From 1aa6da83e2f923a0175a330e61856f5ae616b536 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=98yvind=20Seland?= Date: Sat, 14 Jun 2025 19:18:56 +0200 Subject: [PATCH 01/78] Added options for enthalpy correction programmed by indicate Peter Lauritzen (NCAR) and Thomas Toniazzo (Bjerknes Centre / NORCE) and option for ZM changes programmed by Thomas Toniazzo --- bld/build-namelist | 9 + bld/namelist_files/namelist_defaults_cam.xml | 10 + bld/namelist_files/namelist_definition.xml | 39 + .../camnor_phys/physics/air_composition.F90 | 1287 ++++++ .../camnor_phys/physics/atm_import_export.F90 | 1531 +++++++ .../camnor_phys/physics/cam_diagnostics.F90 | 2356 ++++++++++ .../camnor_phys/physics/cam_thermo.F90 | 2435 ++++++++++ .../camnor_phys/physics/camsrfexch.F90 | 708 +++ .../camnor_phys/physics/check_energy.F90 | 1195 +++++ .../camnor_phys/physics/check_energy_chng.F90 | 426 ++ .../camnor_phys/physics/micro_pumas_cam.F90 | 3908 +++++++++++++++++ .../camnor_phys/physics/physics_types.F90 | 2948 +++++++++++++ src/physics/camnor_phys/physics/physpkg.F90 | 3199 ++++++++++++++ .../camnor_phys/physics/qneg_module.F90 | 493 +++ .../camnor_phys/physics/zm_conv_evap.F90 | 262 ++ .../camnor_phys/physics/zm_conv_intr.F90 | 969 ++++ .../physics/zm_conv_intr.F90.enthalpy-only | 928 ++++ src/physics/camnor_phys/physics/zm_convr.F90 | 3138 +++++++++++++ 18 files changed, 25841 insertions(+) create mode 100644 src/physics/camnor_phys/physics/air_composition.F90 create mode 100644 src/physics/camnor_phys/physics/atm_import_export.F90 create mode 100644 src/physics/camnor_phys/physics/cam_diagnostics.F90 create mode 100644 src/physics/camnor_phys/physics/cam_thermo.F90 create mode 100644 src/physics/camnor_phys/physics/camsrfexch.F90 create mode 100644 src/physics/camnor_phys/physics/check_energy.F90 create mode 100644 src/physics/camnor_phys/physics/check_energy_chng.F90 create mode 100644 src/physics/camnor_phys/physics/micro_pumas_cam.F90 create mode 100644 src/physics/camnor_phys/physics/physics_types.F90 create mode 100644 src/physics/camnor_phys/physics/physpkg.F90 create mode 100644 src/physics/camnor_phys/physics/qneg_module.F90 create mode 100644 src/physics/camnor_phys/physics/zm_conv_evap.F90 create mode 100644 src/physics/camnor_phys/physics/zm_conv_intr.F90 create mode 100644 src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only create mode 100644 src/physics/camnor_phys/physics/zm_convr.F90 diff --git a/bld/build-namelist b/bld/build-namelist index 888ddcd734..2584c8fd9e 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -455,6 +455,7 @@ if ($print>=2) { # Composition of air add_default($nl, 'dry_air_species'); add_default($nl, 'water_species_in_air'); +add_default($nl, 'compute_enthalpy_flux'); # Spectral Element dycore my $dyn = $cfg->get('dyn'); @@ -3866,6 +3867,14 @@ if (!$simple_phys) { add_default($nl, 'zmconv_capelmt'); add_default($nl, 'zmconv_tau'); add_default($nl, 'zmconv_parcel_hscale'); +#+tht + add_default($nl, 'zmconv_tht_thermo'); + add_default($nl, 'zmconv_retrigger' ); + add_default($nl, 'zmconv_tiedke_lnd'); + add_default($nl, 'zmconv_entrmn' ); + add_default($nl, 'zmconv_alfadet' ); + add_default($nl, 'zmconv_plclmin' ); +#-tht } # moist convection rainwater coefficients diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 2bb85fe84f..494ad02cae 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2776,6 +2776,14 @@ See https://github.com/NorESMhub/noresm3_dev_simulations/discussions/78 .false. 0.5 + + 1.0 + .false. + .false. + 2e-4 + 0.1 + 6.e2 + @@ -2986,6 +2994,8 @@ See https://github.com/NorESMhub/noresm3_dev_simulations/discussions/78 'Q','CLDLIQ','CLDICE','RAINQM','SNOWQM' 'Q','CLDLIQ','CLDICE','RAINQM','SNOWQM','GRAUQM' + .false. + diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 60e9d0a9e5..b84edd74a2 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -3234,6 +3234,12 @@ Tunable parcel temperature perturbation in ZM deep convection scheme in units of Default: 0.5K perturbation + +tht: parcel temp perturbation over land in ZM deep convection scheme in units of (K). +Default: 1.0K perturbation + + Tunable triggering threshold for convection in ZM deep scheme in units of (J kg-1). @@ -3258,6 +3264,32 @@ Convective adjustment timescale in units of (s) Default: 3600.0 s + +tht: use moist td to compute plume-ensemble properties +Default: .false. + + +tht: iterate plume-ensemble computation and trigger functions +Default: .false. + + +tht: previously undeclared par: max entr. rate for plume-ens +Default: 2e-4 + + +tht: previously undeclared param: detrainment/entrainment +Default: 0.1 + + +tht: previously undeclared param: min LCL pressure to allow zm +Default: 6e2 + + + +Enthalpy flux terms explicitly computed and added in atmosphere and +passed to MOM6 +Default: TRUE + + shr_kind_r8 + use cam_abortutils, only: endrun + + implicit none + private + save + + public :: air_composition_readnl + public :: air_composition_init + public :: dry_air_composition_update + public :: water_composition_update + + ! get_cp_dry: (generalized) heat capacity for dry air + public :: get_cp_dry + ! get_cp: (generalized) heat capacity + public :: get_cp + ! get_R_dry: (generalized) dry air gas constant + public :: get_R_dry + ! get_R: Compute generalized R + public :: get_R + ! get_mbarv: molecular weight of dry air + public :: get_mbarv + + logical, public :: compute_enthalpy_flux + ! + ! for book keeping of enthalpy variables in physics buffer + ! + integer, parameter, public :: num_enthalpy_vars = 4 ! index for enthalpy flux associated with liquid precipitation + integer, parameter, public :: hliq_idx = 1 ! index for enthalpy flux associated with liquid precipitation + integer, parameter, public :: hice_idx = 2 ! index for enthalpy flux associated with frozen precipiation + integer, parameter, public :: fliq_idx = 3 ! index for flux of liquid precipitation + integer, parameter, public :: fice_idx = 4 ! index for flux of frozen precipitation + + private :: air_species_info + + integer, parameter :: unseti = -HUGE(1) + real(r8), parameter :: unsetr = HUGE(1.0_r8) + + ! composition of air + ! + integer, parameter :: num_names_max = 20 ! Should match namelist definition + character(len=6) :: dry_air_species(num_names_max) + character(len=6) :: water_species_in_air(num_names_max) + + integer, protected, public :: dry_air_species_num + integer, protected, public :: water_species_in_air_num + + ! Thermodynamic variables + integer, protected, public :: thermodynamic_active_species_num = unseti + integer, allocatable, protected, public :: thermodynamic_active_species_idx(:) + integer, allocatable, public :: thermodynamic_active_species_idx_dycore(:) + real(r8), allocatable, protected, public :: thermodynamic_active_species_cp(:) + real(r8), allocatable, protected, public :: thermodynamic_active_species_cv(:) + real(r8), allocatable, protected, public :: thermodynamic_active_species_R(:) + ! thermodynamic_active_species_mwi: inverse molecular weights dry air + real(r8), allocatable, protected, public :: thermodynamic_active_species_mwi(:) + ! thermodynamic_active_species_kv: molecular diffusion + real(r8), allocatable, protected, public :: thermodynamic_active_species_kv(:) + ! thermodynamic_active_species_kc: thermal conductivity + real(r8), allocatable, protected, public :: thermodynamic_active_species_kc(:) + ! + ! for energy computations liquid and ice species need to be identified + ! + ! thermodynamic_active_species_liq_num: number of liquid water species + integer, protected, public :: thermodynamic_active_species_liq_num = unseti + ! thermodynamic_active_species_ice_num: number of frozen water species + integer, protected, public :: thermodynamic_active_species_ice_num = unseti + ! thermodynamic_active_species_liq_idx: index of liquid water species + integer, allocatable, protected, public :: thermodynamic_active_species_liq_idx(:) + ! thermodynamic_active_species_liq_idx_dycore: index of liquid water species + integer, allocatable, public :: thermodynamic_active_species_liq_idx_dycore(:) + ! thermodynamic_active_species_ice_idx: index of ice water species + integer, allocatable, protected, public :: thermodynamic_active_species_ice_idx(:) + ! thermodynamic_active_species_ice_idx_dycore: index of ice water species + integer, allocatable, public :: thermodynamic_active_species_ice_idx_dycore(:) + ! enthalpy_reference_state: choices: 'ice', 'liq', 'vap' !tht:'wv'->'vap' (stick to three characters, 'water' is presumably implicit in all of these...) + character(len=3), public, protected :: enthalpy_reference_state = 'ice' + + integer, protected, public :: wv_idx = -1 ! Water vapor index + + !------------- Variables for consistent themodynamics -------------------- + ! + + ! standard dry air (constant composition) + real(r8), public, protected :: mmro2 = unsetr ! Mass mixing ratio of O2 + real(r8), public, protected :: mmrn2 = unsetr ! Mass mixing ratio of N2 + real(r8), public, protected :: o2_mwi = unsetr ! Inverse mol. weight of O2 + real(r8), public, protected :: n2_mwi = unsetr ! Inverse mol. weight of N2 + real(r8), public, protected :: mbar = unsetr ! Mean mass at mid level + +!tht: explicitly declare reference enthalpies and temperatures for atmosphere and ocean + real(r8), public, protected :: t00o ! Water enthalpy reference temperature, ocean (K) + real(r8), public, protected :: t00a ! Water enthalpy reference temperature, atmosphere (K) + real(r8), public, protected :: h00o ! Material enthalpy zero, liquid reference state, ocean water (J/kg) + real(r8), public, protected :: h00a ! Material enthalpy zero, liquid reference state, atmos water (J/kg) + real(r8), public, protected :: h00a_vap ! Material enthalpy zero, vapor reference state, atmos (J/kg) + real(r8), public, protected :: h00a_ice ! Material enthalpy zero, vapor reference state, atmos (J/kg) + + ! coefficients in expressions for molecular diffusion coefficients + ! kv1,..,kv3 are coefficients for kmvis calculation + ! kc1,..,kc3 are coefficients for kmcnd calculation + ! Liu, H.-L., et al. (2010), Thermosphere extension of the Whole Atmosphere Community Climate Model, + ! J. Geophys. Res., 115, A12302, doi:10.1029/2010JA015586. + real(r8), public, parameter :: kv1 = 4.03_r8 * 1.e-7_r8 + real(r8), public, parameter :: kv2 = 3.42_r8 * 1.e-7_r8 + real(r8), public, parameter :: kv3 = 3.9_r8 * 1.e-7_r8 + real(r8), public, parameter :: kc1 = 56._r8 * 1.e-5_r8 + real(r8), public, parameter :: kc2 = 56._r8 * 1.e-5_r8 + real(r8), public, parameter :: kc3 = 75.9_r8 * 1.e-5_r8 + + real(r8), public, parameter :: kv_temp_exp = 0.69_r8 + real(r8), public, parameter :: kc_temp_exp = 0.69_r8 + + ! cpairv: composition dependent specific heat at constant pressure + real(r8), public, protected, allocatable :: cpairv(:,:,:) + ! rairv: composition dependent gas "constant" + real(r8), public, protected, allocatable :: rairv(:,:,:) + ! cappav: rairv / cpairv + real(r8), public, protected, allocatable :: cappav(:,:,:) + ! mbarv: composition dependent atmosphere mean mass + real(r8), public, protected, allocatable :: mbarv(:,:,:) + ! cp_or_cv_dycore: enthalpy or internal energy scaling factor for + ! energy consistency + real(r8), public, protected, allocatable :: cp_or_cv_dycore(:,:,:) + real(r8), public , allocatable :: te_init(:,:,:)!xxx to be removed + ! + ! Interfaces for public routines + interface get_cp_dry + module procedure get_cp_dry_1hd + module procedure get_cp_dry_2hd + end interface get_cp_dry + + interface get_cp + module procedure get_cp_1hd + module procedure get_cp_2hd + end interface get_cp + + interface get_R_dry + module procedure get_R_dry_1hd + module procedure get_R_dry_2hd + end interface get_R_dry + + interface get_R + module procedure get_R_1hd + module procedure get_R_2hd + end interface get_R + + interface get_mbarv + module procedure get_mbarv_1hd + end interface get_mbarv + +CONTAINS + + ! Read namelist variables. + subroutine air_composition_readnl(nlfile) + use namelist_utils, only: find_group_name + use spmd_utils, only: masterproc, mpicom, masterprocid + use spmd_utils, only: mpi_character, mpi_logical + use cam_logfile, only: iulog + + ! Dummy argument: filepath for file containing namelist input + character(len=*), intent(in) :: nlfile + + ! Local variables + integer :: unitn, ierr, indx + integer, parameter :: lsize = 76 + character(len=*), parameter :: subname = 'air_composition_readnl :: ' + character(len=lsize) :: banner + character(len=lsize) :: bline + + ! Variable components of dry air and water species in air + namelist /air_composition_nl/ dry_air_species, water_species_in_air, compute_enthalpy_flux + !----------------------------------------------------------------------- + + banner = repeat('*', lsize) + bline = "***"//repeat(' ', lsize - 6)//"***" + + ! Read variable components of dry air and water species in air + dry_air_species = (/ (' ', indx = 1, num_names_max) /) + water_species_in_air = (/ (' ', indx = 1, num_names_max) /) + + if (masterproc) then + open(newunit=unitn, file=trim(nlfile), status='old') + call find_group_name(unitn, 'air_composition_nl', status=ierr) + if (ierr == 0) then + read(unitn, air_composition_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname//'ERROR reading namelist, air_composition_nl') + end if + end if + close(unitn) + end if + + call mpi_bcast(compute_enthalpy_flux, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: compute_enthalpy_flux") + + call mpi_bcast(dry_air_species, len(dry_air_species)*num_names_max, & + mpi_character, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: dry_air_species") + call mpi_bcast(water_species_in_air, & + len(water_species_in_air)*num_names_max, mpi_character, & + masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: water_species_in_air") + + dry_air_species_num = 0 + water_species_in_air_num = 0 + do indx = 1, num_names_max + if ( (LEN_TRIM(dry_air_species(indx)) > 0) .and. & + (TRIM(dry_air_species(indx)) /= 'N2')) then + dry_air_species_num = dry_air_species_num + 1 + end if + if (LEN_TRIM(water_species_in_air(indx)) > 0) then + water_species_in_air_num = water_species_in_air_num + 1 + end if + end do + + ! Initialize number of thermodynamically active species + thermodynamic_active_species_num = & + dry_air_species_num + water_species_in_air_num + + if (masterproc) then + if (compute_enthalpy_flux) then + write(iulog, *) "Computing enthalpy flux: compute_enthalpy_flux=",compute_enthalpy_flux + endif + write(iulog, *) banner + write(iulog, *) bline + + if (dry_air_species_num == 0) then + write(iulog, *) " Thermodynamic properties of dry air are ", & + "fixed at troposphere values" + else + write(iulog, *) " Thermodynamic properties of dry air are ", & + "based on variable composition of the following species:" + do indx = 1, dry_air_species_num + write(iulog, *) ' ', trim(dry_air_species(indx)) + end do + write(iulog,*) ' ' + end if + write(iulog,*) " Thermodynamic properties of moist air are ", & + "based on variable composition of the following water species:" + do indx = 1, water_species_in_air_num + write(iulog, *) ' ', trim(water_species_in_air(indx)) + end do + write(iulog, *) bline + write(iulog, *) banner + end if + + end subroutine air_composition_readnl + + !=========================================================================== + + subroutine air_composition_init() + use string_utils, only: int2str + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry, cpwv, latice, latvap, tmelt + use constituents, only: cnst_get_ind, cnst_mw + use ppgrid, only: pcols, pver, begchunk, endchunk + integer :: icnst, ix, isize, ierr, idx + integer :: liq_num, ice_num + integer :: liq_idx(water_species_in_air_num) + integer :: ice_idx(water_species_in_air_num) + logical :: has_liq, has_ice + real(r8) :: mw + + character(len=*), parameter :: subname = 'composition_init' + character(len=*), parameter :: errstr = subname//": failed to allocate " + + ! + ! define cp and R for species in species_name + ! + ! Last major species in namelist dry_air_species is derived from the + ! other major species (since the sum of dry mixing ratios for + ! major species of dry air add must add to one) + ! + ! cv = R * dofx / 2; cp = R * (1 + (dofx / 2)) + ! DOF == Degrees of Freedom + ! dof1 = monatomic ideal gas, 3 translational DOF + real(r8), parameter :: dof1 = 3._r8 + real(r8), parameter :: cv1 = 0.5_r8 * r_universal * dof1 + real(r8), parameter :: cp1 = 0.5_r8 * r_universal * (2._r8 + dof1) + ! dof2 = diatomic ideal gas, 3 translational + 2 rotational = 5 DOF + real(r8), parameter :: dof2 = 5._r8 + real(r8), parameter :: cv2 = 0.5_r8 * r_universal * dof2 + real(r8), parameter :: cp2 = 0.5_r8 * r_universal * (2._r8 + dof2) + ! dof3 = polyatomic ideal gas, 3 translational + 3 rotational = 6 DOF + real(r8), parameter :: dof3 = 6._r8 + real(r8), parameter :: cv3 = 0.5_r8 * r_universal * dof3 + real(r8), parameter :: cp3 = 0.5_r8 * r_universal * (2._r8 + dof3) + + liq_num = 0 + ice_num = 0 + has_liq = .false. + has_ice = .false. + ! standard dry air (constant composition) + o2_mwi = 1._r8 / 32._r8 + n2_mwi = 1._r8 / 28._r8 + mmro2 = 0.235_r8 + mmrn2 = 0.765_r8 + mbar = 1._r8 / ((mmro2 * o2_mwi) + (mmrn2 * n2_mwi)) + + ! init for variable composition dry air + + isize = dry_air_species_num + water_species_in_air_num + allocate(thermodynamic_active_species_idx(isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_idx") + end if + allocate(thermodynamic_active_species_idx_dycore(isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_idx_dycore") + end if + allocate(thermodynamic_active_species_cp(0:isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_cp") + end if + allocate(thermodynamic_active_species_cv(0:isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_cv") + end if + allocate(thermodynamic_active_species_R(0:isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_R") + end if + + isize = dry_air_species_num + allocate(thermodynamic_active_species_mwi(0:isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_mwi") + end if + allocate(thermodynamic_active_species_kv(0:isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_kv") + end if + allocate(thermodynamic_active_species_kc(0:isize), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_kc") + end if + !------------------------------------------------------------------------ + ! Allocate constituent dependent properties + !------------------------------------------------------------------------ + allocate(cpairv(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"cpairv") + end if + allocate(rairv(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"rairv") + end if + allocate(cappav(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"cappav") + end if + allocate(mbarv(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"mbarv") + end if + allocate(cp_or_cv_dycore(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"cp_or_cv_dycore") + end if + allocate(te_init(pcols,4,begchunk:endchunk), stat=ierr)!xxx to be removed + thermodynamic_active_species_idx = -HUGE(1) + thermodynamic_active_species_idx_dycore = -HUGE(1) + thermodynamic_active_species_cp = 0.0_r8 + thermodynamic_active_species_cv = 0.0_r8 + thermodynamic_active_species_R = 0.0_r8 + thermodynamic_active_species_mwi = 0.0_r8 + thermodynamic_active_species_kv = 0.0_r8 + thermodynamic_active_species_kc = 0.0_r8 + !------------------------------------------------------------------------ + ! Initialize constituent dependent properties + !------------------------------------------------------------------------ + cpairv(:pcols, :pver, begchunk:endchunk) = cpair + rairv(:pcols, :pver, begchunk:endchunk) = rair + cappav(:pcols, :pver, begchunk:endchunk) = rair / cpair + mbarv(:pcols, :pver, begchunk:endchunk) = mwdry + ! + if (dry_air_species_num > 0) then + ! + ! The last major species in dry_air_species is derived from the + ! others and constants associated with it are initialized here + ! + if (TRIM(dry_air_species(dry_air_species_num + 1)) == 'N2') then + call air_species_info('N', ix, mw) + mw = 2.0_r8 * mw + icnst = 0 ! index for the derived tracer N2 + thermodynamic_active_species_cp(icnst) = cp2 / mw + thermodynamic_active_species_cv(icnst) = cv2 / mw !N2 + thermodynamic_active_species_R (icnst) = r_universal / mw + thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw + thermodynamic_active_species_kv(icnst) = kv2 + thermodynamic_active_species_kc(icnst) = kc2 + ! + ! if last major species is not N2 then add code here + ! + else + write(iulog, *) subname, ' derived major species not found: ', & + dry_air_species(dry_air_species_num) + call endrun(subname//': derived major species not found') + end if + else + ! + ! dry air is not species dependent + ! + icnst = 0 + thermodynamic_active_species_cp (icnst) = cpair + thermodynamic_active_species_cv (icnst) = cpair - rair + thermodynamic_active_species_R (icnst) = rair + end if + ! + !************************************************************************ + ! + ! add prognostic components of dry air + ! + !************************************************************************ + ! + icnst = 1 + do idx = 1, dry_air_species_num + select case (TRIM(dry_air_species(idx))) + ! + ! O + ! + case('O') + call air_species_info('O', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cp1 / mw + thermodynamic_active_species_cv (icnst) = cv1 / mw + thermodynamic_active_species_R (icnst) = r_universal / mw + thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw + thermodynamic_active_species_kv(icnst) = kv3 + thermodynamic_active_species_kc(icnst) = kc3 + icnst = icnst + 1 + ! + ! O2 + ! + case('O2') + call air_species_info('O2', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cp2 / mw + thermodynamic_active_species_cv (icnst) = cv2 / mw + thermodynamic_active_species_R (icnst) = r_universal / mw + thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw + thermodynamic_active_species_kv(icnst) = kv1 + thermodynamic_active_species_kc(icnst) = kc1 + icnst = icnst + 1 + ! + ! H + ! + case('H') + call air_species_info('H', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cp1 / mw + thermodynamic_active_species_cv (icnst) = cv1 / mw + thermodynamic_active_species_R (icnst) = r_universal / mw + thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw + ! Hydrogen not included in calculation of diffusivity and conductivity + thermodynamic_active_species_kv(icnst) = 0.0_r8 + thermodynamic_active_species_kc(icnst) = 0.0_r8 + icnst = icnst + 1 + ! + ! If support for more major species is to be included add code here + ! + case default + write(iulog, *) subname, ' dry air component not found: ', & + dry_air_species(idx) + call endrun(subname//': dry air component not found') + end select + + if (masterproc) then + write(iulog, *) "Dry air composition ", & + TRIM(dry_air_species(idx)), & + icnst-1,thermodynamic_active_species_idx(icnst-1), & + thermodynamic_active_species_mwi(icnst-1), & + thermodynamic_active_species_cp(icnst-1), & + thermodynamic_active_species_cv(icnst-1) + end if + end do + isize = dry_air_species_num+1 + icnst = 0 ! N2 + if(isize > 0) then + if(masterproc) then + write(iulog, *) "Dry air composition ", & + TRIM(dry_air_species(idx)), & + icnst, -1, thermodynamic_active_species_mwi(icnst), & + thermodynamic_active_species_cp(icnst), & + thermodynamic_active_species_cv(icnst) + end if + end if + ! + !************************************************************************ + ! + ! Add non-dry components of moist air (water vapor and condensates) + ! + !************************************************************************ + ! + icnst = dry_air_species_num + 1 + do idx = 1, water_species_in_air_num + select case (TRIM(water_species_in_air(idx))) + ! + ! Q + ! + case('Q') + call air_species_info('Q', ix, mw) + wv_idx = ix + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cpwv + thermodynamic_active_species_cv (icnst) = cv3 / mw + thermodynamic_active_species_R (icnst) = rh2o + icnst = icnst + 1 + ! + ! CLDLIQ + ! + case('CLDLIQ') + call air_species_info('CLDLIQ', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cpliq + thermodynamic_active_species_cv (icnst) = cpliq + liq_num = liq_num+1 + liq_idx (liq_num) = ix + icnst = icnst + 1 + has_liq = .true. + ! + ! CLDICE + ! + case('CLDICE') + call air_species_info('CLDICE', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cpice + thermodynamic_active_species_cv (icnst) = cpice + ice_num = ice_num+1 + ice_idx(ice_num) = ix + icnst = icnst + 1 + has_ice = .true. + ! + ! RAINQM + ! + case('RAINQM') + call air_species_info('RAINQM', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cpliq + thermodynamic_active_species_cv (icnst) = cpliq + liq_num = liq_num+1 + liq_idx(liq_num) = ix + icnst = icnst + 1 + has_liq = .true. + ! + ! SNOWQM + ! + case('SNOWQM') + call air_species_info('SNOWQM', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cpice + thermodynamic_active_species_cv (icnst) = cpice + ice_num = ice_num+1 + ice_idx(ice_num) = ix + icnst = icnst + 1 + has_ice = .true. + ! + ! GRAUQM + ! + case('GRAUQM') + call air_species_info('GRAUQM', ix, mw) + thermodynamic_active_species_idx(icnst) = ix + thermodynamic_active_species_cp (icnst) = cpice + thermodynamic_active_species_cv (icnst) = cpice + ice_num = ice_num+1 + ice_idx(ice_num) = ix + icnst = icnst + 1 + has_ice = .true. + ! + ! If support for more major species is to be included add code here + ! + case default + write(iulog, *) subname, ' moist air component not found: ', & + water_species_in_air(idx) + call endrun(subname//': moist air component not found') + end select + ! + ! + ! + if (masterproc) then + write(iulog, *) "Thermodynamic active species ", & + TRIM(water_species_in_air(idx)) + write(iulog, *) " global index : ", & + icnst-1 + write(iulog, *) " thermodynamic_active_species_idx : ", & + thermodynamic_active_species_idx(icnst-1) + write(iulog, *) " cp : ", & + thermodynamic_active_species_cp(icnst-1) + write(iulog, *) " cv : ", & + thermodynamic_active_species_cv(icnst-1) + if (has_liq) then + write(iulog, *) " register phase (liquid or ice) :", & + " liquid" + end if + if (has_ice) then + write(iulog, *) " register phase (liquid or ice) :", & + " ice" + end if + write(iulog, *) " " + end if + has_liq = .false. + has_ice = .false. + end do + + allocate(thermodynamic_active_species_liq_idx(liq_num), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_liq_idx") + end if + allocate(thermodynamic_active_species_liq_idx_dycore(liq_num), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_liq_idx_dycore") + end if + allocate(thermodynamic_active_species_ice_idx(ice_num), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_ice_idx") + end if + allocate(thermodynamic_active_species_ice_idx_dycore(ice_num), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"thermodynamic_active_species_ice_idx_dycore") + end if + + thermodynamic_active_species_liq_idx = liq_idx(1:liq_num) + thermodynamic_active_species_liq_num = liq_num + + ! array initialized by the dycore + thermodynamic_active_species_liq_idx_dycore = -99 + + thermodynamic_active_species_ice_idx = ice_idx(1:ice_num) + thermodynamic_active_species_ice_num = ice_num + + ! array initialized by the dycore + thermodynamic_active_species_ice_idx_dycore = -99 + + if (water_species_in_air_num /= 1 + liq_num+ice_num) then + write(iulog, '(2a,2(i0,a))') subname, & + " water_species_in_air_num = ", & + water_species_in_air_num, ", should be ", & + (1 + liq_num + ice_num), " (1 + liq_num + ice_num)" + call endrun(subname//': water_species_in_air_num /= 1+liq_num+ice_num') + end if + +!tht: nasty hard-wiring here + enthalpy_reference_state = 'ice' + if (masterproc) then + write(iulog, *) 'Enthalpy reference state : ', & + TRIM(enthalpy_reference_state) + end if + +!tht: initialising t00's, h00's here + ! N.B. latent heats should be adjusted to t00a, but unless t00a=tmelt, + ! this will break all physics + ! physics and SE dycore make different, mutually inconsistent, + ! hard-wired assumptions on t00 and h00: + ! physics : t00=tmelt, h00(ice)=L(ice; liq, T=tmelt) + ! dynamics (SE): t00=0, h00=0 + ! As a result, any water non-conservation in the dycore results in fixer + ! increments, proportional to h00a as set below. + + !ocean choice for enthalpy at T=0 (liquid reference phase) + t00o = tmelt + h00o = -cpliq*t00o + + !atmo choices for enthalpy at T=0 (liquid ref. phase): + if(.not.compute_enthalpy_flux)then + t00a = 0._r8 + h00a = 0._r8 + h00a_ice = 0._r8 + h00a_vap = 0._r8 + else + t00a = tmelt + h00a = -cpliq*t00a + if (enthalpy_reference_state.eq.'ice') then + !h00a =-((cpliq-cpice)*t00a - latice) ! cam default h00a_ice=0 (minimizes fixer increments) + h00a = -cpliq*t00a ! conserve single formula for global energy + else if (enthalpy_reference_state.eq.'vap') then + h00a =-((cpliq-cpwv )*t00a + latvap) + endif + ! the following ensure that the value of atmospheric enthalpy is independent of reference state + h00a_vap= h00a+((cpliq-cpwv )*t00a + latvap) + h00a_ice= h00a+((cpliq-cpice)*t00a - latice) + endif + + if (masterproc) then + write(iulog, *) ' ocean t00o: ', t00o + write(iulog, *) ' ocean h00o: ', h00o + write(iulog, *) 'atmos. enthalpy_reference_state: ', trim(enthalpy_reference_state) + write(iulog, *) ' t00a: ', t00a + write(iulog, *) ' h00a: ', h00a + write(iulog, *) ' h00a_ice: ', h00a_ice + write(iulog, *) ' h00a_vap: ', h00a_vap + endif + ! call MPI_bcast(t00o , 1, mpi_real8, masterprocid, mpicom, ierr) + ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: t00o ") + ! call MPI_bcast(h00o , 1, mpi_real8, masterprocid, mpicom, ierr) + ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00o ") + ! call MPI_bcast(t00a , 1, mpi_real8, masterprocid, mpicom, ierr) + ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: t00a ") + ! call MPI_bcast(h00a , 1, mpi_real8, masterprocid, mpicom, ierr) + ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00a ") + ! call MPI_bcast(h00a_ice, 1, mpi_real8, masterprocid, mpicom, ierr) + ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00a_ice") + ! call MPI_bcast(h00a_vap, 1, mpi_real8, masterprocid, mpicom, ierr) + ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00a_vap") +!-tht + + end subroutine air_composition_init + + !=========================================================================== + !----------------------------------------------------------------------- + ! dry_air_composition_update: Update the physics "constants" that vary + !------------------------------------------------------------------------- + !=========================================================================== + + subroutine dry_air_composition_update(mmr, lchnk, ncol, to_dry_factor) + use cam_abortutils, only: endrun + !(mmr = dry mixing ratio, if not, use to_dry_factor to convert!) + real(r8), intent(in) :: mmr(:,:,:) ! mixing ratios for species dependent dry air + integer, intent(in) :: lchnk ! Chunk number + integer, intent(in) :: ncol ! number of columns + real(r8), optional, intent(in) :: to_dry_factor(:,:) + + call get_R_dry(mmr(:ncol, :, :), thermodynamic_active_species_idx, & + rairv(:ncol, :, lchnk), fact=to_dry_factor) + call get_cp_dry(mmr(:ncol,:,:), thermodynamic_active_species_idx, & + cpairv(:ncol,:,lchnk), fact=to_dry_factor) + call get_mbarv(mmr(:ncol,:,:), thermodynamic_active_species_idx, & + mbarv(:ncol,:,lchnk), fact=to_dry_factor) + cappav(:ncol,:,lchnk) = rairv(:ncol,:,lchnk) / cpairv(:ncol,:,lchnk) + end subroutine dry_air_composition_update + + !=========================================================================== + !--------------------------------------------------------------------------- + ! water_composition_update: Update generalized cp or cv depending on dycore + !--------------------------------------------------------------------------- + !=========================================================================== + + subroutine water_composition_update(mmr, lchnk, ncol, vcoord, to_dry_factor) + use cam_abortutils, only: endrun + use string_utils, only: int2str + use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure + real(r8), intent(in) :: mmr(:,:,:) ! constituents array + integer, intent(in) :: lchnk ! Chunk number + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: vcoord + real(r8), optional, intent(in) :: to_dry_factor(:,:) + + character(len=*), parameter :: subname = 'water_composition_update' + + if (vcoord==vc_dry_pressure) then + call get_cp(mmr(:ncol,:,:),.false.,cp_or_cv_dycore(:ncol,:,lchnk), factor=to_dry_factor, & + active_species_idx_dycore=thermodynamic_active_species_idx,cpdry=cpairv(:ncol,:,lchnk)) + else if (vcoord==vc_height) then + call get_R(mmr(:ncol,:,:), thermodynamic_active_species_idx, & + cp_or_cv_dycore(:ncol,:,lchnk), fact=to_dry_factor, Rdry=rairv(:ncol,:,lchnk)) + ! + ! internal energy coefficient for MPAS + ! (equation 92 in Eldred et al. 2023; https://rmets.onlinelibrary.wiley.com/doi/epdf/10.1002/qj.4353) + ! + cp_or_cv_dycore(:ncol,:,lchnk)=cp_or_cv_dycore(:ncol,:,lchnk)*& + (cpairv(:ncol,:,lchnk)-rairv(:ncol,:,lchnk)) /rairv(:ncol,:,lchnk) + else if (vcoord==vc_moist_pressure) then + ! no update needed for moist pressure vcoord + else + call endrun(subname//" vertical coordinate not supported; vcoord="// int2str(vcoord)) + end if + end subroutine water_composition_update + + !=========================================================================== + !*************************************************************************** + ! + ! get_cp_dry: Compute dry air heat capacity under constant pressure + ! + !*************************************************************************** + ! + subroutine get_cp_dry_1hd(tracer, active_species_idx, cp_dry, fact) + use cam_abortutils, only: endrun + use string_utils, only: int2str + use physconst, only: cpair + + ! Dummy arguments + ! tracer: tracer array + real(r8), intent(in) :: tracer(:,:,:) + integer, intent(in) :: active_species_idx(:) + ! fact: optional dry pressure level thickness + real(r8), optional, intent(in) :: fact(:,:) + ! cp_dry: dry air heat capacity under constant pressure + real(r8), intent(out) :: cp_dry(:,:) + + ! Local variables + integer :: idx, kdx , m_cnst, qdx + ! factor: dry pressure level thickness + real(r8) :: factor(SIZE(cp_dry, 1), SIZE(cp_dry, 2)) + real(r8) :: residual(SIZE(cp_dry, 1), SIZE(cp_dry, 2)) + real(r8) :: mmr + character(len=*), parameter :: subname = 'get_cp_dry_1hd: ' + + if (dry_air_species_num == 0) then + ! dry air heat capacity not species dependent + cp_dry = cpair + else + ! dry air heat capacity is species dependent + if (present(fact)) then + if (SIZE(fact, 1) /= SIZE(factor, 1)) then + call endrun(subname//"SIZE mismatch in dimension 1 "// & + int2str(SIZE(fact, 1))//' /= '//int2str(SIZE(factor, 1))) + end if + if (SIZE(fact, 2) /= SIZE(factor, 2)) then + call endrun(subname//"SIZE mismatch in dimension 2 "// & + int2str(SIZE(fact, 2))//' /= '//int2str(SIZE(factor, 2))) + end if + factor = fact(:,:) + else + factor = 1.0_r8 + end if + + cp_dry = 0.0_r8 + residual = 1.0_r8 + do qdx = 1, dry_air_species_num + m_cnst = active_species_idx(qdx) + do kdx = 1, SIZE(cp_dry, 2) + do idx = 1, SIZE(cp_dry, 1) + mmr = tracer(idx, kdx, m_cnst) * factor(idx, kdx) + cp_dry(idx, kdx) = cp_dry(idx, kdx) + & + (thermodynamic_active_species_cp(qdx) * mmr) + residual(idx, kdx) = residual(idx, kdx) - mmr + end do + end do + end do + qdx = 0 ! N2 + do kdx = 1, SIZE(cp_dry, 2) + do idx = 1, SIZE(cp_dry, 1) + cp_dry(idx, kdx) = cp_dry(idx, kdx) + & + (thermodynamic_active_species_cp(qdx) * residual(idx, kdx)) + end do + end do + end if + end subroutine get_cp_dry_1hd + + !=========================================================================== + + subroutine get_cp_dry_2hd(tracer, active_species_idx, cp_dry, fact) + ! Version of get_cp_dry for arrays that have a second horizontal index + + ! Dummy arguments + ! tracer: tracer array + real(r8), intent(in) :: tracer(:,:,:,:) + integer, intent(in) :: active_species_idx(:) + ! fact: optional dry pressure level thickness + real(r8), optional, intent(in) :: fact(:,:,:) + ! cp_dry: dry air heat capacity under constant pressure + real(r8), intent(out) :: cp_dry(:,:,:) + + ! Local variable + integer :: jdx + + do jdx = 1, SIZE(cp_dry, 2) + if (present(fact)) then + call get_cp_dry(tracer(:,jdx,:,:), active_species_idx, & + cp_dry(:,jdx,:), fact=fact(:,jdx,:)) + else + call get_cp_dry(tracer(:,jdx,:,:), active_species_idx, & + cp_dry(:,jdx,:)) + end if + end do + + end subroutine get_cp_dry_2hd + + !=========================================================================== + ! + !*************************************************************************** + ! + ! get_cp: Compute generalized heat capacity at constant pressure + ! + !*************************************************************************** + ! + subroutine get_cp_1hd(tracer, inv_cp, cp, factor, active_species_idx_dycore, cpdry) + use cam_abortutils, only: endrun + use string_utils, only: int2str + + ! Dummy arguments + ! tracer: Tracer array + ! + ! factor not present then tracer must be dry mixing ratio + ! if factor present tracer*factor must be dry mixing ratio + ! + real(r8), intent(in) :: tracer(:,:,:) + ! inv_cp: output inverse cp instead of cp + logical, intent(in) :: inv_cp + real(r8), intent(out) :: cp(:,:) + ! dp: if provided then tracer is mass not mixing ratio + real(r8), optional, intent(in) :: factor(:,:) + ! active_species_idx_dycore: array of indices for index of + ! thermodynamic active species in dycore tracer array + ! (if different from physics index) + integer, optional, intent(in) :: active_species_idx_dycore(:) + real(r8),optional, intent(in) :: cpdry(:,:) + + ! LOCAL VARIABLES + integer :: qdx, itrac + real(r8) :: sum_species(SIZE(cp, 1), SIZE(cp, 2)) + real(r8) :: sum_cp(SIZE(cp, 1), SIZE(cp, 2)) + real(r8) :: factor_local(SIZE(cp, 1), SIZE(cp, 2)) + integer :: idx_local(thermodynamic_active_species_num) + character(LEN=*), parameter :: subname = 'get_cp_1hd: ' + + if (present(active_species_idx_dycore)) then + if (SIZE(active_species_idx_dycore) /= & + thermodynamic_active_species_num) then + call endrun(subname//"SIZE mismatch "// & + int2str(SIZE(active_species_idx_dycore))//' /= '// & + int2str(thermodynamic_active_species_num)) + end if + idx_local = active_species_idx_dycore + else + idx_local = thermodynamic_active_species_idx + end if + + if (present(factor)) then + factor_local = factor + else + factor_local = 1.0_r8 + end if + + sum_species = 1.0_r8 ! all dry air species sum to 1 + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + itrac = idx_local(qdx) + sum_species(:,:) = sum_species(:,:) + (tracer(:,:,itrac) * factor_local(:,:)) + end do + + if (dry_air_species_num == 0) then + sum_cp = thermodynamic_active_species_cp(0) + else if (present(cpdry)) then + ! + ! if cpdry is known don't recompute + ! + sum_cp = cpdry + else + call get_cp_dry(tracer, idx_local, sum_cp, fact=factor_local) + end if + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + itrac = idx_local(qdx) + sum_cp(:,:) = sum_cp(:,:)+ & + thermodynamic_active_species_cp(qdx) * tracer(:,:,itrac)* factor_local(:,:) + end do + if (inv_cp) then + cp = sum_species / sum_cp + else + cp = sum_cp / sum_species + end if + end subroutine get_cp_1hd + + !=========================================================================== + + subroutine get_cp_2hd(tracer, inv_cp, cp, factor, active_species_idx_dycore, cpdry) + ! Version of get_cp for arrays that have a second horizontal index + use cam_abortutils, only: endrun + use string_utils, only: int2str + + ! Dummy arguments + ! tracer: Tracer array + ! + real(r8), intent(in) :: tracer(:,:,:,:) + ! inv_cp: output inverse cp instead of cp + logical, intent(in) :: inv_cp + real(r8), intent(out) :: cp(:,:,:) + real(r8), optional, intent(in) :: factor(:,:,:) + real(r8), optional, intent(in) :: cpdry(:,:,:) + + ! active_species_idx_dycore: array of indicies for index of + ! thermodynamic active species in dycore tracer array + ! (if different from physics index) + integer, optional, intent(in) :: active_species_idx_dycore(:) + + ! Local variables + integer :: jdx + integer :: idx_local(thermodynamic_active_species_num) + character(len=*), parameter :: subname = 'get_cp_2hd: ' + + do jdx = 1, SIZE(cp, 2) + if (present(factor).and.present(cpdry)) then + call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& + factor=factor(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore, cpdry=cpdry(:,jdx,:)) + else if (present(factor)) then + call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& + factor=factor(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore) + else if (present(cpdry)) then + call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& + active_species_idx_dycore=active_species_idx_dycore, cpdry=cpdry(:,jdx,:)) + else + call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& + active_species_idx_dycore=active_species_idx_dycore) + end if + end do + + end subroutine get_cp_2hd + + !=========================================================================== + + !*************************************************************************** + ! + ! get_R_dry: Compute generalized dry air gas constant R + ! + !*************************************************************************** + ! + subroutine get_R_dry_1hd(tracer, active_species_idx_dycore, R_dry, fact) + use physconst, only: rair + + ! tracer: tracer array + real(r8), intent(in) :: tracer(:, :, :) + ! active_species_idx_dycore: index of active species in tracer + integer, intent(in) :: active_species_idx_dycore(:) + ! R_dry: dry air R + real(r8), intent(out) :: R_dry(:, :) + ! fact: optional factor for converting tracer to dry mixing ratio + real(r8), optional, intent(in) :: fact(:, :) + + ! Local variables + integer :: idx, kdx, m_cnst, qdx + real(r8) :: factor(SIZE(tracer, 1), SIZE(tracer, 2)) + real(r8) :: residual(SIZE(R_dry, 1), SIZE(R_dry, 2)) + real(r8) :: mmr + + if (dry_air_species_num == 0) then + ! + ! dry air not species dependent + ! + R_dry = rair + else + if (present(fact)) then + factor = fact(:,:) + else + factor = 1.0_r8 + end if + + R_dry = 0.0_r8 + residual = 1.0_r8 + do qdx = 1, dry_air_species_num + m_cnst = active_species_idx_dycore(qdx) + do kdx = 1, SIZE(R_dry, 2) + do idx = 1, SIZE(R_dry, 1) + mmr = tracer(idx, kdx, m_cnst) * factor(idx, kdx) + R_dry(idx, kdx) = R_dry(idx, kdx) + & + (thermodynamic_active_species_R(qdx) * mmr) + residual(idx, kdx) = residual(idx, kdx) - mmr + end do + end do + end do + ! + ! N2 derived from the others + ! + qdx = 0 + do kdx = 1, SIZE(R_dry, 2) + do idx = 1, SIZE(R_dry, 1) + R_dry(idx, kdx) = R_dry(idx, kdx) + & + (thermodynamic_active_species_R(qdx) * residual(idx, kdx)) + end do + end do + end if + end subroutine get_R_dry_1hd + + !=========================================================================== + + subroutine get_R_dry_2hd(tracer, active_species_idx_dycore, R_dry, fact) + ! Version of get_R_dry for arrays that have a second horizontal index + + ! tracer: tracer array + real(r8), intent(in) :: tracer(:, :, :, :) + ! active_species_idx_dycore: index of active species in tracer + integer, intent(in) :: active_species_idx_dycore(:) + ! R_dry: dry air R + real(r8), intent(out) :: R_dry(:, :, :) + ! fact: optional factor for converting tracer to dry mixing ratio + real(r8), optional, intent(in) :: fact(:, :, :) + + ! Local variable + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(fact)) then + call get_R_dry(tracer(:, jdx, :, :), active_species_idx_dycore, & + R_dry(:, jdx, :), fact=fact(:, jdx, :)) + else + call get_R_dry(tracer(:, jdx, :, :), active_species_idx_dycore, & + R_dry(:, jdx, :)) + end if + end do + + end subroutine get_R_dry_2hd + + !=========================================================================== + ! + !*************************************************************************** + ! + ! get_R: Compute generalized R + ! This code (both 1hd and 2hd) is currently unused and untested + ! + !*************************************************************************** + ! + subroutine get_R_1hd(tracer, active_species_idx, R, fact, Rdry) + use cam_abortutils, only: endrun + use string_utils, only: int2str + use physconst, only: rair + + ! Dummy arguments + ! tracer: !tracer array + real(r8), intent(in) :: tracer(:, :, :) + ! active_species_idx: index of active species in tracer + integer, intent(in) :: active_species_idx(:) + ! R: generalized gas constant + real(r8), intent(out) :: R(:, :) + ! fact: optional factor for converting tracer to dry mixing ratio + real(r8), optional, intent(in) :: fact(:, :) + real(r8), optional, intent(in) :: Rdry(:, :) + + ! Local variables + integer :: qdx, itrac + real(r8) :: factor(SIZE(tracer, 1), SIZE(tracer, 2)) + real(r8) :: sum_species(SIZE(R, 1), SIZE(R, 2)) + integer :: idx_local(thermodynamic_active_species_num) + + character(len=*), parameter :: subname = 'get_R_1hd: ' + + if (present(fact)) then + if (SIZE(fact, 1) /= SIZE(factor, 1)) then + call endrun(subname//"SIZE mismatch in dimension 1 "// & + int2str(SIZE(fact, 1))//' /= '//int2str(SIZE(factor, 1))) + end if + if (SIZE(fact, 2) /= SIZE(factor, 2)) then + call endrun(subname//"SIZE mismatch in dimension 2 "// & + int2str(SIZE(fact, 2))//' /= '//int2str(SIZE(factor, 2))) + end if + factor = fact(:,:) + else + factor = 1.0_r8 + end if + + if (dry_air_species_num == 0) then + R = rair + else if (present(Rdry)) then + R = Rdry + else + call get_R_dry(tracer, active_species_idx, R, fact=factor) + end if + + idx_local = active_species_idx + sum_species = 1.0_r8 ! all dry air species sum to 1 + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + itrac = idx_local(qdx) + sum_species(:,:) = sum_species(:,:) + & + (tracer(:,:,itrac) * factor(:,:)) + end do + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + itrac = idx_local(qdx) + R(:,:) = R(:,:) + & + (thermodynamic_active_species_R(qdx) * tracer(:,:,itrac) * & + factor(:,:)) + end do + R = R / sum_species + end subroutine get_R_1hd + + !=========================================================================== + + subroutine get_R_2hd(tracer, active_species_idx, R, fact) + + ! Dummy arguments + ! tracer: !tracer array + real(r8), intent(in) :: tracer(:, :, :, :) + ! active_species_idx: index of active species in tracer + integer, intent(in) :: active_species_idx(:) + ! R: generalized gas constant + real(r8), intent(out) :: R(:, :, :) + ! fact: optional factor for converting tracer to dry mixing ratio + real(r8), optional, intent(in) :: fact(:, :, :) + + ! Local variable + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(fact)) then + call get_R(tracer(:, jdx, :, :), active_species_idx, & + R(:, jdx, :), fact=fact(:, jdx, :)) + else + call get_R(tracer(:, jdx, :, :), active_species_idx, & + R(:, jdx, :)) + end if + end do + + end subroutine get_R_2hd + + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute molecular weight dry air + ! + !************************************************************************************************************************* + ! + subroutine get_mbarv_1hd(tracer, active_species_idx, mbarv_in, fact) + use physconst, only: mwdry + real(r8), intent(in) :: tracer(:,:,:) !tracer array + integer, intent(in) :: active_species_idx(:) !index of active species in tracer + real(r8), intent(out) :: mbarv_in(:,:) !molecular weight of dry air + real(r8), optional, intent(in) :: fact(:,:) !factor for converting tracer to dry mixing ratio + + integer :: idx, kdx, m_cnst, qdx + real(r8):: factor(SIZE(mbarv_in, 1), SIZE(mbarv_in, 2)) + real(r8):: residual(SIZE(tracer, 1), SIZE(mbarv_in, 2)) + real(r8):: mm + ! + ! dry air not species dependent + ! + if (dry_air_species_num==0) then + mbarv_in = mwdry + else + if (present(fact)) then + factor(:,:) = fact(:,:) + else + factor(:,:) = 1.0_r8 + endif + + mbarv_in = 0.0_r8 + residual = 1.0_r8 + do qdx = 1, dry_air_species_num + m_cnst = active_species_idx(qdx) + do kdx = 1, SIZE(mbarv_in, 2) + do idx = 1, SIZE(mbarv_in, 1) + mm = tracer(idx, kdx, m_cnst) * factor(idx, kdx) + mbarv_in(idx, kdx) = mbarv_in(idx, kdx) + thermodynamic_active_species_mwi(qdx) * mm + residual(idx, kdx) = residual(idx, kdx) - mm + end do + end do + end do + qdx = 0 ! N2 + do kdx = 1, SIZE(mbarv_in, 2) + do idx = 1, SIZE(mbarv_in, 1) + mbarv_in(idx, kdx) = mbarv_in(idx, kdx) + thermodynamic_active_species_mwi(qdx) * residual(idx, kdx) + end do + end do + mbarv_in(:,:) = 1.0_r8 / mbarv_in(:,:) + end if + end subroutine get_mbarv_1hd + + !=========================================================================== + + subroutine air_species_info(name, index, molec_weight, caller) + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use constituents, only: cnst_get_ind, cnst_mw + ! Find the constituent index of and return it in + ! . Return the constituent molecular weight in + ! + + ! Dummy arguments + character(len=*), intent(in) :: name + integer, intent(out) :: index + real(r8), intent(out) :: molec_weight + character(len=*), optional, intent(in) :: caller + ! Local parameter + character(len=*), parameter :: subname = 'air_species_info: ' + + call cnst_get_ind(trim(name), index, abort=.false.) + if (index < 1) then + if (present(caller)) then + write(iulog, *) trim(caller), ": air component not found, '", & + trim(name), "'" + call endrun(trim(caller)//": air component not found, '"// & + trim(name)//"'") + else + write(iulog, *) subname, "air component not found, '", & + trim(name), "'" + call endrun(subname//"air component not found, '"// & + trim(name)//"'") + end if + else + molec_weight = cnst_mw(index) + end if + + end subroutine air_species_info + + +end module air_composition diff --git a/src/physics/camnor_phys/physics/atm_import_export.F90 b/src/physics/camnor_phys/physics/atm_import_export.F90 new file mode 100644 index 0000000000..054854689e --- /dev/null +++ b/src/physics/camnor_phys/physics/atm_import_export.F90 @@ -0,0 +1,1531 @@ +module atm_import_export + + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected + use NUOPC_Model , only : NUOPC_ModelGet + use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet, ESMF_Field + use ESMF , only : ESMF_Clock + use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError + use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag + use ESMF , only : operator(/=), operator(==) + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs, cx=>shr_kind_cx + use shr_sys_mod , only : shr_sys_abort + use shr_mpi_mod , only : shr_mpi_min, shr_mpi_max + use nuopc_shr_methods , only : chkerr + use cam_logfile , only : iulog + use cam_history , only: outfld + use spmd_utils , only : masterproc, mpicom + use srf_field_check , only : set_active_Sl_ram1 + use srf_field_check , only : set_active_Sl_fv + use srf_field_check , only : set_active_Sl_soilw + use srf_field_check , only : set_active_Fall_flxdst1 + use srf_field_check , only : set_active_Fall_flxvoc + use srf_field_check , only : set_active_Fall_flxfire + use srf_field_check , only : set_active_Fall_fco2_lnd + use srf_field_check , only : set_active_Faoo_fco2_ocn + use atm_stream_ndep , only : stream_ndep_init, stream_ndep_interp, stream_ndep_is_initialized + use atm_stream_ndep , only : ndep_stream_active + use chemistry , only : chem_has_ndep_flx + use cam_control_mod , only : aqua_planet, simple_phys + + implicit none + private ! except + + public :: read_surface_fields_namelists + public :: advertise_fields + public :: realize_fields + public :: import_fields + public :: export_fields + + private :: fldlist_add + private :: fldlist_realize + private :: state_getfldptr + + type fldlist_type + character(len=128) :: stdname + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 + end type fldlist_type + + integer , parameter :: fldsMax = 100 + integer , public, protected :: fldsToAtm_num = 0 + integer , public, protected :: fldsFrAtm_num = 0 + type (fldlist_type) , public, protected :: fldsToAtm(fldsMax) + type (fldlist_type) , public, protected :: fldsFrAtm(fldsMax) + + ! area correction factors for fluxes send and received from mediator + real(r8), allocatable :: mod2med_areacor(:) + real(r8), allocatable :: med2mod_areacor(:) + + character(len=cx) :: carma_fields = ' ' ! list of CARMA fields from lnd->atm + integer :: drydep_nflds = -huge(1) ! number of dry deposition velocity fields lnd-> atm + integer :: megan_nflds = -huge(1) ! number of MEGAN voc fields from lnd-> atm + integer :: emis_nflds = -huge(1) ! number of fire emission fields from lnd-> atm + logical :: atm_provides_lightning = .false. ! cld to grnd lightning flash freq (min-1) + logical, public :: dms_from_ocn = .false. ! dms is obtained from ocean as atm import data + logical, public :: brf_from_ocn = .false. ! brf is obtained from ocean as atm import data + logical, public :: n2o_from_ocn = .false. ! n2o is obtained from ocean as atm import data + logical, public :: nh3_from_ocn = .false. ! nh3 is obtained from ocean as atm import data + character(*),parameter :: F01 = "('(cam_import_export) ',a,i8,2x,i8,2x,d21.14)" + character(*),parameter :: F02 = "('(cam_import_export) ',a,i8,2x,i8,2x,i8,2x,d21.14)" + character(*),parameter :: u_FILE_u = __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + !----------------------------------------------------------- + ! read mediator fields namelist file + !----------------------------------------------------------- + subroutine read_surface_fields_namelists() + + use shr_drydep_mod , only : shr_drydep_readnl + use shr_megan_mod , only : shr_megan_readnl + use shr_fire_emis_mod , only : shr_fire_emis_readnl + use shr_carma_mod , only : shr_carma_readnl + use shr_lightning_coupling_mod, only : shr_lightning_coupling_readnl + + character(len=*), parameter :: nl_file_name = 'drv_flds_in' + + ! read mediator fields options + call shr_drydep_readnl(nl_file_name, drydep_nflds) + call shr_megan_readnl(nl_file_name, megan_nflds) + call shr_fire_emis_readnl(nl_file_name, emis_nflds) + call shr_carma_readnl(nl_file_name, carma_fields) + call shr_lightning_coupling_readnl(nl_file_name, atm_provides_lightning) + + end subroutine read_surface_fields_namelists + + !----------------------------------------------------------- + ! advertise fields + !----------------------------------------------------------- + subroutine advertise_fields(gcomp, flds_scalar_name, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + character(ESMF_MAXSTR) :: stdname + character(ESMF_MAXSTR) :: cvalue + integer :: n, num + logical :: flds_co2a ! use case + logical :: flds_co2b ! use case + logical :: flds_co2c ! use case + character(len=128) :: fldname + logical :: ispresent + logical :: isset + character(len=*), parameter :: subname='(atm_import_export:advertise_fields): ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! determine necessary toggles for below + !-------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_co2a + if (masterproc) then + write(iulog,'(3a)') trim(subname), 'flds_co2a = ', trim(cvalue) + end if + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_co2b + if (masterproc) then + write(iulog,'(3a)') trim(subname), 'flds_co2b = ', trim(cvalue) + end if + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_co2c + if (masterproc) then + write(iulog,'(3a)') trim(subname), 'flds_co2c = ', trim(cvalue) + end if + + call NUOPC_CompAttributeGet(gcomp, name='flds_dms', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ispresent .and. isset) then + read(cvalue,*) dms_from_ocn + else + dms_from_ocn = .false. + end if + if (masterproc) then + write(iulog,'(2a,l)') trim(subname), 'dms_from_ocn = ', dms_from_ocn + end if + + call NUOPC_CompAttributeGet(gcomp, name='flds_brf', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ispresent .and. isset) then + read(cvalue,*) brf_from_ocn + else + brf_from_ocn = .false. + end if + if (masterproc) then + write(iulog,'(2a,l)') trim(subname), 'brf_from_ocn = ', brf_from_ocn + end if + + call NUOPC_CompAttributeGet(gcomp, name='flds_n2o', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ispresent .and. isset) then + read(cvalue,*) n2o_from_ocn + else + n2o_from_ocn = .false. + end if + if (masterproc) then + write(iulog,'(2a,l)') trim(subname), 'n2o_from_ocn = ', n2o_from_ocn + end if + + call NUOPC_CompAttributeGet(gcomp, name='flds_nh3', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ispresent .and. isset) then + read(cvalue,*) nh3_from_ocn + else + nh3_from_ocn = .false. + end if + if (masterproc) then + write(iulog,'(2a,l)') trim(subname), 'nh3_from_ocn = ', nh3_from_ocn + end if + + !-------------------------------- + ! Export fields + !-------------------------------- + + if (masterproc) write(iulog,'(a)') trim(subname)//'export_fields ' + + call fldlist_add(fldsFrAtm_num, fldsFrAtm, trim(flds_scalar_name)) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_topo' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_z' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_u' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_v' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_u10m' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_v10m' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_tbot' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_ptem' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_shum' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_pbot' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_dens' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_pslv' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_o3' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainc' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainl' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowc' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowl' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hmat' ) !tht enthalpy + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hlat' ) !tht var.lat.ht.part + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_lwdn' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndr' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdr' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndf' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdf' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swnet' ) ! only diagnostic + + ! from atm - black carbon deposition fluxes (3) + ! (1) => bcphidry, (2) => bcphodry, (3) => bcphiwet + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_bcph', ungridded_lbound=1, ungridded_ubound=3) + + ! from atm - organic carbon deposition fluxes (3) + ! (1) => ocphidry, (2) => ocphodry, (3) => ocphiwet + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_ocph', ungridded_lbound=1, ungridded_ubound=3) + + ! from atm - wet dust deposition frluxes (4 sizes) + ! (1) => dstwet1, (2) => dstwet2, (3) => dstwet3, (4) => dstwet4 + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_dstwet', ungridded_lbound=1, ungridded_ubound=4) + + ! from atm - dry dust deposition frluxes (4 sizes) + ! (1) => dstdry1, (2) => dstdry2, (3) => dstdry3, (4) => dstdry4 + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_dstdry', ungridded_lbound=1, ungridded_ubound=4) + + call ESMF_LogWrite(subname//' export fields co2', ESMF_LOGMSG_INFO) + + ! from atm co2 fields + if (flds_co2a .or. flds_co2b .or. flds_co2c) then + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_co2prog' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_co2diag' ) + end if + + ! Nitrogen deposition fluxes + ! Assume that 2 fields are always sent as part of Faxa_ndep + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_ndep', ungridded_lbound=1, ungridded_ubound=2) + + ! lightning flash freq + if (atm_provides_lightning) then + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_lightning') + end if + + ! Now advertise above export fields + if (masterproc) write(iulog,*) trim(subname)//' advertise export fields' + do n = 1,fldsFrAtm_num + call NUOPC_Advertise(exportState, standardName=fldsFrAtm(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + + !----------------- + ! Import fields + !----------------- + + if (masterproc) write(iulog,'(a)') trim(subname)//' import fields ' + + call fldlist_add(fldsToAtm_num, fldsToAtm, trim(flds_scalar_name)) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_anidr' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_avsdf' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_anidf' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_avsdr' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_lfrac' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Si_ifrac' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ofrac' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_tref' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_qref' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_t' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_t' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_fv' ); call set_active_Sl_fv(.true.) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_ram1' ); call set_active_Sl_ram1(.true.) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_snowh' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Si_snowh' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ssq' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_re' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ustar' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_u10' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ugustOut') + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_u10withGust') + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_taux' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_tauy' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lat' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_sen' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lwup' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_evap' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_goef' ) !+tht + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faox_evap' ) !+tht + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_hrof' ) !+tht + + ! dust fluxes from land (4 sizes) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_flxdst', ungridded_lbound=1, ungridded_ubound=4) + call set_active_Fall_flxdst1(.true.) + + ! co2 fields from land and ocean + if (flds_co2b .or. flds_co2c) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_fco2_lnd') + call set_active_Fall_fco2_lnd(.true.) + end if + if (flds_co2c) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fco2_ocn') + call set_active_Faoo_fco2_ocn(.true.) + end if + + ! dry deposition velocities from land - ALSO initialize drydep here + if (drydep_nflds > 0) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_ddvel', ungridded_lbound=1, ungridded_ubound=drydep_nflds) + end if + + ! MEGAN VOC emissions fluxes from land + if (megan_nflds > 0) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_voc', ungridded_lbound=1, ungridded_ubound=megan_nflds) + call set_active_Fall_flxvoc(.true.) + end if + + ! fire emissions fluxes from land + if (emis_nflds > 0) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_fire', ungridded_lbound=1, ungridded_ubound=emis_nflds) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_fztop') + call set_active_Fall_flxfire(.true.) + end if + + ! CARMA volumetric soil water from land + if (carma_fields /= ' ') then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_soilw') ! optional for carma + call set_active_Sl_soilw(.true.) ! check for carma + end if + + ! DMS source from ocean + if (dms_from_ocn) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fdms_ocn') ! optional + end if + + ! BRF source from ocean + if (brf_from_ocn) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fbrf_ocn') ! optional + end if + + ! N2O source from ocean + if (n2o_from_ocn) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fn2o_ocn') ! optional + end if + + ! NH3 source from ocean + if (nh3_from_ocn) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fnh3_ocn') ! optional + end if + + ! ------------------------------------------ + ! Now advertise above import fields + ! ------------------------------------------ + call ESMF_LogWrite(trim(subname)//' advertise import fields ', ESMF_LOGMSG_INFO) + do n = 1,fldsToAtm_num + call NUOPC_Advertise(importState, standardName=fldsToAtm(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + + end subroutine advertise_fields + + !=============================================================================== + + subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, single_column, rc) + + use ESMF , only : ESMF_MeshGet, ESMF_StateGet + use ESMF , only : ESMF_FieldRegridGetArea,ESMF_FieldGet + use ppgrid , only : pcols, begchunk, endchunk + use phys_grid , only : get_area_all_p, get_ncols_p + + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + type(ESMF_Mesh) , intent(in) :: Emesh + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + logical , intent(in) :: single_column + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + type(ESMF_Field) :: lfield + integer :: numOwnedElements + integer :: c,i,n,ncols + real(r8), allocatable :: mesh_areas(:) + real(r8), allocatable :: model_areas(:) + real(r8), allocatable :: area(:) + real(r8), pointer :: dataptr(:) + real(r8) :: max_mod2med_areacor + real(r8) :: max_med2mod_areacor + real(r8) :: min_mod2med_areacor + real(r8) :: min_med2mod_areacor + real(r8) :: max_mod2med_areacor_glob + real(r8) :: max_med2mod_areacor_glob + real(r8) :: min_mod2med_areacor_glob + real(r8) :: min_med2mod_areacor_glob + character(len=cl) :: cvalue + character(len=cl) :: mesh_atm + character(len=cl) :: mesh_lnd + character(len=cl) :: mesh_ocn + logical :: samegrid_atm_lnd_ocn + character(len=*), parameter :: subname='(atm_import_export:realize_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call fldlist_realize( & + state=ExportState, & + fldList=fldsFrAtm, & + numflds=fldsFrAtm_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':camExport',& + mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call fldlist_realize( & + state=importState, & + fldList=fldsToAtm, & + numflds=fldsToAtm_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':camImport',& + mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine if atm/lnd/ocn are on the same grid - if so set area correction factors to 1 + call NUOPC_CompAttributeGet(gcomp, name='mesh_atm', value=mesh_atm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='mesh_lnd', value=mesh_lnd, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=mesh_ocn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + samegrid_atm_lnd_ocn = .false. + if ( trim(mesh_lnd) /= 'UNSET' .and. trim(mesh_atm) == trim(mesh_lnd) .and. & + trim(mesh_ocn) /= 'UNSET' .and. trim(mesh_atm) == trim(mesh_ocn)) then + samegrid_atm_lnd_ocn = .true. + elseif ( trim(mesh_lnd) == 'UNSET' .and. trim(mesh_atm) == trim(mesh_ocn)) then + samegrid_atm_lnd_ocn = .true. + elseif ( trim(mesh_ocn) == 'UNSET' .and. trim(mesh_atm) == trim(mesh_lnd)) then + samegrid_atm_lnd_ocn = .true. + end if + + ! allocate area correction factors + call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate (mod2med_areacor(numOwnedElements)) + allocate (med2mod_areacor(numOwnedElements)) + + if (single_column .or. samegrid_atm_lnd_ocn) then + + mod2med_areacor(:) = 1._r8 + med2mod_areacor(:) = 1._r8 + + else + + ! Determine areas for regridding + call ESMF_StateGet(exportState, itemName=trim(fldsFrAtm(2)%stdname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(mesh_areas(numOwnedElements)) + mesh_areas(:) = dataptr(:) + + ! Determine model areas + allocate(model_areas(numOwnedElements)) + allocate(area(numOwnedElements)) + n = 0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_area_all_p(c, ncols, area) + do i = 1,ncols + n = n + 1 + model_areas(n) = area(i) + end do + end do + deallocate(area) + + ! Determine flux correction factors (module variables) + do n = 1,numOwnedElements + mod2med_areacor(n) = model_areas(n) / mesh_areas(n) + med2mod_areacor(n) = 1._r8 / mod2med_areacor(n) + end do + deallocate(model_areas) + deallocate(mesh_areas) + + end if + + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) + call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) + call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) + call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) + + if (masterproc) then + write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'CAM' + write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'CAM' + end if + + call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine realize_fields + + !=============================================================================== + + subroutine import_fields( gcomp, cam_in, restart_init, rc) + + ! ----------------------------------------------------- + ! Set field pointers in import state and + ! copy from field pointer to chunk array data structure + ! ----------------------------------------------------- + + use camsrfexch , only : cam_in_t + use phys_grid , only : get_ncols_p + use ppgrid , only : begchunk, endchunk + use shr_const_mod , only : shr_const_stebol + use co2_cycle , only : c_i, co2_readFlux_ocn, co2_readFlux_fuel + use co2_cycle , only : co2_transport, co2_time_interp_ocn, co2_time_interp_fuel + use co2_cycle , only : data_flux_ocn, data_flux_fuel + use physconst , only : mwco2 + use time_manager , only : is_first_step, get_nstep + use air_composition, only : compute_enthalpy_flux + + ! input/output variabes + type(ESMF_GridComp) :: gcomp + type(cam_in_t) , intent(inout) :: cam_in(begchunk:endchunk) + logical, optional , intent(in) :: restart_init + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + integer :: i,n,c,g, num ! indices + integer :: nstep + logical :: overwrite_flds + logical :: exists + logical :: exists_fco2_ocn + logical :: exists_fco2_lnd + character(len=128) :: fldname + real(r8), pointer :: fldptr2d(:,:) + real(r8), pointer :: fldptr1d(:) + real(r8), pointer :: fldptr_lat(:) + real(r8), pointer :: fldptr_lwup(:) + real(r8), pointer :: fldptr_avsdr(:) + real(r8), pointer :: fldptr_anidr(:) + real(r8), pointer :: fldptr_avsdf(:) + real(r8), pointer :: fldptr_anidf(:) + real(r8), pointer :: fldptr_tsurf(:) + real(r8), pointer :: fldptr_tocn(:) + real(r8), pointer :: fldptr_tref(:) + real(r8), pointer :: fldptr_qref(:) + real(r8), pointer :: fldptr_u10(:) + real(r8), pointer :: fldptr_snowhland(:) + real(r8), pointer :: fldptr_snowhice(:) + real(r8), pointer :: fldptr_ifrac(:) + real(r8), pointer :: fldptr_ofrac(:) + real(r8), pointer :: fldptr_lfrac(:) + real(r8), pointer :: fldptr_taux(:) + real(r8), pointer :: fldptr_tauy(:) + real(r8), pointer :: fldptr_sen(:) + real(r8), pointer :: fldptr_evap(:) + real(r8), pointer :: fldptr_evop(:)!+tht + real(r8), pointer :: fldptr_hrof(:)!+tht + real(r8), pointer :: fldptr_goef(:)!+tht + logical, save :: first_time = .true. + character(len=*), parameter :: subname='(atm_import_export:import_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Get import state + call NUOPC_ModelGet(gcomp, importState=importState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! don't overwrite fields if invoked during the initialization phase + ! of a 'continue' or 'branch' run type with data from .rs file + overwrite_flds = .true. + if (present(restart_init)) overwrite_flds = .not. restart_init + + !-------------------------- + ! Required atmosphere input fields + !-------------------------- + + if (overwrite_flds) then + call state_getfldptr(importState, 'Faxx_taux', fldptr=fldptr_taux, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Faxx_tauy', fldptr=fldptr_tauy, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Faxx_sen' , fldptr=fldptr_sen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Faxx_evap', fldptr=fldptr_evap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return +!+tht + ! ocean-point hevap (compute_enthalpy=T) + call state_getfldptr(importState, 'Faox_evap', fldptr=fldptr_evop, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! enthalpy of runoff(compute_enthalpy=T) + call state_getfldptr(importState, 'Faxx_hrof', fldptr=fldptr_hrof, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! ocean mat.enth.flx to atm (back compatibility) + call state_getfldptr(importState, 'Faxx_goef', fldptr=fldptr_goef,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return +!-tht + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%wsx(i) = -fldptr_taux(g) * med2mod_areacor(g) + cam_in(c)%wsy(i) = -fldptr_tauy(g) * med2mod_areacor(g) + cam_in(c)%shf(i) = -fldptr_sen(g) * med2mod_areacor(g) + cam_in(c)%cflx(i,1) = -fldptr_evap(g) * med2mod_areacor(g) +!+tht + ! add sensible heat correction only if not conserving energy + if(.not.compute_enthalpy_flux) & + cam_in(c)%shf(i) = cam_in(c)%shf(i)-fldptr_goef(g)*med2mod_areacor(g) + ! hevap over ocean + cam_in(c)%evap_ocn(i) = -fldptr_evop(g) * med2mod_areacor(g) + cam_in(c)%hrof (i) = -fldptr_hrof(g) * med2mod_areacor(g) +!-tht + g = g + 1 + end do + end do + end if ! end of overwrite_flds + + call state_getfldptr(importState, 'Faxx_lat', fldptr=fldptr_lat, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Faxx_lwup', fldptr=fldptr_lwup, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_avsdr', fldptr=fldptr_avsdr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_anidr', fldptr=fldptr_anidr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_avsdf', fldptr=fldptr_avsdf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_anidf', fldptr=fldptr_anidf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_t', fldptr=fldptr_tsurf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'So_t', fldptr=fldptr_tocn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sl_snowh', fldptr=fldptr_snowhland, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Si_snowh', fldptr=fldptr_snowhice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_tref', fldptr=fldptr_tref, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_qref', fldptr=fldptr_qref, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_u10', fldptr=fldptr_u10, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Si_ifrac', fldptr=fldptr_ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'So_ofrac', fldptr=fldptr_ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sl_lfrac', fldptr=fldptr_lfrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Only do area correction on fluxes + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%lhf(i) = -fldptr_lat(g) * med2mod_areacor(g) + cam_in(c)%lwup(i) = -fldptr_lwup(g) * med2mod_areacor(g) + cam_in(c)%asdir(i) = fldptr_avsdr(g) + cam_in(c)%aldir(i) = fldptr_anidr(g) + cam_in(c)%asdif(i) = fldptr_avsdf(g) + cam_in(c)%aldif(i) = fldptr_anidf(g) + cam_in(c)%ts(i) = fldptr_tsurf(g) + cam_in(c)%sst(i) = fldptr_tocn(g) + cam_in(c)%tref(i) = fldptr_tref(g) + cam_in(c)%qref(i) = fldptr_qref(g) + cam_in(c)%u10(i) = fldptr_u10(g) + cam_in(c)%snowhland(i) = fldptr_snowhland(g) + cam_in(c)%snowhice(i) = fldptr_snowhice(g) + cam_in(c)%icefrac(i) = fldptr_ifrac(g) + cam_in(c)%ocnfrac(i) = fldptr_ofrac(g) + cam_in(c)%landfrac(i) = fldptr_lfrac(g) + g = g + 1 + end do + end do + + ! Optional fields + + call state_getfldptr(importState, 'Sl_ram1', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + if ( associated(cam_in(c)%ram1) ) then + do i = 1, get_ncols_p(c) + cam_in(c)%ram1(i) = fldptr1d(g) + g = g + 1 + end do + end if + end do + end if + + call state_getfldptr(importState, 'Sl_fv', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + if ( associated(cam_in(c)%fv) ) then + do i = 1,get_ncols_p(c) + cam_in(c)%fv(i) = fldptr1d(g) + g = g + 1 + end do + end if + end do + end if + + ! For CARMA - soil water from land + call state_getfldptr(importState, 'Sl_soilw', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + if ( associated(cam_in(c)%soilw)) then + do i = 1,get_ncols_p(c) + cam_in(c)%soilw(i) = fldptr1d(g) + g = g+1 + end do + end if + end do + end if + + ! dry deposition fluxes from land + call state_getfldptr(importState, 'Fall_flxdst', fldptr2d=fldptr2d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + if ( associated(cam_in(c)%dstflx) ) then + do i = 1,get_ncols_p(c) + do n = 1, size(fldptr2d, dim=1) + cam_in(c)%dstflx(i,n) = fldptr2d(n,g) * med2mod_areacor(g) + end do + g = g + 1 + end do + end if + end do + end if + + ! MEGAN VOC emis fluxes from land + call state_getfldptr(importState, 'Fall_voc', fldptr2d=fldptr2d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c=begchunk,endchunk + if ( associated(cam_in(c)%meganflx) ) then + do i = 1,get_ncols_p(c) + do n = 1, size(fldptr2d, dim=1) + cam_in(c)%meganflx(i,n) = fldptr2d(n,g) * med2mod_areacor(g) + end do + g = g + 1 + end do + end if + end do + end if + + ! fire emission fluxes from land + call state_getfldptr(importState, 'Fall_fire', fldptr2d=fldptr2d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + if ( associated(cam_in(c)%fireflx) .and. associated(cam_in(c)%fireztop) ) then + do i = 1,get_ncols_p(c) + do n = 1, size(fldptr2d, dim=1) + cam_in(c)%fireflx(i,n) = fldptr2d(n,g) * med2mod_areacor(g) + end do + g = g + 1 + end do + end if + end do + end if + call state_getfldptr(importState, 'Sl_fztop', fldptr=fldptr1d, exists=exists, rc=rc) + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fireztop(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + + ! dry dep velocities + call state_getfldptr(importState, 'Sl_ddvel', fldptr2d=fldptr2d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + do n = 1, size(fldptr2d, dim=1) + cam_in(c)%depvel(i,n) = fldptr2d(n,g) + end do + g = g + 1 + end do + end do + end if + + ! fields needed to calculate water isotopes to ocean evaporation processes + call state_getfldptr(importState, 'So_ustar', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%ustar(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + call state_getfldptr(importState, 'So_re', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%re(i)= fldptr1d(g) + g = g + 1 + end do + end do + end if + call state_getfldptr(importState, 'So_ssq', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%ssq(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + + call state_getfldptr(importState, 'So_ugustOut', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%ugustOut(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + + call state_getfldptr(importState, 'So_u10withGust', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%u10withGusts(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + + ! bgc scenarios + call state_getfldptr(importState, 'Fall_fco2_lnd', fldptr=fldptr1d, exists=exists_fco2_lnd, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists_fco2_lnd) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fco2_lnd(i) = -fldptr1d(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + end if + call state_getfldptr(importState, 'Faoo_fco2_ocn', fldptr=fldptr1d, exists=exists_fco2_ocn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists_fco2_ocn) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fco2_ocn(i) = -fldptr1d(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + else + ! Consistency check + if (co2_readFlux_ocn) then + call shr_sys_abort(subname // ':: co2_readFlux_ocn and x2a_Faoo_fco2_ocn cannot both be active') + end if + end if + + call state_getfldptr(importState, 'Faoo_fdms_ocn', fldptr=fldptr1d, exists=exists, rc=rc) + if (exists) then + ! Ideally what should happen below is that + ! cam_in%cflx(icol,) should be set directly from + ! fldptr1d. However, the code initializes the chemistry + ! consituents surface fluxes (i.e.cam_in%cflx(:,:)) to zero in + ! the routine in mozart/chemistry.F90 at the start of every + ! time step. Introducing cam_in(c)%fdms below stores this + ! information until it can be updated in aero_model.F90 when + ! oslo-aero is used. + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fdms(i) = -fldptr1d(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + end if + + call state_getfldptr(importState, 'Faoo_fbrf_ocn', fldptr=fldptr1d, exists=exists, rc=rc) + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fbrf(i) = -fldptr1d(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + end if + + call state_getfldptr(importState, 'Faoo_fn2o_ocn', fldptr=fldptr1d, exists=exists, rc=rc) + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fn2o_ocn(i) = -fldptr1d(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + end if + + call state_getfldptr(importState, 'Faoo_fnh3_ocn', fldptr=fldptr1d, exists=exists, rc=rc) + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%fnh3_ocn(i) = -fldptr1d(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + end if + + ! ----------------------------------- + ! Get total co2 flux from components, + ! ----------------------------------- + + ! Note - co2_transport determines if cam_in(c)%cflx(i,c_i(1:4)) is allocated + + if (co2_transport() .and. overwrite_flds) then + + ! Interpolate in time for flux data read in + if (co2_readFlux_ocn) then + call co2_time_interp_ocn + end if + if (co2_readFlux_fuel) then + call co2_time_interp_fuel + end if + + ! from ocn : data read in or from coupler or zero + ! from fuel: data read in or zero + ! from lnd : through coupler or zero + ! all co2 fluxes in unit kgCO2/m2/s + + do c=begchunk,endchunk + do i=1, get_ncols_p(c) + + ! co2 flux from ocn + if (exists_fco2_ocn) then + cam_in(c)%cflx(i,c_i(1)) = cam_in(c)%fco2_ocn(i) + else if (co2_readFlux_ocn) then + ! convert from molesCO2/m2/s to kgCO2/m2/s + cam_in(c)%cflx(i,c_i(1)) = & + -data_flux_ocn%co2flx(i,c)*(1._r8- cam_in(c)%landfrac(i))*mwco2*1.0e-3_r8 + else + cam_in(c)%cflx(i,c_i(1)) = 0._r8 + end if + + ! co2 flux from fossil fuel + if (co2_readFlux_fuel) then + cam_in(c)%cflx(i,c_i(2)) = data_flux_fuel%co2flx(i,c) + else + cam_in(c)%cflx(i,c_i(2)) = 0._r8 + end if + + ! co2 flux from land (cpl already multiplies flux by land fraction) + if (exists_fco2_lnd) then + cam_in(c)%cflx(i,c_i(3)) = cam_in(c)%fco2_lnd(i) + else + cam_in(c)%cflx(i,c_i(3)) = 0._r8 + end if + + ! merged co2 flux + cam_in(c)%cflx(i,c_i(4)) = cam_in(c)%cflx(i,c_i(1)) + cam_in(c)%cflx(i,c_i(2)) + cam_in(c)%cflx(i,c_i(3)) + end do + end do + end if + + ! if first step, determine longwave up flux from the surface temperature + if (first_time) then + if (is_first_step()) then + do c=begchunk, endchunk + do i=1, get_ncols_p(c) + cam_in(c)%lwup(i) = shr_const_stebol*(cam_in(c)%ts(i)**4) + end do + end do + end if + first_time = .false. + end if + + end subroutine import_fields + + !=============================================================================== + + subroutine export_fields( gcomp, model_mesh, model_clock, cam_out, rc) + + ! ----------------------------------------------------- + ! Set field pointers in export set + ! Copy from chunk array data structure into state fldptr + ! ----------------------------------------------------- + + use camsrfexch , only : cam_out_t + use phys_grid , only : get_ncols_p + use ppgrid , only : begchunk, endchunk + use time_manager , only : is_first_step, get_nstep + use spmd_utils , only : masterproc + + !------------------------------- + ! Pack the export state + !------------------------------- + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_Mesh) , intent(in) :: model_mesh + type(ESMF_Clock), intent(in) :: model_clock + type(cam_out_t) , intent(inout) :: cam_out(begchunk:endchunk) + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: exportState + type(ESMF_State) :: importState + type(ESMF_Clock) :: clock + integer :: i,m,c,n,g ! indices + integer :: nstep + logical :: exists + real(r8) :: wind_dir + ! 2d output pointers + real(r8), pointer :: fldptr_ndep(:,:) + real(r8), pointer :: fldptr_bcph(:,:) , fldptr_ocph(:,:) + real(r8), pointer :: fldptr_dstwet(:,:), fldptr_dstdry(:,:) + ! 1d output pointers + real(r8), pointer :: fldptr_soll(:) , fldptr_sols(:) + real(r8), pointer :: fldptr_solld(:) , fldptr_solsd(:) + real(r8), pointer :: fldptr_snowc(:) , fldptr_snowl(:) + real(r8), pointer :: fldptr_hmat (:) , fldptr_hlat (:)!+tht enthalpy + real(r8), pointer :: fldptr_rainc(:) , fldptr_rainl(:) + real(r8), pointer :: fldptr_lwdn(:) , fldptr_swnet(:) + real(r8), pointer :: fldptr_topo(:) , fldptr_zbot(:) + real(r8), pointer :: fldptr_ubot(:) , fldptr_vbot(:) + real(r8), pointer :: fldptr_pbot(:) , fldptr_tbot(:) + real(r8), pointer :: fldptr_shum(:) , fldptr_dens(:) + real(r8), pointer :: fldptr_ptem(:) , fldptr_pslv(:) + real(r8), pointer :: fldptr_co2prog(:) , fldptr_co2diag(:) + real(r8), pointer :: fldptr_ozone(:) + real(r8), pointer :: fldptr_lght(:) + real(r8), pointer :: fldptr_u10m(:) + real(r8), pointer :: fldptr_v10m(:) + ! import state pointer + real(r8), pointer :: fldptr_wind10m(:) + character(len=*), parameter :: subname='(atm_import_export:export_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Get export state + call NUOPC_ModelGet(gcomp, exportState=exportState, importState=importState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! required export state variables + call state_getfldptr(exportState, 'Sa_topo', fldptr=fldptr_topo, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_z' , fldptr=fldptr_zbot, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_u' , fldptr=fldptr_ubot, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_v' , fldptr=fldptr_vbot, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_tbot', fldptr=fldptr_tbot, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_pbot', fldptr=fldptr_pbot, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_shum', fldptr=fldptr_shum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_dens', fldptr=fldptr_dens, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_ptem', fldptr=fldptr_ptem, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_pslv', fldptr=fldptr_pslv, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_u10m', fldptr=fldptr_u10m, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sa_v10m', fldptr=fldptr_v10m, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(importState, 'Sx_u10' , fldptr=fldptr_wind10m, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! The 10m wind speed over ocean obtained from the atm/ocn flux computation in the mediator + ! and is merged with the 10m wind speed obtained from the land ice ice components + ! This computation for 10m wind speed will have used the bottom level winds from cam sent + ! at the previous time + ! The decomposition of the 10m wind into its zonal and meridional components is done using + ! the bottom level u and v fields from cam (at the current time) + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_topo(g) = cam_out(c)%topo(i) + fldptr_zbot(g) = cam_out(c)%zbot(i) + fldptr_ubot(g) = cam_out(c)%ubot(i) + fldptr_vbot(g) = cam_out(c)%vbot(i) + fldptr_pbot(g) = cam_out(c)%pbot(i) + fldptr_tbot(g) = cam_out(c)%tbot(i) + fldptr_shum(g) = cam_out(c)%qbot(i,1) + fldptr_dens(g) = cam_out(c)%rho(i) + fldptr_ptem(g) = cam_out(c)%thbot(i) + fldptr_pslv(g) = cam_out(c)%psl(i) + wind_dir = cam_out(c)%wind_dir(i) + fldptr_u10m(g) = fldptr_wind10m(g)*cos(wind_dir) + fldptr_v10m(g) = fldptr_wind10m(g)*sin(wind_dir) + g = g + 1 + end do + end do + + ! required export flux variables + call state_getfldptr(exportState, 'Faxa_swnet', fldptr=fldptr_swnet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_lwdn' , fldptr=fldptr_lwdn , rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_rainc', fldptr=fldptr_rainc, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_rainl', fldptr=fldptr_rainl, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_snowc', fldptr=fldptr_snowc, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_snowl', fldptr=fldptr_snowl, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_swndr', fldptr=fldptr_soll, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_swvdr', fldptr=fldptr_sols, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_swndf', fldptr=fldptr_solld, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_swvdf', fldptr=fldptr_solsd, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_hmat' , fldptr=fldptr_hmat , rc=rc) !tht enthalpy + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_hlat' , fldptr=fldptr_hlat , rc=rc) !tht var.lat.ht.part + if (ChkErr(rc,__LINE__,u_FILE_u)) return + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_lwdn(g) = cam_out(c)%flwds(i) * mod2med_areacor(g) + fldptr_swnet(g) = cam_out(c)%netsw(i) * mod2med_areacor(g) + fldptr_snowc(g) = cam_out(c)%precsc(i)*1000._r8 * mod2med_areacor(g) + fldptr_snowl(g) = cam_out(c)%precsl(i)*1000._r8 * mod2med_areacor(g) + fldptr_rainc(g) = (cam_out(c)%precc(i) - cam_out(c)%precsc(i))*1000._r8 * mod2med_areacor(g) + fldptr_rainl(g) = (cam_out(c)%precl(i) - cam_out(c)%precsl(i))*1000._r8 * mod2med_areacor(g) + fldptr_soll(g) = cam_out(c)%soll(i) * mod2med_areacor(g) + fldptr_sols(g) = cam_out(c)%sols(i) * mod2med_areacor(g) + fldptr_solld(g) = cam_out(c)%solld(i) * mod2med_areacor(g) + fldptr_solsd(g) = cam_out(c)%solsd(i) * mod2med_areacor(g) + fldptr_hmat (g) = cam_out(c)%hmat(i) * mod2med_areacor(g) !+tht enthalpy + fldptr_hlat (g) = cam_out(c)%hlat(i) * mod2med_areacor(g) !+tht var.lat.ht.part + g = g + 1 + end do + end do + + ! aerosol deposition fluxes + call state_getfldptr(exportState, 'Faxa_bcph', fldptr2d=fldptr_bcph, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_ocph', fldptr2d=fldptr_ocph, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_dstdry', fldptr2d=fldptr_dstdry, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_dstwet', fldptr2d=fldptr_dstwet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! (1) => bcphidry, (2) => bcphodry, (3) => bcphiwet + ! (1) => ocphidry, (2) => ocphodry, (3) => ocphiwet + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_bcph(1,g) = cam_out(c)%bcphidry(i) * mod2med_areacor(g) + fldptr_bcph(2,g) = cam_out(c)%bcphodry(i) * mod2med_areacor(g) + fldptr_bcph(3,g) = cam_out(c)%bcphiwet(i) * mod2med_areacor(g) + fldptr_ocph(1,g) = cam_out(c)%ocphidry(i) * mod2med_areacor(g) + fldptr_ocph(2,g) = cam_out(c)%ocphodry(i) * mod2med_areacor(g) + fldptr_ocph(3,g) = cam_out(c)%ocphiwet(i) * mod2med_areacor(g) + fldptr_dstdry(1,g) = cam_out(c)%dstdry1(i) * mod2med_areacor(g) + fldptr_dstdry(2,g) = cam_out(c)%dstdry2(i) * mod2med_areacor(g) + fldptr_dstdry(3,g) = cam_out(c)%dstdry3(i) * mod2med_areacor(g) + fldptr_dstdry(4,g) = cam_out(c)%dstdry4(i) * mod2med_areacor(g) + fldptr_dstwet(1,g) = cam_out(c)%dstwet1(i) * mod2med_areacor(g) + fldptr_dstwet(2,g) = cam_out(c)%dstwet2(i) * mod2med_areacor(g) + fldptr_dstwet(3,g) = cam_out(c)%dstwet3(i) * mod2med_areacor(g) + fldptr_dstwet(4,g) = cam_out(c)%dstwet4(i) * mod2med_areacor(g) + g = g + 1 + end do + end do + + call state_getfldptr(exportState, 'Sa_o3', fldptr=fldptr_ozone, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_ozone(g) = cam_out(c)%ozone(i) ! atm ozone + g = g + 1 + end do + end do + end if + + call state_getfldptr(exportState, 'Sa_lightning', fldptr=fldptr_lght, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_lght(g) = cam_out(c)%lightning_flash_freq(i) ! cloud-to-ground lightning flash frequency (/min) + g = g + 1 + end do + end do + end if + + call state_getfldptr(exportState, 'Sa_co2prog', fldptr=fldptr_co2prog, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_co2prog(g) = cam_out(c)%co2prog(i) ! atm prognostic co2 + g = g + 1 + end do + end do + end if + + call state_getfldptr(exportState, 'Sa_co2diag', fldptr=fldptr_co2diag, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_co2diag(g) = cam_out(c)%co2diag(i) ! atm diagnostic co2 + g = g + 1 + end do + end do + end if + + call state_getfldptr(exportState, 'Faxa_ndep', fldptr2d=fldptr_ndep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr_ndep(:,:) = 0._r8 + + if (.not. (simple_phys .or. aqua_planet)) then + + ! The ndep_stream_nl namelist group is read in stream_ndep_init. This sets whether + ! or not the stream will be used. + if (.not. stream_ndep_is_initialized) then + call stream_ndep_init(model_mesh, model_clock, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + stream_ndep_is_initialized = .true. + end if + + if (ndep_stream_active.or.chem_has_ndep_flx) then + + ! Nitrogen dep fluxes are obtained from the ndep input stream if input data is available + ! otherwise computed by chemistry + if (ndep_stream_active) then + + ! get ndep fluxes from the stream + call stream_ndep_interp(cam_out, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end if + + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_ndep(1,g) = cam_out(c)%nhx_nitrogen_flx(i) * mod2med_areacor(g) + fldptr_ndep(2,g) = cam_out(c)%noy_nitrogen_flx(i) * mod2med_areacor(g) + g = g + 1 + end do + end do + + end if + + end if + + end subroutine export_fields + + !=============================================================================== + + subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) + + ! input/otuput variables + integer , intent(inout) :: num + type(fldlist_type) , intent(inout) :: fldlist(:) + character(len=*) , intent(in) :: stdname + integer, optional , intent(in) :: ungridded_lbound + integer, optional , intent(in) :: ungridded_ubound + + ! local variables + character(len=*), parameter :: subname='(atm_import_export:fldlist_add)' + !------------------------------------------------------------------------------- + + ! Set up a list of field information + + num = num + 1 + if (num > fldsMax) then + call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & + ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) + return + endif + fldlist(num)%stdname = trim(stdname) + + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + end if + + end subroutine fldlist_add + + !=============================================================================== + + subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) + + use NUOPC , only : NUOPC_IsConnected, NUOPC_Realize + use ESMF , only : ESMF_MeshLoc_Element, ESMF_FieldCreate, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_MAXSTR, ESMF_Field, ESMF_State, ESMF_Mesh, ESMF_StateRemove + use ESMF , only : ESMF_LogFoundError, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LOGERR_PASSTHRU + + ! input/output variables + type(ESMF_State) , intent(inout) :: state + type(fldlist_type) , intent(in) :: fldList(:) + integer , intent(in) :: numflds + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! local variables + integer :: n + type(ESMF_Field) :: field + character(len=80) :: stdname + character(CL) :: msg + character(len=*),parameter :: subname='(atm_import_export:fldlist_realize)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + do n = 1, numflds + stdname = fldList(n)%stdname + if (NUOPC_IsConnected(state, fieldName=stdname)) then + if (stdname == trim(flds_scalar_name)) then + if (masterproc) then + write(iulog,'(a)') trim(subname)//trim(tag)//" field = "//trim(stdname)//" is connected on root pe" + end if + ! Create the scalar field + call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (masterproc) then + write(iulog,'(a,i8,a,i8)') trim(subname)// trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh with lbound ", fldlist(n)%ungridded_lbound,& + " and with ubound ",fldlist(n)%ungridded_ubound + end if + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (masterproc) then + write(iulog,'(a)') trim(subname)// trim(tag)//" Field = "//trim(stdname)// " is connected using mesh " + end if + end if + endif + + ! NOW call NUOPC_Realize + call NUOPC_Realize(state, field=field, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + if (stdname /= trim(flds_scalar_name)) then + if (masterproc) then + write(iulog,'(a)')trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is not connected" + end if + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + end if + end if + end do + + contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) + ! ---------------------------------------------- + ! create a field with scalar data on the root pe + ! ---------------------------------------------- + + use ESMF, only : ESMF_Field, ESMF_DistGrid, ESMF_Grid + use ESMF, only : ESMF_DistGridCreate, ESMF_GridCreate, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU + use ESMF, only : ESMF_FieldCreate, ESMF_GridCreate, ESMF_TYPEKIND_R8 + + ! input/output variables + type(ESMF_Field) , intent(inout) :: field + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(inout) :: rc + + ! local variables + type(ESMF_Distgrid) :: distgrid + type(ESMF_Grid) :: grid + character(len=*), parameter :: subname='(atm_import_export:SetScalarField)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + ! create a DistGrid with a single index space element, which gets mapped onto DE 0. + distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + grid = ESMF_GridCreate(distgrid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + field = ESMF_FieldCreate(name=trim(flds_scalar_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + end subroutine SetScalarField + + end subroutine fldlist_realize + + !=============================================================================== + subroutine state_getfldptr(State, fldname, fldptr, fldptr2d, exists, rc) + + ! ---------------------------------------------- + ! Get pointer to a state field + ! ---------------------------------------------- + + use ESMF , only : ESMF_State, ESMF_Field, ESMF_Mesh, ESMF_FieldStatus_Flag + use ESMF , only : ESMF_StateGet, ESMF_FieldGet, ESMF_MeshGet + use ESMF , only : ESMF_FIELDSTATUS_COMPLETE, ESMF_FAILURE + + ! input/output variables + type(ESMF_State) , intent(in) :: State + character(len=*) , intent(in) :: fldname + real(R8), optional, pointer :: fldptr(:) + real(R8), optional, pointer :: fldptr2d(:,:) + logical , optional, intent(out) :: exists + integer , intent(out) :: rc + + ! local variables + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_StateItem_Flag) :: itemFlag + type(ESMF_Field) :: lfield + type(ESMF_Mesh) :: lmesh + integer :: nnodes, nelements + logical :: lexists + character(len=*), parameter :: subname='(atm_import_export:state_getfldptr)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + lexists = .true. + + ! Determine if field with name fldname exists in state + if (present(exists)) then + call ESMF_StateGet(state, trim(fldname), itemFlag, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (itemflag == ESMF_STATEITEM_NOTFOUND) then + lexists = .false. + end if + exists = lexists + end if + + if (lexists) then + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (present(fldptr)) then + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else if (present(fldptr2d)) then + call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + + end subroutine state_getfldptr + +end module atm_import_export diff --git a/src/physics/camnor_phys/physics/cam_diagnostics.F90 b/src/physics/camnor_phys/physics/cam_diagnostics.F90 new file mode 100644 index 0000000000..dade72ed95 --- /dev/null +++ b/src/physics/camnor_phys/physics/cam_diagnostics.F90 @@ -0,0 +1,2356 @@ +module cam_diagnostics + +!--------------------------------------------------------------------------------- +! Module to compute a variety of diagnostics quantities for history files +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use camsrfexch, only: cam_in_t, cam_out_t +use cam_control_mod, only: moist_physics +use physics_types, only: physics_state, physics_tend, physics_ptend +use ppgrid, only: pcols, pver, begchunk, endchunk +use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dtype_r8 +use physics_buffer, only: dyn_time_lvls, pbuf_get_field, pbuf_get_index, pbuf_old_tim_idx + +use cam_history, only: outfld, write_inithist, hist_fld_active, inithist_all, write_camiop +use cam_history_support, only: max_fieldname_len +use constituents, only: pcnst, cnst_name, cnst_longname, cnst_cam_outfld +use constituents, only: ptendnam, apcnst, bpcnst, cnst_get_ind +use dycore, only: dycore_is +use phys_control, only: phys_getopts +use wv_saturation, only: qsat, qsat_water, svp_ice_vect +use time_manager, only: is_first_step + +use scamMod, only: single_column, wfld +use cam_abortutils, only: endrun + +implicit none +private +save + +! Public interfaces + +public :: & + diag_readnl, &! read namelist options + diag_register, &! register pbuf space + diag_init, &! initialization + diag_allocate, &! allocate memory for module variables + diag_deallocate, &! deallocate memory for module variables + diag_conv_tend_ini, &! initialize convective tendency calcs + diag_phys_writeout, &! output diagnostics of the dynamics + diag_clip_tend_writeout, &! output diagnostics for clipping + diag_phys_tend_writeout, &! output physics tendencies + diag_state_b4_phys_write, &! output state before physics execution + diag_conv, &! output diagnostics of convective processes + diag_surf, &! output diagnostics of the surface + diag_export, &! output export state + diag_physvar_ic, & + nsurf + +integer, public, parameter :: num_stages = 8 +character (len = max_fieldname_len), dimension(num_stages) :: stage = (/"phBF","phBP","phAP","phAM","dyBF","dyBP","dyAP","dyAM"/) +character (len = 45),dimension(num_stages) :: stage_txt = (/& + " before energy fixer ",& !phBF - physics energy + " before parameterizations ",& !phBF - physics energy + " after parameterizations ",& !phAP - physics energy + " after dry mass correction ",& !phAM - physics energy + " before energy fixer (dycore) ",& !dyBF - dynamics energy + " before parameterizations (dycore) ",& !dyBF - dynamics energy + " after parameterizations (dycore) ",& !dyAP - dynamics energy + " after dry mass correction (dycore) " & !dyAM - dynamics energy + /) + +! Private data + +integer :: dqcond_num ! number of constituents to compute convective +character(len=16) :: dcconnam(pcnst) ! names of convection tendencies + ! tendencies for +real(r8), allocatable :: dtcond(:,:,:) ! temperature tendency due to convection +type dqcond_t + real(r8), allocatable :: cnst(:,:,:) ! constituent tendency due to convection +end type dqcond_t +type(dqcond_t), allocatable :: dqcond(:) + +character(len=8) :: diag_cnst_conv_tend = 'q_only' ! output constituent tendencies due to convection + ! 'none', 'q_only' or 'all' + +integer, parameter :: surf_100000 = 1 +integer, parameter :: surf_092500 = 2 +integer, parameter :: surf_085000 = 3 +integer, parameter :: surf_070000 = 4 +integer, parameter :: nsurf = 4 + +logical :: history_amwg ! output the variables used by the AMWG diag package +logical :: history_vdiag ! output the variables used by the AMWG variability diag package +logical :: history_eddy ! output the eddy variables +logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. +integer :: history_budget_histfile_num ! output history file number for budget fields +logical :: history_waccm ! outputs typically used for WACCM + +! Physics buffer indices + +integer :: psl_idx = 0 +integer :: relhum_idx = 0 +integer :: qcwat_idx = 0 +integer :: tcwat_idx = 0 +integer :: lcwat_idx = 0 +integer :: cld_idx = 0 +integer :: concld_idx = 0 +integer :: tke_idx = 0 +integer :: kvm_idx = 0 +integer :: kvh_idx = 0 +integer :: cush_idx = 0 +integer :: t_ttend_idx = 0 +integer :: t_utend_idx = 0 +integer :: t_vtend_idx = 0 + +integer :: prec_dp_idx = 0 +integer :: snow_dp_idx = 0 +integer :: prec_sh_idx = 0 +integer :: snow_sh_idx = 0 +integer :: prec_sed_idx = 0 +integer :: snow_sed_idx = 0 +integer :: prec_pcw_idx = 0 +integer :: snow_pcw_idx = 0 + + +integer :: tpert_idx=-1, qpert_idx=-1, pblh_idx=-1 + +integer :: trefmxav_idx = -1, trefmnav_idx = -1 + +contains + +!============================================================================== + + subroutine diag_readnl(nlfile) + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpi_character, mpicom + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'diag_readnl' + + namelist /cam_diag_opts/ diag_cnst_conv_tend + !-------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'cam_diag_opts', status=ierr) + if (ierr == 0) then + read(unitn, cam_diag_opts, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast(diag_cnst_conv_tend, len(diag_cnst_conv_tend), mpi_character, masterprocid, mpicom, ierr) + + end subroutine diag_readnl + +!============================================================================== + + subroutine diag_register_dry() + + call pbuf_add_field('PSL', 'physpkg', dtype_r8, (/pcols/), psl_idx) + + ! Request physics buffer space for fields that persist across timesteps. + call pbuf_add_field('T_TTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_ttend_idx) + call pbuf_add_field('T_UTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_utend_idx) + call pbuf_add_field('T_VTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_vtend_idx) + end subroutine diag_register_dry + + subroutine diag_register_moist() + ! Request physics buffer space for fields that persist across timesteps. + call pbuf_add_field('TREFMXAV', 'global', dtype_r8, (/pcols/), trefmxav_idx) + call pbuf_add_field('TREFMNAV', 'global', dtype_r8, (/pcols/), trefmnav_idx) + end subroutine diag_register_moist + + subroutine diag_register() + call diag_register_dry() + if (moist_physics) then + call diag_register_moist() + end if + end subroutine diag_register + +!============================================================================== + + subroutine diag_init_dry(pbuf2d) + ! Declare the history fields for which this module contains outfld calls. + + use cam_history, only: addfld, add_default, horiz_only + use cam_history, only: register_vector_field + use tidal_diag, only: tidal_diag_init + use cam_budget, only: cam_budget_em_snapshot, cam_budget_em_register, thermo_budget_history + use air_composition, only: compute_enthalpy_flux !+tht + + type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) + + logical :: debug_enthalpy_flux=.true. !+tht + integer :: istage + ! outfld calls in diag_phys_writeout + call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) + call addfld ('NSTEP', horiz_only, 'A', 'timestep', 'Model timestep') + call addfld ('PHIS', horiz_only, 'I', 'm2/s2', 'Surface geopotential') + + call addfld ('PS', horiz_only, 'A', 'Pa', 'Surface pressure') + call addfld ('T', (/ 'lev' /), 'A', 'K', 'Temperature') + call addfld ('U', (/ 'lev' /), 'A', 'm/s', 'Zonal wind') + call addfld ('V', (/ 'lev' /), 'A', 'm/s', 'Meridional wind') + + call register_vector_field('U','V') + + ! State before physics + call addfld ('TBP', (/ 'lev' /), 'A','K', 'Temperature (before physics)') + call addfld ('UBP', (/ 'lev' /), 'A','m/s', 'Zonal wind (before physics)') + call addfld ('VBP', (/ 'lev' /), 'A','m/s', 'Meridional Wind (before physics)') + call register_vector_field('UBP','VBP') + call addfld (bpcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (before physics)') + ! State after physics + call addfld ('TAP', (/ 'lev' /), 'A','K', 'Temperature (after physics)' ) + call addfld ('UAP', (/ 'lev' /), 'A','m/s', 'Zonal wind (after physics)' ) + call addfld ('VAP', (/ 'lev' /), 'A','m/s', 'Meridional wind (after physics)' ) + + call register_vector_field('UAP','VAP') + + call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') + call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') + call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') +!+tht + call addfld('EBREAK' , horiz_only, 'A','W/m2', & + 'Global-mean energy-nonconservation (W/m2)' ) + !if (compute_enthalpy_flux) then + call addfld('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & + 'T-tendency due to water fluxes (end of tphysac)' ) + call addfld('IETEND_DME', horiz_only, 'A','W/m2 ', & + 'Column enthalpy tendency due to water fluxes (end of tphysac)' ) + call addfld('EFLX ' , horiz_only, 'A','W/m2 ', & + 'Surface water material enthalpy flux (end of tphysac)' ) + call addfld('MFLX ' , horiz_only, 'A','W/m2 ', & + 'Mass flux due to dry mass adjustment / water changes (end of tphysac)') + !endif +!-tht + + ! outfld calls in diag_phys_tend_writeout + call addfld ('UTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total zonal wind tendency') + call addfld ('VTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total meridional wind tendency') + call register_vector_field('UTEND_TOT','VTEND_TOT') + + ! Debugging negative water output fields + call addfld ('INEGCLPTEND ', (/ 'lev' /), 'A', 'kg/kg/s', 'Cloud ice tendency due to clipping neg values after microp', sampled_on_subcycle=.true.) + call addfld ('LNEGCLPTEND ', (/ 'lev' /), 'A', 'kg/kg/s', 'Cloud liq tendency due to clipping neg values after microp', sampled_on_subcycle=.true.) + call addfld ('VNEGCLPTEND ', (/ 'lev' /), 'A', 'kg/kg/s', 'Vapor tendency due to clipping neg values after microp', sampled_on_subcycle=.true.) + + call addfld ('Z3', (/ 'lev' /), 'A', 'm', 'Geopotential Height (above sea level)') + call addfld ('Z1000', horiz_only, 'A', 'm', 'Geopotential Z at 1000 mbar pressure surface') + call addfld ('Z700', horiz_only, 'A', 'm', 'Geopotential Z at 700 mbar pressure surface') + call addfld ('Z500', horiz_only, 'A', 'm', 'Geopotential Z at 500 mbar pressure surface') + call addfld ('Z300', horiz_only, 'A', 'm', 'Geopotential Z at 300 mbar pressure surface') + call addfld ('Z200', horiz_only, 'A', 'm', 'Geopotential Z at 200 mbar pressure surface') + call addfld ('Z100', horiz_only, 'A', 'm', 'Geopotential Z at 100 mbar pressure surface') + call addfld ('Z050', horiz_only, 'A', 'm', 'Geopotential Z at 50 mbar pressure surface') + + call addfld ('ZZ', (/ 'lev' /), 'A', 'm2', 'Eddy height variance' ) + call addfld ('VZ', (/ 'lev' /), 'A', 'm2/s', 'Meridional transport of geopotential height') + call addfld ('VT', (/ 'lev' /), 'A', 'K m/s ', 'Meridional heat transport') + call addfld ('VU', (/ 'lev' /), 'A', 'm2/s2', 'Meridional flux of zonal momentum' ) + call addfld ('VV', (/ 'lev' /), 'A', 'm2/s2', 'Meridional velocity squared' ) + call addfld ('OMEGAV', (/ 'lev' /), 'A', 'm Pa/s2 ', 'Vertical flux of meridional momentum' ) + call addfld ('OMGAOMGA', (/ 'lev' /), 'A', 'Pa2/s2', 'Vertical flux of vertical momentum' ) + + call addfld ('UT', (/ 'lev' /), 'A', 'K m/s ', 'Zonal heat transport') + call addfld ('UU', (/ 'lev' /), 'A', 'm2/s2', 'Zonal velocity squared' ) + call addfld ('WSPEED', (/ 'lev' /), 'X', 'm/s', 'Horizontal total wind speed maximum' ) + call addfld ('WSPDSRFMX', horiz_only, 'X', 'm/s', 'Horizontal total wind speed maximum at surface layer midpoint' ) + call addfld ('WSPDSRFAV', horiz_only, 'A', 'm/s', 'Horizontal total wind speed average at surface layer midpoint' ) + + call addfld ('OMEGA', (/ 'lev' /), 'A', 'Pa/s', 'Vertical velocity (pressure)') + call addfld ('OMEGAT', (/ 'lev' /), 'A', 'K Pa/s ', 'Vertical heat flux' ) + call addfld ('OMEGAU', (/ 'lev' /), 'A', 'm Pa/s2 ', 'Vertical flux of zonal momentum' ) + call addfld ('OMEGA850', horiz_only, 'A', 'Pa/s', 'Vertical velocity at 850 mbar pressure surface') + call addfld ('OMEGA500', horiz_only, 'A', 'Pa/s', 'Vertical velocity at 500 mbar pressure surface') + + call addfld ('PSL', horiz_only, 'A', 'Pa','Sea level pressure') + + call addfld ('T1000', horiz_only, 'A', 'K','Temperature at 1000 mbar pressure surface') + call addfld ('T925', horiz_only, 'A', 'K','Temperature at 925 mbar pressure surface') + call addfld ('T850', horiz_only, 'A', 'K','Temperature at 850 mbar pressure surface') + call addfld ('T700', horiz_only, 'A', 'K','Temperature at 700 mbar pressure surface') + call addfld ('T500', horiz_only, 'A', 'K','Temperature at 500 mbar pressure surface') + call addfld ('T400', horiz_only, 'A', 'K','Temperature at 400 mbar pressure surface') + call addfld ('T300', horiz_only, 'A', 'K','Temperature at 300 mbar pressure surface') + call addfld ('T200', horiz_only, 'A', 'K','Temperature at 200 mbar pressure surface') + call addfld ('T010', horiz_only, 'A', 'K','Temperature at 10 mbar pressure surface') + + call addfld ('T7001000', horiz_only, 'A', 'K','Temperature difference 700 mb - 1000 mb') + call addfld ('TH7001000', horiz_only, 'A', 'K','Theta difference 700 mb - 1000 mb') + call addfld ('THE7001000', horiz_only, 'A', 'K','ThetaE difference 700 mb - 1000 mb') + + call addfld ('T8501000', horiz_only, 'A', 'K','Temperature difference 850 mb - 1000 mb') + call addfld ('TH8501000', horiz_only, 'A', 'K','Theta difference 850 mb - 1000 mb') + call addfld ('T9251000', horiz_only, 'A', 'K','Temperature difference 925 mb - 1000 mb') + call addfld ('TH9251000', horiz_only, 'A', 'K','Theta difference 925 mb - 1000 mb') + + call addfld ('TT', (/ 'lev' /), 'A', 'K2','Eddy temperature variance' ) + + call addfld ('U850', horiz_only, 'A', 'm/s','Zonal wind at 850 mbar pressure surface') + call addfld ('U500', horiz_only, 'A', 'm/s','Zonal wind at 500 mbar pressure surface') + call addfld ('U250', horiz_only, 'A', 'm/s','Zonal wind at 250 mbar pressure surface') + call addfld ('U200', horiz_only, 'A', 'm/s','Zonal wind at 200 mbar pressure surface') + call addfld ('U010', horiz_only, 'A', 'm/s','Zonal wind at 10 mbar pressure surface') + call addfld ('V850', horiz_only, 'A', 'm/s','Meridional wind at 850 mbar pressure surface') + call addfld ('V500', horiz_only, 'A', 'm/s','Meridional wind at 500 mbar pressure surface') + call addfld ('V250', horiz_only, 'A', 'm/s','Meridional wind at 250 mbar pressure surface') + call addfld ('V200', horiz_only, 'A', 'm/s','Meridional wind at 200 mbar pressure surface') + + call register_vector_field('U850', 'V850') + call register_vector_field('U500', 'V500') + call register_vector_field('U250', 'V250') + call register_vector_field('U200', 'V200') + + call addfld ('UBOT', horiz_only, 'A', 'm/s','Lowest model level zonal wind') + call addfld ('VBOT', horiz_only, 'A', 'm/s','Lowest model level meridional wind') + call register_vector_field('UBOT', 'VBOT') + + call addfld ('ZBOT', horiz_only, 'A', 'm','Lowest model level height') + + call addfld ('ATMEINT', horiz_only, 'A', 'J/m2','Vertically integrated total atmospheric energy ') + + if (history_amwg) then + call add_default ('PHIS ' , 1, ' ') + call add_default ('PS ' , 1, ' ') + call add_default ('T ' , 1, ' ') + call add_default ('U ' , 1, ' ') + call add_default ('V ' , 1, ' ') + call add_default ('Z3 ' , 1, ' ') + call add_default ('OMEGA ' , 1, ' ') + call add_default ('VT ', 1, ' ') + call add_default ('VU ', 1, ' ') + call add_default ('VV ', 1, ' ') + call add_default ('UU ', 1, ' ') + call add_default ('OMEGAT ', 1, ' ') + call add_default ('PSL ', 1, ' ') + end if + + if (history_vdiag) then + call add_default ('U200', 2, ' ') + call add_default ('V200', 2, ' ') + call add_default ('U850', 2, ' ') + call add_default ('U200', 3, ' ') + call add_default ('U850', 3, ' ') + call add_default ('OMEGA500', 3, ' ') + end if + + if (history_eddy) then + call add_default ('VT ', 1, ' ') + call add_default ('VU ', 1, ' ') + call add_default ('VV ', 1, ' ') + call add_default ('UT ', 1, ' ') + call add_default ('UU ', 1, ' ') + call add_default ('OMEGAT ', 1, ' ') + call add_default ('OMEGAU ', 1, ' ') + call add_default ('OMEGAV ', 1, ' ') + endif + + if ( history_budget ) then + call add_default ('PHIS ' , history_budget_histfile_num, ' ') + call add_default ('PS ' , history_budget_histfile_num, ' ') + call add_default ('T ' , history_budget_histfile_num, ' ') + call add_default ('U ' , history_budget_histfile_num, ' ') + call add_default ('V ' , history_budget_histfile_num, ' ') + call add_default ('TTEND_TOT' , history_budget_histfile_num, ' ') + call add_default ('UTEND_TOT' , history_budget_histfile_num, ' ') + call add_default ('VTEND_TOT' , history_budget_histfile_num, ' ') + + ! State before physics (FV) + call add_default ('TBP ' , history_budget_histfile_num, ' ') + call add_default ('UBP ' , history_budget_histfile_num, ' ') + call add_default ('VBP ' , history_budget_histfile_num, ' ') + call add_default (bpcnst(1) , history_budget_histfile_num, ' ') + ! State after physics (FV) + call add_default ('TAP ' , history_budget_histfile_num, ' ') + call add_default ('UAP ' , history_budget_histfile_num, ' ') + call add_default ('VAP ' , history_budget_histfile_num, ' ') + call add_default (apcnst(1) , history_budget_histfile_num, ' ') + call add_default ('TFIX ' , history_budget_histfile_num, ' ') + end if + + if (history_waccm) then + call add_default ('PHIS', 7, ' ') + call add_default ('PS', 7, ' ') + call add_default ('PSL', 7, ' ') + end if + + ! outfld calls in diag_phys_tend_writeout + call addfld ('PTTEND', (/ 'lev' /), 'A', 'K/s','T total physics tendency') + call addfld ('UTEND_PHYSTOT', (/ 'lev' /), 'A', 'm/s2','U total physics tendency') + call addfld ('VTEND_PHYSTOT', (/ 'lev' /), 'A', 'm/s2','V total physics tendency') + call register_vector_field('UTEND_PHYSTOT','VTEND_PHYSTOT') + if ( history_budget ) then + call add_default ('PTTEND' , history_budget_histfile_num, ' ') + call add_default ('UTEND_PHYSTOT' , history_budget_histfile_num, ' ') + call add_default ('VTEND_PHYSTOT' , history_budget_histfile_num, ' ') + end if + + ! create history variables for fourier coefficients of the diurnal + ! and semidiurnal tide in T, U, V, and Z3 + call tidal_diag_init() + + call addfld( 'CPAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable specific heat cap air' ) + call addfld( 'RAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable dry air gas constant' ) + +!+tht temp diag for material enthalpy fluxes (debug) + !if (compute_enthalpy_flux) then + if(debug_enthalpy_flux) then + !+pel + call addfld('enth_prec_ac_hice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_hliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_hice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_hliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_fice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_fliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_fice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_fliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fevap' ,horiz_only, 'A', 'W/m2', '' ) + !-pel + call addfld('enth_frain_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hevap_atm' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hevap_ocn' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) + endif + !+pel + call addfld('te_tnd' , horiz_only, 'A', 'W/m2', 'Total column integrated energy tendency from CAM physics' ) + call addfld('dEdt_dme' , horiz_only, 'A', 'W/m2', 'Column integrated dEdt from water update') + call addfld('dEdt_physics' , horiz_only, 'A', 'W/m2', '' )!xxx diags will remove + call addfld('dEdt_efix_physics', horiz_only, 'A', 'W/m2', 'Column integrated physics energy fixer dEdt from enthalpy fixer' ) + !-pel + !endif +!-tht + + if (thermo_budget_history) then + ! + ! energy diagnostics addflds for vars_stage combinations plus e_m_snapshots + ! + do istage = 1, num_stages + call cam_budget_em_snapshot(TRIM(ADJUSTL(stage(istage))),'phy',longname=TRIM(ADJUSTL(stage_txt(istage)))) + end do + + ! Create budgets that are a sum/dif of 2 stages + + call cam_budget_em_register('dEdt_param_efix_physE','phAP','phBF','phy','dif',longname='dE/dt CAM physics + energy fixer using physics E formula (phAP-phBF)') + call cam_budget_em_register('dEdt_param_efix_dynE' ,'dyAP','dyBF','phy','dif',longname='dE/dt CAM physics + energy fixer using dycore E formula (dyAP-dyBF)') + call cam_budget_em_register('dEdt_param_physE' ,'phAP','phBP','phy','dif',longname='dE/dt CAM physics using physics E formula (phAP-phBP)') + call cam_budget_em_register('dEdt_param_dynE' ,'dyAP','dyBP','phy','dif',longname='dE/dt CAM physics using dycore E (dyAP-dyBP)') + call cam_budget_em_register('dEdt_dme_adjust_physE','phAM','phAP','phy','dif',longname='dE/dt dry mass adjustment using physics E formula (phAM-phAP)') + call cam_budget_em_register('dEdt_dme_adjust_dynE' ,'dyAM','dyAP','phy','dif',longname='dE/dt dry mass adjustment using dycore E (dyAM-dyAP)') + call cam_budget_em_register('dEdt_efix_physE' ,'phBP','phBF','phy','dif',longname='dE/dt energy fixer using physics E formula (phBP-phBF)') + call cam_budget_em_register('dEdt_efix_dynE' ,'dyBP','dyBF','phy','dif',longname='dE/dt energy fixer using dycore E formula (dyBP-dyBF)') + call cam_budget_em_register('dEdt_phys_tot_physE' ,'phAM','phBF','phy','dif',longname='dE/dt physics total using physics E formula (phAM-phBF)') + call cam_budget_em_register('dEdt_phys_tot_dynE' ,'dyAM','dyBF','phy','dif',longname='dE/dt physics total using dycore E (dyAM-dyBF)') + endif + end subroutine diag_init_dry + + subroutine diag_init_moist(pbuf2d) + + ! Declare the history fields for which this module contains outfld calls. + + use cam_history, only: addfld, add_default, horiz_only + use constituent_burden, only: constituent_burden_init + use physics_buffer, only: pbuf_set_field + + type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) + + integer :: m + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: ierr + ! column burdens for all constituents except water vapor + call constituent_burden_init + + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + + ! outfld calls in diag_phys_writeout + call addfld ('OMEGAQ', (/ 'lev' /), 'A', 'kgPa/kgs', 'Vertical water transport' ) + call addfld ('UQ', (/ 'lev' /), 'A', 'm/skg/kg', 'Zonal water transport') + call addfld ('VQ', (/ 'lev' /), 'A', 'm/skg/kg', 'Meridional water transport') + call addfld ('QQ', (/ 'lev' /), 'A', 'kg2/kg2', 'Eddy moisture variance') + + call addfld ('MQ', (/ 'lev' /), 'A', 'kg/m2','Water vapor mass in layer') + call addfld ('TMQ', horiz_only, 'A', 'kg/m2','Total (vertically integrated) precipitable water') + call addfld ('RELHUM', (/ 'lev' /), 'A', 'percent','Relative humidity') + call addfld ('RHW', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to liquid') + call addfld ('RHI', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to ice') + call addfld ('RHCFMIP', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to water above 273 K, ice below 273 K') + + call addfld ('IVT', horiz_only, 'A', 'kg/m/s','Total (vertically integrated) vapor transport') + call addfld ('uIVT', horiz_only, 'A', 'kg/m/s','u-component (vertically integrated) vapor transport') + call addfld ('vIVT', horiz_only, 'A', 'kg/m/s','v-component (vertically integrated) vapor transport') + + call addfld ('THE8501000', horiz_only, 'A', 'K','ThetaE difference 850 mb - 1000 mb') + call addfld ('THE9251000', horiz_only, 'A', 'K','ThetaE difference 925 mb - 1000 mb') + + call addfld ('Q1000', horiz_only, 'A', 'kg/kg','Specific Humidity at 1000 mbar pressure surface') + call addfld ('Q925', horiz_only, 'A', 'kg/kg','Specific Humidity at 925 mbar pressure surface') + call addfld ('Q850', horiz_only, 'A', 'kg/kg','Specific Humidity at 850 mbar pressure surface') + call addfld ('Q200', horiz_only, 'A', 'kg/kg','Specific Humidity at 200 mbar pressure surface') + call addfld ('QBOT', horiz_only, 'A', 'kg/kg','Lowest model level water vapor mixing ratio') + + call addfld ('PSDRY', horiz_only, 'A', 'Pa', 'Dry surface pressure') + call addfld ('PMID', (/ 'lev' /), 'A', 'Pa', 'Pressure at layer midpoints') + call addfld ('PINT', (/ 'ilev' /), 'A', 'Pa', 'Pressure at layer interfaces') + call addfld ('PDELDRY', (/ 'lev' /), 'A', 'Pa', 'Dry pressure difference between levels') + call addfld ('PDEL', (/ 'lev' /), 'A', 'Pa', 'Pressure difference between levels') + + ! outfld calls in diag_conv + + call addfld ('DTCOND', (/ 'lev' /), 'A','K/s','T tendency - moist processes') + call addfld ('DTCOND_24_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 24hr. cos coeff.') + call addfld ('DTCOND_24_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 24hr. sin coeff.') + call addfld ('DTCOND_12_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. cos coeff.') + call addfld ('DTCOND_12_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. sin coeff.') + call addfld ('DTCOND_08_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. cos coeff.') + call addfld ('DTCOND_08_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. sin coeff.') + + call addfld ('PRECL', horiz_only, 'A', 'm/s','Large-scale (stable) precipitation rate (liq + ice)' ) + call addfld ('PRECC', horiz_only, 'A', 'm/s','Convective precipitation rate (liq + ice)' ) + call addfld ('PRECT', horiz_only, 'A', 'm/s','Total (convective and large-scale) precipitation rate (liq + ice)' ) + call addfld ('PREC_PCW', horiz_only, 'A', 'm/s','LS_pcw precipitation rate') + call addfld ('PREC_zmc', horiz_only, 'A', 'm/s','CV_zmc precipitation rate') + call addfld ('PRECTMX', horiz_only, 'X','m/s','Maximum (convective and large-scale) precipitation rate (liq+ice)' ) + call addfld ('PRECSL', horiz_only, 'A', 'm/s','Large-scale (stable) snow rate (water equivalent)' ) + call addfld ('PRECSC', horiz_only, 'A', 'm/s','Convective snow rate (water equivalent)' ) + call addfld ('PRECCav', horiz_only, 'A', 'm/s','Average large-scale precipitation (liq + ice)' ) + call addfld ('PRECLav', horiz_only, 'A', 'm/s','Average convective precipitation (liq + ice)' ) + + ! outfld calls in diag_surf + + call addfld ('SHFLX', horiz_only, 'A', 'W/m2','Surface sensible heat flux') + call addfld ('LHFLX', horiz_only, 'A', 'W/m2','Surface latent heat flux') + call addfld ('QFLX', horiz_only, 'A', 'kg/m2/s','Surface water flux') + + call addfld ('TAUX', horiz_only, 'A', 'N/m2','Zonal surface stress') + call addfld ('TAUY', horiz_only, 'A', 'N/m2','Meridional surface stress') + call addfld ('TREFHT', horiz_only, 'A', 'K','Reference height temperature') + call addfld ('TREFHTMN', horiz_only, 'M','K','Minimum reference height temperature over output period') + call addfld ('TREFHTMX', horiz_only, 'X','K','Maximum reference height temperature over output period') + call addfld ('QREFHT', horiz_only, 'A', 'kg/kg','Reference height humidity') + call addfld ('U10', horiz_only, 'A', 'm/s','10m wind speed') + call addfld ('UGUST', horiz_only, 'A', 'm/s','Gustiness term added to U10') + call addfld ('U10WITHGUSTS',horiz_only, 'A', 'm/s','10m wind speed with gustiness added') + call addfld ('RHREFHT', horiz_only, 'A', 'fraction','Reference height relative humidity') + + call addfld ('LANDFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by land') + call addfld ('ICEFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by sea-ice') + call addfld ('OCNFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by ocean') + + call addfld ('TREFMNAV', horiz_only, 'A', 'K','Average of TREFHT daily minimum') + call addfld ('TREFMXAV', horiz_only, 'A', 'K','Average of TREFHT daily maximum') + + call addfld ('TS', horiz_only, 'A', 'K','Surface temperature (radiative)') + call addfld ('TSMN', horiz_only, 'M','K','Minimum surface temperature over output period') + call addfld ('TSMX', horiz_only, 'X','K','Maximum surface temperature over output period') + call addfld ('SNOWHLND', horiz_only, 'A', 'm','Water equivalent snow depth') + call addfld ('SNOWHICE', horiz_only, 'A', 'm','Snow depth over ice', fill_value = 1.e30_r8) + call addfld ('TBOT', horiz_only, 'A', 'K','Lowest model level temperature') + + call addfld ('ASDIR', horiz_only, 'A', '1','albedo: shortwave, direct') + call addfld ('ASDIF', horiz_only, 'A', '1','albedo: shortwave, diffuse') + call addfld ('ALDIR', horiz_only, 'A', '1','albedo: longwave, direct') + call addfld ('ALDIF', horiz_only, 'A', '1','albedo: longwave, diffuse') + call addfld ('SST', horiz_only, 'A', 'K','sea surface temperature') + + + ! outfld calls in diag_phys_tend_writeout + + call addfld (ptendnam( 1),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name( 1))//' total physics tendency ' ) + + if (ixcldliq > 0) then + call addfld (ptendnam(ixcldliq),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldliq))//' total physics tendency ' ) + end if + if (ixcldice > 0) then + call addfld (ptendnam(ixcldice),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldice))//' total physics tendency ') + end if + + ! outfld calls in diag_physvar_ic + + call addfld ('QCWAT&IC', (/ 'lev' /), 'I','kg/kg','q associated with cloud water' ) + call addfld ('TCWAT&IC', (/ 'lev' /), 'I','kg/kg','T associated with cloud water' ) + call addfld ('LCWAT&IC', (/ 'lev' /), 'I','kg/kg','Cloud water (ice + liq' ) + call addfld ('CLOUD&IC', (/ 'lev' /), 'I','fraction','Cloud fraction' ) + call addfld ('CONCLD&IC', (/ 'lev' /), 'I','fraction','Convective cloud fraction' ) + call addfld ('TKE&IC', (/ 'ilev' /), 'I','m2/s2','Turbulent Kinetic Energy' ) + call addfld ('CUSH&IC', horiz_only, 'I','m','Convective Scale Height' ) + call addfld ('KVH&IC', (/ 'ilev' /), 'I','m2/s','Vertical diffusion diffusivities (heat/moisture)' ) + call addfld ('KVM&IC', (/ 'ilev' /), 'I','m2/s','Vertical diffusion diffusivities (momentum)' ) + call addfld ('PBLH&IC', horiz_only, 'I','m','PBL height' ) + call addfld ('TPERT&IC', horiz_only, 'I','K','Perturbation temperature (eddies in PBL)' ) + call addfld ('QPERT&IC', horiz_only, 'I','kg/kg','Perturbation specific humidity (eddies in PBL)' ) + + ! CAM export state + call addfld('a2x_BCPHIWET', horiz_only, 'A', 'kg/m2/s', 'wetdep of hydrophilic black carbon') + call addfld('a2x_BCPHIDRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophilic black carbon') + call addfld('a2x_BCPHODRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophobic black carbon') + call addfld('a2x_OCPHIWET', horiz_only, 'A', 'kg/m2/s', 'wetdep of hydrophilic organic carbon') + call addfld('a2x_OCPHIDRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophilic organic carbon') + call addfld('a2x_OCPHODRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophobic organic carbon') + call addfld('a2x_DSTWET1', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin1)') + call addfld('a2x_DSTDRY1', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin1)') + call addfld('a2x_DSTWET2', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin2)') + call addfld('a2x_DSTDRY2', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin2)') + call addfld('a2x_DSTWET3', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin3)') + call addfld('a2x_DSTDRY3', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin3)') + call addfld('a2x_DSTWET4', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin4)') + call addfld('a2x_DSTDRY4', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin4)') + + call addfld('a2x_NOYDEP', horiz_only, 'A', 'kgN/m2/s', 'NOy Deposition Flux') + call addfld('a2x_NHXDEP', horiz_only, 'A', 'kgN/m2/s', 'NHx Deposition Flux') + + ! defaults + if (history_amwg) then + call add_default (cnst_name(1), 1, ' ') + call add_default ('VQ ', 1, ' ') + call add_default ('TMQ ', 1, ' ') + call add_default ('PSL ', 1, ' ') + call add_default ('RELHUM ', 1, ' ') + + call add_default ('DTCOND ', 1, ' ') + call add_default ('PRECL ', 1, ' ') + call add_default ('PRECC ', 1, ' ') + call add_default ('PRECSL ', 1, ' ') + call add_default ('PRECSC ', 1, ' ') + call add_default ('SHFLX ', 1, ' ') + call add_default ('LHFLX ', 1, ' ') + call add_default ('QFLX ', 1, ' ') + call add_default ('TAUX ', 1, ' ') + call add_default ('TAUY ', 1, ' ') + call add_default ('TREFHT ', 1, ' ') + call add_default ('LANDFRAC', 1, ' ') + call add_default ('OCNFRAC ', 1, ' ') + call add_default ('QREFHT ', 1, ' ') + call add_default ('U10 ', 1, ' ') + call add_default ('ICEFRAC ', 1, ' ') + call add_default ('TS ', 1, ' ') + call add_default ('TSMN ', 1, ' ') + call add_default ('TSMX ', 1, ' ') + call add_default ('SNOWHLND', 1, ' ') + call add_default ('SNOWHICE', 1, ' ') + end if + + if (dycore_is('SE')) then + call add_default ('PSDRY', 1, ' ') + call add_default ('PMID', 1, ' ') + end if + + if (dycore_is('MPAS')) then + call add_default ('PINT', 1, ' ') + call add_default ('PMID', 1, ' ') + call add_default ('PDEL', 1, ' ') + end if + + if (history_eddy) then + call add_default ('UQ ', 1, ' ') + call add_default ('VQ ', 1, ' ') + endif + + if ( history_budget ) then + call add_default (cnst_name(1), history_budget_histfile_num, ' ') + call add_default ('PTTEND' , history_budget_histfile_num, ' ') + call add_default ('UTEND_PHYSTOT' , history_budget_histfile_num, ' ') + call add_default ('VTEND_PHYSTOT' , history_budget_histfile_num, ' ') + call add_default (ptendnam( 1), history_budget_histfile_num, ' ') + if (ixcldliq > 0) then + call add_default (ptendnam(ixcldliq), history_budget_histfile_num, ' ') + end if + if (ixcldice > 0) then + call add_default (ptendnam(ixcldice), history_budget_histfile_num, ' ') + end if + if( history_budget_histfile_num > 1 ) then + call add_default ('DTCOND ' , history_budget_histfile_num, ' ') + end if + end if + + if (history_vdiag) then + call add_default ('PRECT ', 2, ' ') + call add_default ('PRECT ', 3, ' ') + call add_default ('PRECT ', 4, ' ') + end if + + ! Initial file - Optional fields + if (inithist_all.or.single_column) then + call add_default ('CONCLD&IC ',0, 'I') + call add_default ('QCWAT&IC ',0, 'I') + call add_default ('TCWAT&IC ',0, 'I') + call add_default ('LCWAT&IC ',0, 'I') + call add_default ('PBLH&IC ',0, 'I') + call add_default ('TPERT&IC ',0, 'I') + call add_default ('QPERT&IC ',0, 'I') + call add_default ('CLOUD&IC ',0, 'I') + call add_default ('TKE&IC ',0, 'I') + call add_default ('CUSH&IC ',0, 'I') + call add_default ('KVH&IC ',0, 'I') + call add_default ('KVM&IC ',0, 'I') + end if + + ! determine number of constituents for which convective tendencies must be computed + if (history_budget) then + dqcond_num = pcnst + else + if (diag_cnst_conv_tend == 'none') dqcond_num = 0 + if (diag_cnst_conv_tend == 'q_only') dqcond_num = 1 + if (diag_cnst_conv_tend == 'all') dqcond_num = pcnst + end if + + do m = 1, dqcond_num + dcconnam(m) = 'DC'//cnst_name(m) + end do + + if ((diag_cnst_conv_tend == 'q_only') .or. (diag_cnst_conv_tend == 'all') .or. history_budget) then + call addfld (dcconnam(1),(/ 'lev' /),'A', 'kg/kg/s',trim(cnst_name(1))//' tendency due to moist processes') + if ( diag_cnst_conv_tend == 'q_only' .or. diag_cnst_conv_tend == 'all' ) then + call add_default (dcconnam(1), 1, ' ') + end if + if( history_budget ) then + call add_default (dcconnam(1), history_budget_histfile_num, ' ') + end if + if (diag_cnst_conv_tend == 'all' .or. history_budget) then + do m = 2, pcnst + call addfld (dcconnam(m),(/ 'lev' /),'A', 'kg/kg/s',trim(cnst_name(m))//' tendency due to moist processes') + if( diag_cnst_conv_tend == 'all' ) then + call add_default (dcconnam(m), 1, ' ') + end if + if( history_budget .and. (m == ixcldliq .or. m == ixcldice) ) then + call add_default (dcconnam(m), history_budget_histfile_num, ' ') + end if + end do + end if + end if + + ! Pbuf field indices for collecting output data + relhum_idx = pbuf_get_index('RELHUM', errcode=ierr) + qcwat_idx = pbuf_get_index('QCWAT', errcode=ierr) + tcwat_idx = pbuf_get_index('TCWAT', errcode=ierr) + lcwat_idx = pbuf_get_index('LCWAT', errcode=ierr) + cld_idx = pbuf_get_index('CLD', errcode=ierr) + concld_idx = pbuf_get_index('CONCLD', errcode=ierr) + + tke_idx = pbuf_get_index('tke', errcode=ierr) + kvm_idx = pbuf_get_index('kvm', errcode=ierr) + kvh_idx = pbuf_get_index('kvh', errcode=ierr) + cush_idx = pbuf_get_index('cush', errcode=ierr) + + pblh_idx = pbuf_get_index('pblh', errcode=ierr) + tpert_idx = pbuf_get_index('tpert', errcode=ierr) + qpert_idx = pbuf_get_index('qpert', errcode=ierr) + + prec_dp_idx = pbuf_get_index('PREC_DP', errcode=ierr) + snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=ierr) + prec_sh_idx = pbuf_get_index('PREC_SH', errcode=ierr) + snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=ierr) + prec_sed_idx = pbuf_get_index('PREC_SED', errcode=ierr) + snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=ierr) + prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=ierr) + snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=ierr) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, trefmxav_idx, -1.0e36_r8) + call pbuf_set_field(pbuf2d, trefmnav_idx, 1.0e36_r8) + end if + + end subroutine diag_init_moist + + subroutine diag_init(pbuf2d) + + ! Declare the history fields for which this module contains outfld calls. + + type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) + + ! ---------------------------- + ! determine default variables + ! ---------------------------- + call phys_getopts(history_amwg_out = history_amwg , & + history_vdiag_out = history_vdiag , & + history_eddy_out = history_eddy , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm) + + call diag_init_dry(pbuf2d) + if (moist_physics) then + call diag_init_moist(pbuf2d) + end if + + end subroutine diag_init + +!=============================================================================== + + subroutine diag_allocate_dry() + use infnan, only: nan, assignment(=) + + ! Allocate memory for module variables. + ! Done at the begining of a physics step at same point as the pbuf allocate + ! for variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_allocate_dry' + character(len=128) :: errmsg + integer :: istat + + allocate(dtcond(pcols,pver,begchunk:endchunk), stat=istat) + if ( istat /= 0 ) then + write(errmsg, '(2a,i0)') sub, ': allocate failed, stat = ',istat + call endrun (errmsg) + end if + dtcond = nan + end subroutine diag_allocate_dry + + subroutine diag_allocate_moist() + use infnan, only: nan, assignment(=) + + ! Allocate memory for module variables. + ! Done at the begining of a physics step at same point as the pbuf allocate + ! for variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_allocate_moist' + character(len=128) :: errmsg + integer :: i, istat + + if (dqcond_num > 0) then + allocate(dqcond(dqcond_num)) + do i = 1, dqcond_num + allocate(dqcond(i)%cnst(pcols,pver,begchunk:endchunk), stat=istat) + if ( istat /= 0 ) then + write(errmsg, '(2a,i0)') sub, ': allocate failed, stat = ',istat + call endrun (errmsg) + end if + dqcond(i)%cnst = nan + end do + end if + + end subroutine diag_allocate_moist + + subroutine diag_allocate() + + call diag_allocate_dry() + if (moist_physics) then + call diag_allocate_moist() + end if + + end subroutine diag_allocate + +!=============================================================================== + + subroutine diag_deallocate_dry() + ! Deallocate memory for module variables. + ! Done at the end of a physics step at same point as the pbuf deallocate for + ! variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_deallocate_dry' + integer :: istat + + deallocate(dtcond, stat=istat) + if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') + end subroutine diag_deallocate_dry + + subroutine diag_deallocate_moist() + + ! Deallocate memory for module variables. + ! Done at the end of a physics step at same point as the pbuf deallocate for + ! variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_deallocate_moist' + integer :: i, istat + + if (dqcond_num > 0) then + do i = 1, dqcond_num + deallocate(dqcond(i)%cnst, stat=istat) + if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') + end do + deallocate(dqcond, stat=istat) + if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') + end if + end subroutine diag_deallocate_moist + + subroutine diag_deallocate() + + call diag_deallocate_dry() + if (moist_physics) then + call diag_deallocate_moist() + end if + + end subroutine diag_deallocate + +!=============================================================================== + + subroutine diag_conv_tend_ini(state,pbuf) + + ! Initialize convective tendency calcs. + + ! Arguments: + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variables: + + integer :: i, k, m, lchnk, ncol + real(r8), pointer, dimension(:,:) :: t_ttend + real(r8), pointer, dimension(:,:) :: t_utend + real(r8), pointer, dimension(:,:) :: t_vtend + + lchnk = state%lchnk + ncol = state%ncol + + do k = 1, pver + do i = 1, ncol + dtcond(i,k,lchnk) = state%t(i,k) + end do + end do + + do m = 1, dqcond_num + do k = 1, pver + do i = 1, ncol + dqcond(m)%cnst(i,k,lchnk) = state%q(i,k,m) + end do + end do + end do + + !! initialize to pbuf T_TTEND to temperature at first timestep + if (is_first_step()) then + do m = 1, dyn_time_lvls + call pbuf_get_field(pbuf, t_ttend_idx, t_ttend, start=(/1,1,m/), kount=(/pcols,pver,1/)) + t_ttend(:ncol,:) = state%t(:ncol,:) + call pbuf_get_field(pbuf, t_utend_idx, t_utend, start=(/1,1,m/), kount=(/pcols,pver,1/)) + t_utend(:ncol,:) = state%u(:ncol,:) + call pbuf_get_field(pbuf, t_vtend_idx, t_vtend, start=(/1,1,m/), kount=(/pcols,pver,1/)) + t_vtend(:ncol,:) = state%v(:ncol,:) + end do + end if + + end subroutine diag_conv_tend_ini + +!=============================================================================== + + subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) + + !----------------------------------------------------------------------- + ! + ! Purpose: output dry physics diagnostics + ! + !----------------------------------------------------------------------- + use physconst, only: gravit, rga, rair, cappa + use time_manager, only: get_nstep + use interpolate_data, only: vertinterp + use tidal_diag, only: tidal_diag_write + use air_composition, only: cpairv, rairv + use cam_diagnostic_utils, only: cpslec + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface + ! + !---------------------------Local workspace----------------------------- + ! + real(r8) :: ftem(pcols,pver) ! temporary workspace + real(r8) :: z3(pcols,pver) ! geo-potential height + real(r8) :: p_surf(pcols) ! data interpolated to a pressure surface + real(r8) :: timestep(pcols) ! used for outfld call + + real(r8), pointer :: psl(:) ! Sea Level Pressure + + integer :: i, k, m, lchnk, ncol, nstep + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + ncol = state%ncol + + ! Output NSTEP for debugging + nstep = get_nstep() + timestep(:ncol) = nstep + call outfld ('NSTEP ',timestep, pcols, lchnk) + + call outfld('T ',state%t , pcols ,lchnk ) + call outfld('PS ',state%ps, pcols ,lchnk ) + call outfld('U ',state%u , pcols ,lchnk ) + call outfld('V ',state%v , pcols ,lchnk ) + + call outfld('PHIS ',state%phis, pcols, lchnk ) + + if (write_camiop) call outfld('phis ',state%phis, pcols, lchnk ) + + call outfld( 'CPAIRV', cpairv(:ncol,:,lchnk), ncol, lchnk ) + call outfld( 'RAIRV', rairv(:ncol,:,lchnk), ncol, lchnk ) + + do m = 1, pcnst + if (cnst_cam_outfld(m)) then + call outfld(cnst_name(m), state%q(1,1,m), pcols, lchnk) + end if + end do + + ! + ! Add height of surface to midpoint height above surface + ! + do k = 1, pver + z3(:ncol,k) = state%zm(:ncol,k) + state%phis(:ncol)*rga + end do + call outfld('Z3 ',z3,pcols,lchnk) + ! + ! Output Z3 on pressure surfaces + ! + if (hist_fld_active('Z1000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, z3, p_surf, & + extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) + call outfld('Z1000 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z700')) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, z3, p_surf, & + extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) + call outfld('Z700 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, z3, p_surf, & + extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) + call outfld('Z500 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z300')) then + call vertinterp(ncol, pcols, pver, state%pmid, 30000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z300 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z200 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z100')) then + call vertinterp(ncol, pcols, pver, state%pmid, 10000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z100 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z050')) then + call vertinterp(ncol, pcols, pver, state%pmid, 5000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z050 ', p_surf, pcols, lchnk) + end if + ! + ! Quadratic height fiels Z3*Z3 + ! + ftem(:ncol,:) = z3(:ncol,:)*z3(:ncol,:) + call outfld('ZZ ',ftem,pcols,lchnk) + + ftem(:ncol,:) = z3(:ncol,:)*state%v(:ncol,:) + call outfld('VZ ',ftem, pcols,lchnk) + ! + ! Meridional advection fields + ! + ftem(:ncol,:) = state%v(:ncol,:)*state%t(:ncol,:) + call outfld ('VT ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%v(:ncol,:)**2 + call outfld ('VV ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%v(:ncol,:) * state%u(:ncol,:) + call outfld ('VU ',ftem ,pcols ,lchnk ) + ! + ! zonal advection + ! + ftem(:ncol,:) = state%u(:ncol,:)*state%t(:ncol,:) + call outfld ('UT ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%u(:ncol,:)**2 + call outfld ('UU ',ftem ,pcols ,lchnk ) + + ! Wind speed + ftem(:ncol,:) = sqrt( state%u(:ncol,:)**2 + state%v(:ncol,:)**2) + call outfld ('WSPEED ',ftem ,pcols ,lchnk ) + call outfld ('WSPDSRFMX',ftem(:,pver) ,pcols ,lchnk ) + call outfld ('WSPDSRFAV',ftem(:,pver) ,pcols ,lchnk ) + + ! Vertical velocity and advection + + if (single_column) then + call outfld('OMEGA ',wfld, pcols, lchnk ) + else + call outfld('OMEGA ',state%omega, pcols, lchnk ) + endif + + if (write_camiop) call outfld('omega ',state%omega, pcols, lchnk ) + + ftem(:ncol,:) = state%omega(:ncol,:)*state%t(:ncol,:) + call outfld('OMEGAT ',ftem, pcols, lchnk ) + ftem(:ncol,:) = state%omega(:ncol,:)*state%u(:ncol,:) + call outfld('OMEGAU ',ftem, pcols, lchnk ) + ftem(:ncol,:) = state%omega(:ncol,:)*state%v(:ncol,:) + call outfld('OMEGAV ',ftem, pcols, lchnk ) + ftem(:ncol,:) = state%omega(:ncol,:)*state%omega(:ncol,:) + call outfld('OMGAOMGA',ftem, pcols, lchnk ) + ! + ! Output omega at 850 and 500 mb pressure levels + ! + if (hist_fld_active('OMEGA850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%omega, p_surf) + call outfld('OMEGA850', p_surf, pcols, lchnk) + end if + if (hist_fld_active('OMEGA500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%omega, p_surf) + call outfld('OMEGA500', p_surf, pcols, lchnk) + end if + + ! Sea level pressure + call pbuf_get_field(pbuf, psl_idx, psl) + call cpslec(ncol, state%pmid, state%phis, state%ps, state%t, psl, gravit, rair) + call outfld('PSL', psl, pcols, lchnk) + + ! Output T,u,v fields on pressure surfaces + ! + if (hist_fld_active('T850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf, & + extrapolate='T', ps=state%ps, phis=state%phis) + call outfld('T850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%t, p_surf, & + extrapolate='T', ps=state%ps, phis=state%phis) + call outfld('T500 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T400')) then + call vertinterp(ncol, pcols, pver, state%pmid, 40000._r8, state%t, p_surf, & + extrapolate='T', ps=state%ps, phis=state%phis) + call outfld('T400 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T300')) then + call vertinterp(ncol, pcols, pver, state%pmid, 30000._r8, state%t, p_surf) + call outfld('T300 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%t, p_surf) + call outfld('T200 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%u, p_surf) + call outfld('U850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%u, p_surf) + call outfld('U500 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U250')) then + call vertinterp(ncol, pcols, pver, state%pmid, 25000._r8, state%u, p_surf) + call outfld('U250 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%u, p_surf) + call outfld('U200 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U010')) then + call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%u, p_surf) + call outfld('U010 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%v, p_surf) + call outfld('V850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%v, p_surf) + call outfld('V500 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V250')) then + call vertinterp(ncol, pcols, pver, state%pmid, 25000._r8, state%v, p_surf) + call outfld('V250 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%v, p_surf) + call outfld('V200 ', p_surf, pcols, lchnk ) + end if + + ftem(:ncol,:) = state%t(:ncol,:)*state%t(:ncol,:) + call outfld('TT ',ftem ,pcols ,lchnk ) + ! + ! Output U, V, T, P and Z at bottom level + ! + call outfld ('UBOT ', state%u(1,pver) , pcols, lchnk) + call outfld ('VBOT ', state%v(1,pver) , pcols, lchnk) + call outfld ('ZBOT ', state%zm(1,pver) , pcols, lchnk) + + !! Boundary layer atmospheric stability, temperature, water vapor diagnostics + + p_surf_t = -99.0_r8 ! Uninitialized to impossible value + if (hist_fld_active('T1000') .or. & + hist_fld_active('T9251000') .or. & + hist_fld_active('TH9251000') .or. & + hist_fld_active('T8501000') .or. & + hist_fld_active('TH8501000') .or. & + hist_fld_active('T7001000') .or. & + hist_fld_active('TH7001000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%t, p_surf_t(:,surf_100000)) + end if + + if ( hist_fld_active('T925') .or. & + hist_fld_active('T9251000') .or. & + hist_fld_active('TH9251000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%t, p_surf_t(:,surf_092500)) + end if + +!!! at 1000 mb and 925 mb + if (hist_fld_active('T1000')) then + call outfld('T1000 ', p_surf_t(:,surf_100000), pcols, lchnk ) + end if + + if (hist_fld_active('T925')) then + call outfld('T925 ', p_surf_t(:,surf_092500), pcols, lchnk ) + end if + + if (hist_fld_active('T9251000')) then + p_surf = p_surf_t(:,surf_092500) - p_surf_t(:,surf_100000) + call outfld('T9251000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('TH9251000')) then + p_surf = (p_surf_t(:,surf_092500)*(1000.0_r8/925.0_r8)**cappa) - (p_surf_t(:,surf_100000)*(1.0_r8)**cappa) + call outfld('TH9251000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('T8501000') .or. & + hist_fld_active('TH8501000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf_t(:,surf_085000)) + end if + +!!! at 1000 mb and 850 mb + if (hist_fld_active('T8501000')) then + p_surf = p_surf_t(:,surf_085000)-p_surf_t(:,surf_100000) + call outfld('T8501000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('TH8501000')) then + p_surf = (p_surf_t(:,surf_085000)*(1000.0_r8/850.0_r8)**cappa)-(p_surf_t(:,surf_100000)*(1.0_r8)**cappa) + call outfld('TH8501000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('T7001000') .or. & + hist_fld_active('TH7001000') .or. & + hist_fld_active('T700')) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%t, p_surf_t(:,surf_070000)) + end if + +!!! at 700 mb + if (hist_fld_active('T700')) then + call outfld('T700 ', p_surf_t(:,surf_070000), pcols, lchnk ) + end if + +!!! at 1000 mb and 700 mb + if (hist_fld_active('T7001000')) then + p_surf = p_surf_t(:,surf_070000)-p_surf_t(:,surf_100000) + call outfld('T7001000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('TH7001000')) then + p_surf = (p_surf_t(:,surf_070000)*(1000.0_r8/700.0_r8)**cappa)-(p_surf_t(:,surf_100000)*(1.0_r8)**cappa) + call outfld('TH7001000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('T010')) then + call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%t, p_surf) + call outfld('T010 ', p_surf, pcols, lchnk ) + end if + + !--------------------------------------------------------- + ! tidal diagnostics + !--------------------------------------------------------- + call tidal_diag_write(state) + + return + end subroutine diag_phys_writeout_dry + +!=============================================================================== + + subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) + + !----------------------------------------------------------------------- + ! + ! Purpose: record dynamics variables on physics grid + ! + !----------------------------------------------------------------------- + use physconst, only: gravit, rga, rair, cpair, latvap, rearth, cappa + use interpolate_data, only: vertinterp + use constituent_burden, only: constituent_burden_comp + use co2_cycle, only: c_i, co2_transport + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(inout) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface + ! + !---------------------------Local workspace----------------------------- + ! + real(r8) :: ftem(pcols,pver) ! temporary workspace + real(r8) :: ftem1(pcols,pver) ! another temporary workspace + real(r8) :: ftem2(pcols,pver) ! another temporary workspace + real(r8) :: p_surf(pcols) ! data interpolated to a pressure surface + real(r8) :: p_surf_q1(pcols) ! data interpolated to a pressure surface + real(r8) :: p_surf_q2(pcols) ! data interpolated to a pressure surface + real(r8) :: tem2(pcols,pver) ! temporary workspace + real(r8) :: esl(pcols,pver) ! saturation vapor pressures + real(r8) :: esi(pcols,pver) ! + + real(r8), pointer :: ftem_ptr(:,:) + + integer :: i, k, m, lchnk, ncol + integer :: ixq, ierr + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + ncol = state%ncol + + call cnst_get_ind('Q', ixq) + + if (co2_transport()) then + do m = 1,4 + call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(1,pver,c_i(m)), pcols, lchnk) + end do + end if + + ! column burdens of all constituents except water vapor + call constituent_burden_comp(state) + + call outfld('PSDRY', state%psdry, pcols, lchnk) + call outfld('PMID', state%pmid, pcols, lchnk) + call outfld('PINT', state%pint, pcols, lchnk) + call outfld('PDELDRY', state%pdeldry, pcols, lchnk) + call outfld('PDEL', state%pdel, pcols, lchnk) + + + ftem(:ncol,:) = state%u(:ncol,:)*state%q(:ncol,:,ixq) + call outfld ('UQ ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%v(:ncol,:)*state%q(:ncol,:,ixq) + call outfld ('VQ ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%q(:ncol,:,1)*state%q(:ncol,:,ixq) + call outfld ('QQ ',ftem ,pcols ,lchnk ) + + ! Vertical velocity and advection + ftem(:ncol,:) = state%omega(:ncol,:)*state%q(:ncol,:,ixq) + call outfld('OMEGAQ ',ftem, pcols, lchnk ) + ! + ! Mass of q, by layer and vertically integrated + ! + ftem(:ncol,:) = state%q(:ncol,:,ixq) * state%pdel(:ncol,:) * rga + call outfld ('MQ ',ftem ,pcols ,lchnk ) + + do k=2,pver + ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) + end do + call outfld ('TMQ ',ftem, pcols ,lchnk ) + ! + ! Integrated vapor transport calculation + ! + !compute uq*dp/g and vq*dp/g + ftem1(:ncol,:) = state%q(:ncol,:,ixq) * state%u(:ncol,:) *state%pdel(:ncol,:) * rga + ftem2(:ncol,:) = state%q(:ncol,:,ixq) * state%v(:ncol,:) *state%pdel(:ncol,:) * rga + + do k=2,pver + ftem1(:ncol,1) = ftem1(:ncol,1) + ftem1(:ncol,k) + ftem2(:ncol,1) = ftem2(:ncol,1) + ftem2(:ncol,k) + end do + ! compute ivt + ftem(:ncol,1) = sqrt( ftem1(:ncol,1)**2 + ftem2(:ncol,1)**2) + + call outfld ('IVT ',ftem, pcols ,lchnk ) + + ! output uq*dp/g + call outfld ('uIVT ',ftem1, pcols ,lchnk ) + + ! output vq*dp/g + call outfld ('vIVT ',ftem2, pcols ,lchnk ) + ! + ! Relative humidity + ! + if (hist_fld_active('RELHUM')) then + if (relhum_idx > 0) then + call pbuf_get_field(pbuf, relhum_idx, ftem_ptr) + ftem(:ncol,:) = ftem_ptr(:ncol,:) + else + do k = 1, pver + call qsat(state%t(1:ncol,k), state%pmid(1:ncol,k), tem2(1:ncol,k), ftem(1:ncol,k), ncol) + end do + ftem(:ncol,:) = state%q(:ncol,:,ixq)/ftem(:ncol,:)*100._r8 + end if + call outfld ('RELHUM ',ftem ,pcols ,lchnk ) + end if + + if (hist_fld_active('RHW') .or. hist_fld_active('RHI') .or. hist_fld_active('RHCFMIP') ) then + + ! RH w.r.t liquid (water) + do k = 1, pver + call qsat_water (state%t(1:ncol,k), state%pmid(1:ncol,k), esl(1:ncol,k), ftem(1:ncol,k), ncol) + end do + ftem(:ncol,:) = state%q(:ncol,:,ixq)/ftem(:ncol,:)*100._r8 + call outfld ('RHW ',ftem ,pcols ,lchnk ) + + ! Convert to RHI (ice) + do k=1,pver + call svp_ice_vect(state%t(1:ncol,k), esi(1:ncol,k), ncol) + do i=1,ncol + ftem1(i,k)=ftem(i,k)*esl(i,k)/esi(i,k) + end do + end do + call outfld ('RHI ',ftem1 ,pcols ,lchnk ) + + ! use temperature to decide if you populate with ftem (liquid, above 0 C) or ftem1 (ice, below 0 C) + + ftem2(:ncol,:)=ftem(:ncol,:) + + do i=1,ncol + do k=1,pver + if (state%t(i,k) .gt. 273) then + ftem2(i,k)=ftem(i,k) !!wrt water + else + ftem2(i,k)=ftem1(i,k) !!wrt ice + end if + end do + end do + + call outfld ('RHCFMIP ',ftem2 ,pcols ,lchnk ) + + end if + ! + ! Output q field on pressure surfaces + ! + if (hist_fld_active('Q850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,ixq), p_surf) + call outfld('Q850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('Q200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%q(1,1,ixq), p_surf) + call outfld('Q200 ', p_surf, pcols, lchnk ) + end if + ! + ! Output Q at bottom level + ! + call outfld ('QBOT ', state%q(1,pver,ixq), pcols, lchnk) + + ! Total energy of the atmospheric column for atmospheric heat storage calculations + + !! temporary variable to get surface geopotential in dimensions of (ncol,pver) + do k=1,pver + ftem1(:ncol,k)=state%phis(:ncol) !! surface geopotential in units (m2/s2) + end do + + !! calculate sum of sensible, kinetic, latent, and surface geopotential energy + !! E=CpT+PHIS+Lv*q+(0.5)*(u^2+v^2) + ftem(:ncol,:) = (cpair*state%t(:ncol,:) + ftem1(:ncol,:) + latvap*state%q(:ncol,:,ixq) + & + 0.5_r8*(state%u(:ncol,:)**2+state%v(:ncol,:)**2))*(state%pdel(:ncol,:)/gravit) + !! vertically integrate + do k=2,pver + ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) + end do + call outfld ('ATMEINT ', ftem(:ncol,1), ncol, lchnk) + + !! Boundary layer atmospheric stability, temperature, water vapor diagnostics + + if ( hist_fld_active('THE9251000') .or. & + hist_fld_active('THE8501000') .or. & + hist_fld_active('THE7001000')) then + if (p_surf_t(1, surf_100000) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%t, p_surf_t(:, surf_100000)) + end if + end if + + if ( hist_fld_active('TH9251000') .or. & + hist_fld_active('THE9251000')) then + if (p_surf_t(1, surf_092500) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%t, p_surf_t(:, surf_092500)) + end if + end if + + if ( hist_fld_active('Q1000') .or. & + hist_fld_active('THE9251000') .or. & + hist_fld_active('THE8501000') .or. & + hist_fld_active('THE7001000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%q(1,1,ixq), p_surf_q1) + end if + + if (hist_fld_active('THE9251000') .or. & + hist_fld_active('Q925')) then + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%q(1,1,ixq), p_surf_q2) + end if + +!!! at 1000 mb and 925 mb + if (hist_fld_active('Q1000')) then + call outfld('Q1000 ', p_surf_q1, pcols, lchnk ) + end if + + if (hist_fld_active('Q925')) then + call outfld('Q925 ', p_surf_q2, pcols, lchnk ) + end if + + if (hist_fld_active('THE9251000')) then + p_surf = ((p_surf_t(:, surf_092500)*(1000.0_r8/925.0_r8)**cappa) * & + exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_092500)))) - & + (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) + call outfld('THE9251000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('THE8501000')) then + if (p_surf_t(1, surf_085000) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf_t(:, surf_085000)) + end if + end if + +!!! at 1000 mb and 850 mb + if (hist_fld_active('THE8501000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,ixq), p_surf_q2) + p_surf = ((p_surf_t(:, surf_085000)*(1000.0_r8/850.0_r8)**cappa) * & + exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_085000)))) - & + (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) + call outfld('THE8501000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('THE7001000')) then + if (p_surf_t(1, surf_070000) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%t, p_surf_t(:, surf_070000)) + end if + end if + +!!! at 1000 mb and 700 mb + if (hist_fld_active('THE7001000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%q(1,1,ixq), p_surf_q2) + p_surf = ((p_surf_t(:, surf_070000)*(1000.0_r8/700.0_r8)**cappa) * & + exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_070000)))) - & + (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) + call outfld('THE7001000 ', p_surf, pcols, lchnk ) + end if + + return + end subroutine diag_phys_writeout_moist + +!=============================================================================== + + subroutine diag_phys_writeout(state, pbuf) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variable + real(r8) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface + + call diag_phys_writeout_dry(state, pbuf, p_surf_t) + + if (moist_physics) then + call diag_phys_writeout_moist(state, pbuf, p_surf_t) + end if + + end subroutine diag_phys_writeout + +!=============================================================================== + + subroutine diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + type(physics_ptend), intent(in) :: ptend + integer :: ncol + integer :: lchnk + integer :: ixcldliq + integer :: ixcldice + integer :: ixq + real(r8) :: ztodt + real(r8) :: rtdt + + ! Local variables + + ! Debugging output to look at ice tendencies due to hard clipping negative values + real(r8) :: preclipice(pcols,pver) + real(r8) :: icecliptend(pcols,pver) + real(r8) :: preclipliq(pcols,pver) + real(r8) :: liqcliptend(pcols,pver) + real(r8) :: preclipvap(pcols,pver) + real(r8) :: vapcliptend(pcols,pver) + + ! Initialize to zero + liqcliptend(:,:) = 0._r8 + icecliptend(:,:) = 0._r8 + vapcliptend(:,:) = 0._r8 + + preclipliq(:ncol,:) = state%q(:ncol,:,ixcldliq)+(ptend%q(:ncol,:,ixcldliq)*ztodt) + preclipice(:ncol,:) = state%q(:ncol,:,ixcldice)+(ptend%q(:ncol,:,ixcldice)*ztodt) + preclipvap(:ncol,:) = state%q(:ncol,:,ixq)+(ptend%q(:ncol,:,ixq)*ztodt) + vapcliptend(:ncol,:) = (state%q(:ncol,:,ixq)-preclipvap(:ncol,:))*rtdt + icecliptend(:ncol,:) = (state%q(:ncol,:,ixcldice)-preclipice(:ncol,:))*rtdt + liqcliptend(:ncol,:) = (state%q(:ncol,:,ixcldliq)-preclipliq(:ncol,:))*rtdt + + call outfld('INEGCLPTEND', icecliptend, pcols, lchnk ) + call outfld('LNEGCLPTEND', liqcliptend, pcols, lchnk ) + call outfld('VNEGCLPTEND', vapcliptend, pcols, lchnk ) + + end subroutine diag_clip_tend_writeout + +!=============================================================================== + + subroutine diag_conv(state, ztodt, pbuf) + + !----------------------------------------------------------------------- + ! + ! Output diagnostics associated with all convective processes. + ! + !----------------------------------------------------------------------- + use tidal_diag, only: get_tidal_coeffs + + ! Arguments: + + real(r8), intent(in) :: ztodt ! timestep for computing physics tendencies + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! convective precipitation variables + real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8), pointer :: snow_dp(:) ! snow from ZM convection + real(r8), pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8), pointer :: snow_sh(:) ! snow from Hack convection + real(r8), pointer :: prec_sed(:) ! total precipitation from MG sedimentation + real(r8), pointer :: snow_sed(:) ! snow from MG sedimentation + real(r8), pointer :: prec_pcw(:) ! total precipitation from MG prog. cloud + real(r8), pointer :: snow_pcw(:) ! snow from MG prog. cloud + + ! Local variables: + + integer :: i, k, m, lchnk, ncol + + real(r8) :: rtdt + + real(r8):: precc(pcols) ! convective precip rate + real(r8):: precl(pcols) ! stratiform precip rate + real(r8):: snowc(pcols) ! convective snow rate + real(r8):: snowl(pcols) ! stratiform snow rate + real(r8):: prect(pcols) ! total (conv+large scale) precip rate + real(r8) :: dcoef(6) ! for tidal component of T tend + + lchnk = state%lchnk + ncol = state%ncol + + rtdt = 1._r8/ztodt + + if (moist_physics) then + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) + else + nullify(prec_dp) + end if + if (snow_dp_idx > 0) then + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) + else + nullify(snow_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) + else + nullify(prec_sh) + end if + if (snow_sh_idx > 0) then + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) + else + nullify(snow_sh) + end if + if (prec_sed_idx > 0) then + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) + else + nullify(prec_sed) + end if + if (snow_sed_idx > 0) then + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) + else + nullify(snow_sed) + end if + if (prec_pcw_idx > 0) then + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) + else + nullify(prec_pcw) + end if + if (snow_pcw_idx > 0) then + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) + else + nullify(snow_pcw) + end if + + ! Precipitation rates (multi-process) + if (associated(prec_dp) .and. associated(prec_sh)) then + precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) + else if (associated(prec_dp)) then + precc(:ncol) = prec_dp(:ncol) + else if (associated(prec_sh)) then + precc(:ncol) = prec_sh(:ncol) + else + precc(:ncol) = 0._r8 + end if + if (associated(prec_sed) .and. associated(prec_pcw)) then + precl(:ncol) = prec_sed(:ncol) + prec_pcw(:ncol) + else if (associated(prec_sed)) then + precl(:ncol) = prec_sed(:ncol) + else if (associated(prec_pcw)) then + precl(:ncol) = prec_pcw(:ncol) + else + precl(:ncol) = 0._r8 + end if + if (associated(snow_dp) .and. associated(snow_sh)) then + snowc(:ncol) = snow_dp(:ncol) + snow_sh(:ncol) + else if (associated(snow_dp)) then + snowc(:ncol) = snow_dp(:ncol) + else if (associated(snow_sh)) then + snowc(:ncol) = snow_sh(:ncol) + else + snowc(:ncol) = 0._r8 + end if + if (associated(snow_sed) .and. associated(snow_pcw)) then + snowl(:ncol) = snow_sed(:ncol) + snow_pcw(:ncol) + else if (associated(snow_sed)) then + snowl(:ncol) = snow_sed(:ncol) + else if (associated(snow_pcw)) then + snowl(:ncol) = snow_pcw(:ncol) + else + snowl(:ncol) = 0._r8 + end if + prect(:ncol) = precc(:ncol) + precl(:ncol) + + call outfld('PRECC ', precc, pcols, lchnk ) + call outfld('PRECL ', precl, pcols, lchnk ) + if (associated(prec_pcw)) then + call outfld('PREC_PCW', prec_pcw,pcols ,lchnk ) + end if + if (associated(prec_dp)) then + call outfld('PREC_zmc', prec_dp ,pcols ,lchnk ) + end if + call outfld('PRECSC ', snowc, pcols, lchnk ) + call outfld('PRECSL ', snowl, pcols, lchnk ) + call outfld('PRECT ', prect, pcols, lchnk ) + call outfld('PRECTMX ', prect, pcols, lchnk ) + + call outfld('PRECLav ', precl, pcols, lchnk ) + call outfld('PRECCav ', precc, pcols, lchnk ) + + if (write_camiop) call outfld('Prec ' , prect, pcols, lchnk ) + + ! Total convection tendencies. + + do k = 1, pver + do i = 1, ncol + dtcond(i,k,lchnk) = (state%t(i,k) - dtcond(i,k,lchnk))*rtdt + end do + end do + call outfld('DTCOND ', dtcond(:,:,lchnk), pcols, lchnk) + + ! output tidal coefficients + call get_tidal_coeffs( dcoef ) + call outfld( 'DTCOND_24_SIN', dtcond(:ncol,:,lchnk)*dcoef(1), ncol, lchnk ) + call outfld( 'DTCOND_24_COS', dtcond(:ncol,:,lchnk)*dcoef(2), ncol, lchnk ) + call outfld( 'DTCOND_12_SIN', dtcond(:ncol,:,lchnk)*dcoef(3), ncol, lchnk ) + call outfld( 'DTCOND_12_COS', dtcond(:ncol,:,lchnk)*dcoef(4), ncol, lchnk ) + call outfld( 'DTCOND_08_SIN', dtcond(:ncol,:,lchnk)*dcoef(5), ncol, lchnk ) + call outfld( 'DTCOND_08_COS', dtcond(:ncol,:,lchnk)*dcoef(6), ncol, lchnk ) + + do m = 1, dqcond_num + if ( cnst_cam_outfld(m) ) then + do k = 1, pver + do i = 1, ncol + dqcond(m)%cnst(i,k,lchnk) = (state%q(i,k,m) - dqcond(m)%cnst(i,k,lchnk))*rtdt + end do + end do + call outfld(dcconnam(m), dqcond(m)%cnst(:,:,lchnk), pcols, lchnk) + end if + end do + + end if + end subroutine diag_conv + +!=============================================================================== + + subroutine diag_surf (cam_in, cam_out, state, pbuf) + + !----------------------------------------------------------------------- + ! + ! Purpose: record surface diagnostics + ! + !----------------------------------------------------------------------- + + use time_manager, only: is_end_curr_day + use co2_cycle, only: c_i, co2_transport + use constituents, only: sflxnam + + !----------------------------------------------------------------------- + ! + ! Input arguments + ! + type(cam_in_t), intent(in) :: cam_in + type(cam_out_t), intent(in) :: cam_out + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + ! + !---------------------------Local workspace----------------------------- + ! + integer :: i, k, m ! indexes + integer :: lchnk ! chunk identifier + integer :: ncol ! longitude dimension + real(r8) tem2(pcols) ! temporary workspace + real(r8) ftem(pcols) ! temporary workspace + + real(r8), pointer :: trefmnav(:) ! daily minimum tref + real(r8), pointer :: trefmxav(:) ! daily maximum tref + + ! + !----------------------------------------------------------------------- + ! + lchnk = cam_in%lchnk + ncol = cam_in%ncol + + if (moist_physics) then + call outfld('SHFLX', cam_in%shf, pcols, lchnk) + call outfld('LHFLX', cam_in%lhf, pcols, lchnk) + call outfld('QFLX', cam_in%cflx(1,1), pcols, lchnk) + + call outfld('TAUX', cam_in%wsx, pcols, lchnk) + call outfld('TAUY', cam_in%wsy, pcols, lchnk) + call outfld('TREFHT ', cam_in%tref, pcols, lchnk) + call outfld('TREFHTMX', cam_in%tref, pcols, lchnk) + call outfld('TREFHTMN', cam_in%tref, pcols, lchnk) + call outfld('QREFHT', cam_in%qref, pcols, lchnk) + call outfld('U10', cam_in%u10, pcols, lchnk) + call outfld('UGUST', cam_in%ugustOut, pcols, lchnk) + call outfld('U10WITHGUSTS',cam_in%u10withGusts, pcols, lchnk) + + ! + ! Calculate and output reference height RH (RHREFHT) + call qsat(cam_in%tref(1:ncol), state%ps(1:ncol), tem2(1:ncol), ftem(1:ncol), ncol) + ftem(:ncol) = cam_in%qref(:ncol)/ftem(:ncol)*100._r8 + + + call outfld('RHREFHT', ftem, pcols, lchnk) + + + if (write_camiop) then + call outfld('shflx ',cam_in%shf, pcols, lchnk) + call outfld('lhflx ',cam_in%lhf, pcols, lchnk) + call outfld('trefht ',cam_in%tref, pcols, lchnk) + call outfld('Tg', cam_in%ts, pcols, lchnk) + call outfld('Tsair',cam_in%ts, pcols, lchnk) + end if + ! + ! Ouput ocn and ice fractions + ! + call outfld('LANDFRAC', cam_in%landfrac, pcols, lchnk) + call outfld('ICEFRAC', cam_in%icefrac, pcols, lchnk) + call outfld('OCNFRAC', cam_in%ocnfrac, pcols, lchnk) + ! + ! Compute daily minimum and maximum of TREF + ! + call pbuf_get_field(pbuf, trefmxav_idx, trefmxav) + call pbuf_get_field(pbuf, trefmnav_idx, trefmnav) + do i = 1,ncol + trefmxav(i) = max(cam_in%tref(i),trefmxav(i)) + trefmnav(i) = min(cam_in%tref(i),trefmnav(i)) + end do + if (is_end_curr_day()) then + call outfld('TREFMXAV', trefmxav,pcols, lchnk ) + call outfld('TREFMNAV', trefmnav,pcols, lchnk ) + trefmxav(:ncol) = -1.0e36_r8 + trefmnav(:ncol) = 1.0e36_r8 + endif + + call outfld('TBOT', cam_out%tbot, pcols, lchnk) + call outfld('TS', cam_in%ts, pcols, lchnk) + call outfld('TSMN', cam_in%ts, pcols, lchnk) + call outfld('TSMX', cam_in%ts, pcols, lchnk) + call outfld('SNOWHLND', cam_in%snowhland, pcols, lchnk) + call outfld('SNOWHICE', cam_in%snowhice, pcols, lchnk) + call outfld('ASDIR', cam_in%asdir, pcols, lchnk) + call outfld('ASDIF', cam_in%asdif, pcols, lchnk) + call outfld('ALDIR', cam_in%aldir, pcols, lchnk) + call outfld('ALDIF', cam_in%aldif, pcols, lchnk) + call outfld('SST', cam_in%sst, pcols, lchnk) + + if (co2_transport()) then + do m = 1,4 + call outfld(sflxnam(c_i(m)), cam_in%cflx(:,c_i(m)), pcols, lchnk) + end do + end if + end if + + end subroutine diag_surf + +!=============================================================================== + + subroutine diag_export(cam_out) + + !----------------------------------------------------------------------- + ! + ! Purpose: Write export state to history file + ! + !----------------------------------------------------------------------- + + ! arguments + type(cam_out_t), intent(inout) :: cam_out + + ! Local variables: + integer :: lchnk ! chunk identifier + logical :: atm_dep_flux ! true ==> sending deposition fluxes to coupler. + ! Otherwise, set them to zero. + !----------------------------------------------------------------------- + + lchnk = cam_out%lchnk + + call phys_getopts(atm_dep_flux_out=atm_dep_flux) + + if (.not. atm_dep_flux) then + ! set the fluxes to zero before outfld and sending them to the + ! coupler + cam_out%bcphiwet = 0.0_r8 + cam_out%bcphidry = 0.0_r8 + cam_out%bcphodry = 0.0_r8 + cam_out%ocphiwet = 0.0_r8 + cam_out%ocphidry = 0.0_r8 + cam_out%ocphodry = 0.0_r8 + cam_out%dstwet1 = 0.0_r8 + cam_out%dstdry1 = 0.0_r8 + cam_out%dstwet2 = 0.0_r8 + cam_out%dstdry2 = 0.0_r8 + cam_out%dstwet3 = 0.0_r8 + cam_out%dstdry3 = 0.0_r8 + cam_out%dstwet4 = 0.0_r8 + cam_out%dstdry4 = 0.0_r8 + end if + + if (moist_physics) then + call outfld('a2x_BCPHIWET', cam_out%bcphiwet, pcols, lchnk) + call outfld('a2x_BCPHIDRY', cam_out%bcphidry, pcols, lchnk) + call outfld('a2x_BCPHODRY', cam_out%bcphodry, pcols, lchnk) + call outfld('a2x_OCPHIWET', cam_out%ocphiwet, pcols, lchnk) + call outfld('a2x_OCPHIDRY', cam_out%ocphidry, pcols, lchnk) + call outfld('a2x_OCPHODRY', cam_out%ocphodry, pcols, lchnk) + call outfld('a2x_DSTWET1', cam_out%dstwet1, pcols, lchnk) + call outfld('a2x_DSTDRY1', cam_out%dstdry1, pcols, lchnk) + call outfld('a2x_DSTWET2', cam_out%dstwet2, pcols, lchnk) + call outfld('a2x_DSTDRY2', cam_out%dstdry2, pcols, lchnk) + call outfld('a2x_DSTWET3', cam_out%dstwet3, pcols, lchnk) + call outfld('a2x_DSTDRY3', cam_out%dstdry3, pcols, lchnk) + call outfld('a2x_DSTWET4', cam_out%dstwet4, pcols, lchnk) + call outfld('a2x_DSTDRY4', cam_out%dstdry4, pcols, lchnk) + end if + + end subroutine diag_export + +!####################################################################### + + subroutine diag_physvar_ic (lchnk, pbuf, cam_out, cam_in) + ! + !--------------------------------------------- + ! + ! Purpose: record physics variables on IC file + ! + !--------------------------------------------- + ! + + ! + ! Arguments + ! + integer , intent(in) :: lchnk ! chunk identifier + type(physics_buffer_desc), pointer :: pbuf(:) + + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(inout) :: cam_in + ! + !---------------------------Local workspace----------------------------- + ! + integer :: itim_old ! indices + + real(r8), pointer, dimension(:,:) :: cwat_var + real(r8), pointer, dimension(:,:) :: conv_var_3d + real(r8), pointer, dimension(: ) :: conv_var_2d + real(r8), pointer :: tpert(:), pblh(:), qpert(:) + ! + !----------------------------------------------------------------------- + ! + if( write_inithist() .and. moist_physics ) then + + ! + ! Associate pointers with physics buffer fields + ! + itim_old = pbuf_old_tim_idx() + + if (qcwat_idx > 0) then + call pbuf_get_field(pbuf, qcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('QCWAT&IC ',cwat_var, pcols,lchnk) + end if + + if (tcwat_idx > 0) then + call pbuf_get_field(pbuf, tcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('TCWAT&IC ',cwat_var, pcols,lchnk) + end if + + if (lcwat_idx > 0) then + call pbuf_get_field(pbuf, lcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('LCWAT&IC ',cwat_var, pcols,lchnk) + end if + + if (cld_idx > 0) then + call pbuf_get_field(pbuf, cld_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('CLOUD&IC ',cwat_var, pcols,lchnk) + end if + + if (concld_idx > 0) then + call pbuf_get_field(pbuf, concld_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('CONCLD&IC ',cwat_var, pcols,lchnk) + end if + + if (cush_idx > 0) then + call pbuf_get_field(pbuf, cush_idx, conv_var_2d ,(/1,itim_old/), (/pcols,1/)) + call outfld('CUSH&IC ',conv_var_2d, pcols,lchnk) + + end if + + if (tke_idx > 0) then + call pbuf_get_field(pbuf, tke_idx, conv_var_3d) + call outfld('TKE&IC ',conv_var_3d, pcols,lchnk) + end if + + if (kvm_idx > 0) then + call pbuf_get_field(pbuf, kvm_idx, conv_var_3d) + call outfld('KVM&IC ',conv_var_3d, pcols,lchnk) + end if + + if (kvh_idx > 0) then + call pbuf_get_field(pbuf, kvh_idx, conv_var_3d) + call outfld('KVH&IC ',conv_var_3d, pcols,lchnk) + end if + + if (qpert_idx > 0) then + call pbuf_get_field(pbuf, qpert_idx, qpert) + call outfld('QPERT&IC ', qpert, pcols, lchnk) + end if + + if (pblh_idx > 0) then + call pbuf_get_field(pbuf, pblh_idx, pblh) + call outfld('PBLH&IC ', pblh, pcols, lchnk) + end if + + if (tpert_idx > 0) then + call pbuf_get_field(pbuf, tpert_idx, tpert) + call outfld('TPERT&IC ', tpert, pcols, lchnk) + end if + + end if + + end subroutine diag_physvar_ic + + +!####################################################################### + + subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + + !--------------------------------------------------------------- + ! + ! Purpose: Dump physics tendencies for temperature + ! + !--------------------------------------------------------------- + + use check_energy, only: check_energy_get_integrals + use physconst, only: cpair + + ! Arguments + + type(physics_state), intent(in) :: state + + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns in chunk + real(r8) :: ftem2(pcols) ! Temporary workspace for outfld variables + real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: heat_glob ! global energy integral (FV only) + real(r8) :: tedif_glob ! tht energy flux from fixer + ! CAM pointers to get variables from the physics buffer + real(r8), pointer, dimension(:,:) :: t_ttend + real(r8), pointer, dimension(:,:) :: t_utend + real(r8), pointer, dimension(:,:) :: t_vtend + integer :: itim_old,m + + !----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + ! Dump out post-physics state (FV only) + + call outfld('TAP', state%t, pcols, lchnk ) + call outfld('UAP', state%u, pcols, lchnk ) + call outfld('VAP', state%v, pcols, lchnk ) + + ! Total physics tendency for Temperature + ! (remove global fixer tendency from total for FV and SE dycores) + +!+tht + call check_energy_get_integrals(heat_glob_out=heat_glob,tedif_glob_out=tedif_glob) !+tedif + ftem2(:ncol) = tedif_glob/ztodt + call outfld('EBREAK', ftem2, pcols, lchnk) +!-tht + ftem2(:ncol) = heat_glob/cpair + call outfld('TFIX', ftem2, pcols, lchnk) + + ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair + call outfld('PTTEND',ftem3, pcols, lchnk ) + ftem3(:ncol,:pver) = tend%dudt(:ncol,:pver) + call outfld('UTEND_PHYSTOT',ftem3, pcols, lchnk ) + ftem3(:ncol,:pver) = tend%dvdt(:ncol,:pver) + call outfld('VTEND_PHYSTOT',ftem3, pcols, lchnk ) + + ! Total (physics+dynamics, everything!) tendency for Temperature + + !! get temperature, U, and V stored in physics buffer + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, t_ttend_idx, t_ttend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, t_utend_idx, t_utend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, t_vtend_idx, t_vtend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + !! calculate and outfld the total temperature, U, and V tendencies + ftem3(:ncol,:) = (state%t(:ncol,:) - t_ttend(:ncol,:))/ztodt + call outfld('TTEND_TOT', ftem3, pcols, lchnk) + ftem3(:ncol,:) = (state%u(:ncol,:) - t_utend(:ncol,:))/ztodt + call outfld('UTEND_TOT', ftem3, pcols, lchnk) + ftem3(:ncol,:) = (state%v(:ncol,:) - t_vtend(:ncol,:))/ztodt + call outfld('VTEND_TOT', ftem3, pcols, lchnk) + + !! update physics buffer with this time-step's temperature, U, and V + t_ttend(:ncol,:) = state%t(:ncol,:) + t_utend(:ncol,:) = state%u(:ncol,:) + t_vtend(:ncol,:) = state%v(:ncol,:) + + end subroutine diag_phys_tend_writeout_dry + +!####################################################################### + + subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & + qini, cldliqini, cldiceini) + + !--------------------------------------------------------------- + ! + ! Purpose: Dump physics tendencies for moisture + ! + !--------------------------------------------------------------- + + ! Arguments + + type(physics_state), intent(in) :: state + + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns in chunk + real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: rtdt + integer :: ixcldice, ixcldliq! constituent indices for cloud liquid and ice water. + + lchnk = state%lchnk + ncol = state%ncol + rtdt = 1._r8/ztodt + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + + if ( cnst_cam_outfld( 1) ) then + call outfld (apcnst( 1), state%q(1,1, 1), pcols, lchnk) + end if + if (ixcldliq > 0) then + if (cnst_cam_outfld(ixcldliq)) then + call outfld (apcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if ( cnst_cam_outfld(ixcldice) ) then + call outfld (apcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + end if + end if + + ! Total physics tendency for moisture and other tracers + + if ( cnst_cam_outfld( 1) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver, 1) - qini (:ncol,:pver) )*rtdt + call outfld (ptendnam( 1), ftem3, pcols, lchnk) + end if + if (ixcldliq > 0) then + if (cnst_cam_outfld(ixcldliq) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixcldliq) - cldliqini(:ncol,:pver) )*rtdt + call outfld (ptendnam(ixcldliq), ftem3, pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if ( cnst_cam_outfld(ixcldice) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixcldice) - cldiceini(:ncol,:pver) )*rtdt + call outfld (ptendnam(ixcldice), ftem3, pcols, lchnk) + end if + end if + + end subroutine diag_phys_tend_writeout_moist + +!####################################################################### + + subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & + qini, cldliqini, cldiceini) + + !--------------------------------------------------------------- + ! + ! Purpose: Dump physics tendencies for moisture and temperature + ! + !--------------------------------------------------------------- + + ! Arguments + + type(physics_state), intent(in) :: state + + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics + + !----------------------------------------------------------------------- + + call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + if (moist_physics) then + call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & + qini, cldliqini, cldiceini) + end if + + end subroutine diag_phys_tend_writeout + +!####################################################################### + + subroutine diag_state_b4_phys_write_dry (state) + ! + !--------------------------------------------------------------- + ! + ! Purpose: Dump dry state just prior to executing physics + ! + !--------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + ! + !---------------------------Local workspace----------------------------- + ! + integer :: lchnk ! chunk index + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + + call outfld('TBP', state%t, pcols, lchnk ) + call outfld('UBP', state%u, pcols, lchnk ) + call outfld('VBP', state%v, pcols, lchnk ) + + end subroutine diag_state_b4_phys_write_dry + + subroutine diag_state_b4_phys_write_moist (state) + ! + !--------------------------------------------------------------- + ! + ! Purpose: Dump moist state just prior to executing physics + ! + !--------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + ! + !---------------------------Local workspace----------------------------- + ! + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: lchnk ! chunk index + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + + if ( cnst_cam_outfld( 1) ) then + call outfld (bpcnst( 1), state%q(1,1, 1), pcols, lchnk) + end if + if (ixcldliq > 0) then + if (cnst_cam_outfld(ixcldliq)) then + call outfld (bpcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if (cnst_cam_outfld(ixcldice)) then + call outfld (bpcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + end if + end if + + end subroutine diag_state_b4_phys_write_moist + + subroutine diag_state_b4_phys_write (state) + ! + !--------------------------------------------------------------- + ! + ! Purpose: Dump state just prior to executing physics + ! + !--------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + ! + + call diag_state_b4_phys_write_dry(state) + if (moist_physics) then + call diag_state_b4_phys_write_moist(state) + end if + end subroutine diag_state_b4_phys_write + +end module cam_diagnostics diff --git a/src/physics/camnor_phys/physics/cam_thermo.F90 b/src/physics/camnor_phys/physics/cam_thermo.F90 new file mode 100644 index 0000000000..4fe5650d55 --- /dev/null +++ b/src/physics/camnor_phys/physics/cam_thermo.F90 @@ -0,0 +1,2435 @@ +! cam_thermo module provides interfaces to compute thermodynamic quantities +module cam_thermo + + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_abortutils, only: endrun + use air_composition, only: thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx + use air_composition, only: thermodynamic_active_species_idx_dycore + use air_composition, only: thermodynamic_active_species_cp + use air_composition, only: thermodynamic_active_species_R + use air_composition, only: thermodynamic_active_species_mwi + use air_composition, only: thermodynamic_active_species_kv + use air_composition, only: thermodynamic_active_species_kc + use air_composition, only: thermodynamic_active_species_liq_num + use air_composition, only: thermodynamic_active_species_ice_num + use air_composition, only: thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_liq_idx_dycore + use air_composition, only: thermodynamic_active_species_ice_idx + use air_composition, only: thermodynamic_active_species_ice_idx_dycore + use air_composition, only: dry_air_species_num + use air_composition, only: enthalpy_reference_state + use air_composition, only: mmro2, mmrn2, o2_mwi, n2_mwi, mbar + + !use air_composition, only: cpliq, t00a, h00a !+tht + + implicit none + private + save + + ! subroutines to compute thermodynamic quantities + ! + ! See Lauritzen et al. (2018) for formulae + ! DOI: 10.1029/2017MS001257 + ! https://opensky.ucar.edu/islandora/object/articles:21929 + + public :: get_conserved_energy, inv_conserved_energy !+tht + ! cam_thermo_init: Initialize constituent dependent properties + public :: cam_thermo_init + ! cam_thermo_dry_air_update: Update dry air composition dependent properties + public :: cam_thermo_dry_air_update + ! cam_thermo_water_update: Update water dependent properties + public :: cam_thermo_water_update +! public :: cam_thermo_water_update_conserve + ! get_enthalpy: enthalpy quantity = dp*cp*T + public :: get_enthalpy + ! get_virtual_temp: virtual temperature + public :: get_virtual_temp + ! get_sum_species: sum of thermodynamically active species: + ! Note: dp = dp_dry * sum_species + public :: get_sum_species + ! get_virtual_theta: virtual potential temperature + public :: get_virtual_theta + ! cam_thermo_calc_kappav: update species dependent kappa for FV dycore + public :: cam_thermo_calc_kappav + ! get_dp: pressure level thickness from dry dp and dry mixing ratios + public :: get_dp + ! get_pmid_from_dp: full level pressure from dp (approximation depends on dycore) + public :: get_pmid_from_dp + ! get_ps: surface pressure + public :: get_ps + ! get_gz: geopotential + public :: get_gz + ! get_Richardson_number: Richardson number at layer interfaces + public :: get_Richardson_number + ! get_kappa_dry: (generalized) dry kappa = R_dry/cp_dry + public :: get_kappa_dry + ! get_dp_ref: reference pressure layer thickness (include topography) + public :: get_dp_ref + ! get_molecular_diff_coef: molecular diffusion and thermal conductivity + public :: get_molecular_diff_coef + ! get_molecular_diff_coef_reference: reference vertical profile of density, + ! molecular diffusion and thermal conductivity + public :: get_molecular_diff_coef_reference + ! get_rho_dry: dry density from temperature (temp) and + ! pressure (dp_dry and tracer) + public :: get_rho_dry + ! get_exner: Exner pressure + public :: get_exner + ! get_hydrostatic_energy: Vertically integrated total energy + public :: get_hydrostatic_energy + + ! Public variables + ! mixing_ratio options + integer, public, parameter :: DRY_MIXING_RATIO = 1 + integer, public, parameter :: MASS_MIXING_RATIO = 2 + +!+tht + !public condtr + !real(r8), parameter :: condtr = 273.16_r8 +!-tht + + !--------------- Variables below here are for WACCM-X --------------------- + ! kmvis: molecular viscosity kg/m/s + real(r8), public, protected, allocatable :: kmvis(:,:,:) + ! kmcnd: molecular conductivity J/m/s/K + real(r8), public, protected, allocatable :: kmcnd(:,:,:) + + !------------- Variables for consistent themodynamics -------------------- + ! + + ! + ! Interfaces for public routines + interface get_gz + ! get_gz_geopotential (with dp_dry, ptop, temp, and phis as input) + module procedure get_gz_from_dp_dry_ptop_temp_1hd + ! get_gz_given_dp_Tv_Rdry: geopotential (with dp,dry R and Tv as input) + module procedure get_gz_given_dp_Tv_Rdry_1hd + module procedure get_gz_given_dp_Tv_Rdry_2hd + end interface get_gz + + interface get_enthalpy + module procedure get_enthalpy_1hd + module procedure get_enthalpy_2hd + end interface get_enthalpy + + interface get_virtual_temp + module procedure get_virtual_temp_1hd + module procedure get_virtual_temp_2hd + end interface get_virtual_temp + + interface get_sum_species + module procedure get_sum_species_1hd + module procedure get_sum_species_2hd + end interface get_sum_species + + interface get_dp + module procedure get_dp_1hd + module procedure get_dp_2hd + end interface get_dp + + interface get_pmid_from_dp + module procedure get_pmid_from_dpdry_1hd + module procedure get_pmid_from_dp_1hd + end interface get_pmid_from_dp + + interface get_exner + module procedure get_exner_1hd + end interface get_exner + + interface get_virtual_theta + module procedure get_virtual_theta_1hd + end interface get_virtual_theta + + interface get_Richardson_number + module procedure get_Richardson_number_1hd + end interface get_Richardson_number + + interface get_ps + module procedure get_ps_1hd + module procedure get_ps_2hd + end interface get_ps + + interface get_kappa_dry + module procedure get_kappa_dry_1hd + module procedure get_kappa_dry_2hd + end interface get_kappa_dry + + interface get_dp_ref + module procedure get_dp_ref_1hd + module procedure get_dp_ref_2hd + end interface get_dp_ref + + interface get_rho_dry + module procedure get_rho_dry_1hd + module procedure get_rho_dry_2hd + end interface get_rho_dry + + interface get_molecular_diff_coef + module procedure get_molecular_diff_coef_1hd + module procedure get_molecular_diff_coef_2hd + end interface get_molecular_diff_coef + + interface cam_thermo_calc_kappav + ! Since this routine is currently only used by the FV dycore, + ! a 1-d interface is not needed (but can easily be added) + module procedure cam_thermo_calc_kappav_2hd + end interface cam_thermo_calc_kappav + + interface get_hydrostatic_energy + module procedure get_hydrostatic_energy_1hd + ! This routine is currently only called from the physics so a + ! 2-d interface is not needed (but can easily be added) + end interface get_hydrostatic_energy + + integer, public, parameter :: thermo_budget_num_vars = 10 + integer, public, parameter :: wvidx = 1 + integer, public, parameter :: wlidx = 2 + integer, public, parameter :: wiidx = 3 + integer, public, parameter :: seidx = 4 ! enthalpy or internal energy (W/m2) index + integer, public, parameter :: poidx = 5 ! surface potential or potential energy index + integer, public, parameter :: keidx = 6 ! kinetic energy index + integer, public, parameter :: mridx = 7 + integer, public, parameter :: moidx = 8 + integer, public, parameter :: ttidx = 9 + integer, public, parameter :: teidx = 10 + character (len = 2) ,public, dimension(thermo_budget_num_vars) :: thermo_budget_vars = & + (/"WV" ,"WL" ,"WI" ,"SE" ,"PO" ,"KE" ,"MR" ,"MO" ,"TT" ,"TE" /) + character (len = 46) ,public, dimension(thermo_budget_num_vars) :: thermo_budget_vars_descriptor = (/& + "Total column water vapor ",& + "Total column liquid water ",& + "Total column frozen water ",& + "Total column enthalpy or internal energy ",& + "Total column srf potential or potential energy",& + "Total column kinetic energy ",& + "Total column wind axial angular momentum ",& + "Total column mass axial angular momentum ",& + "Total column test_tracer ",& + "Total column energy (ke + se + po) "/) + + character (len = 14), public, dimension(thermo_budget_num_vars) :: & + thermo_budget_vars_unit = (/& + "kg/m2 ","kg/m2 ","kg/m2 ","J/m2 ",& + "J/m2 ","J/m2 ","kg*m2/s*rad2 ","kg*m2/s*rad2 ",& + "kg/m2 ","J/m2 "/) + logical ,public, dimension(thermo_budget_num_vars) :: thermo_budget_vars_massv = (/& + .true.,.true.,.true.,.false.,.false.,.false.,.false.,.false.,.true.,.false./) +CONTAINS + + !=========================================================================== + + subroutine cam_thermo_init() + use shr_infnan_mod, only: assignment(=), shr_infnan_qnan + use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + + integer :: ierr + character(len=*), parameter :: subname = "cam_thermo_init" + character(len=*), parameter :: errstr = subname//": failed to allocate " + + !------------------------------------------------------------------------ + ! Allocate constituent dependent properties + !------------------------------------------------------------------------ + allocate(kmvis(pcols,pverp,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"kmvis") + end if + allocate(kmcnd(pcols,pverp,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"kmcnd") + end if + + !------------------------------------------------------------------------ + ! Initialize constituent dependent properties + !------------------------------------------------------------------------ + kmvis(:pcols, :pver, begchunk:endchunk) = shr_infnan_qnan + kmcnd(:pcols, :pver, begchunk:endchunk) = shr_infnan_qnan + + end subroutine cam_thermo_init + ! + !*************************************************************************** + ! + ! cam_thermo_dry_air_update: update dry air species dependent constants for physics + ! + !*************************************************************************** + ! + subroutine cam_thermo_dry_air_update(mmr, T, lchnk, ncol, to_dry_factor) + use air_composition, only: dry_air_composition_update + use string_utils, only: int2str + !------------------------------Arguments---------------------------------- + !(mmr = dry mixing ratio, if not use to_dry_factor to convert) + real(r8), intent(in) :: mmr(:,:,:) ! constituents array + real(r8), intent(in) :: T(:,:) ! temperature + integer, intent(in) :: lchnk ! Chunk number + integer, intent(in) :: ncol ! number of columns + real(r8), optional, intent(in) :: to_dry_factor(:,:)!if mmr moist convert + ! + !---------------------------Local storage------------------------------- + real(r8):: sponge_factor(SIZE(mmr, 2)) + character(len=*), parameter :: subname = 'cam_thermo_update: ' + + if (present(to_dry_factor)) then + if (SIZE(to_dry_factor, 1) /= ncol) then + call endrun(subname//'DIM 1 of to_dry_factor is'//int2str(SIZE(to_dry_factor,1))//'but should be'//int2str(ncol)) + end if + end if + + sponge_factor = 1.0_r8 + call dry_air_composition_update(mmr, lchnk, ncol, to_dry_factor=to_dry_factor) + call get_molecular_diff_coef(T(:ncol,:), .true., sponge_factor, kmvis(:ncol,:,lchnk), & + kmcnd(:ncol,:,lchnk), tracer=mmr(:ncol,:,:), fact=to_dry_factor, & + active_species_idx_dycore=thermodynamic_active_species_idx) + end subroutine cam_thermo_dry_air_update + ! + !*************************************************************************** + ! + ! cam_thermo_water+update: update water species dependent constants for physics + ! + !*************************************************************************** + ! + subroutine cam_thermo_water_update(mmr, lchnk, ncol, vcoord, to_dry_factor) + use air_composition, only: water_composition_update + !----------------------------------------------------------------------- + ! Update the physics "constants" that vary + !------------------------------------------------------------------------- + + !------------------------------Arguments---------------------------------- + + real(r8), intent(in) :: mmr(:,:,:) ! constituents array + integer, intent(in) :: lchnk ! Chunk number + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: vcoord + real(r8), optional, intent(in) :: to_dry_factor(:,:) + ! + logical :: lcp + + call water_composition_update(mmr, lchnk, ncol, vcoord, to_dry_factor=to_dry_factor) + + end subroutine cam_thermo_water_update + +! !=========================================================================== +! subroutine cam_thermo_water_update_conserve(state, lchnk, ncol, vcoord, to_dry_factor, init) +! use air_composition, only: water_composition_update +! !----------------------------------------------------------------------- +! ! Update the physics "constants" that vary +! !------------------------------------------------------------------------- +! use physics_types, only: physics_state ! leads to circular dependency +! +! !------------------------------Arguments---------------------------------- +! +! type(physics_state),intent(inout):: state +! integer, intent(in) :: lchnk ! Chunk number +! integer, intent(in) :: ncol ! number of columns +! integer, intent(in) :: vcoord +! real(r8), optional, intent(in) :: to_dry_factor(:,:) +! logical, optional, intent(in) :: init +! ! +! logical :: lcp +! +! call water_composition_update(state%q(:ncol,:,:), lchnk, ncol, vcoord, to_dry_factor=to_dry_factor, init=init) +! +!!add code to change T and Phi such that cp*T+Phi remains constant +!!(method: start from bottom, at each step first rescaling T=(state%s-Phi)/cp then integrating Phi) +! +! end subroutine cam_thermo_water_update_conserve +! + !=========================================================================== + + ! + !*********************************************************************** + ! + ! Compute enthalpy = cp*T*dp, where dp is pressure level thickness, + ! cp is generalized cp and T temperature + ! + ! Note: tracer is in units of m*dp_dry ("mass") + ! + !*********************************************************************** + ! + subroutine get_enthalpy_1hd(tracer_mass, temp, dp_dry, & + enthalpy, active_species_idx_dycore) + use air_composition, only: dry_air_species_num, get_cp_dry + ! Dummy arguments + ! tracer_mass: tracer array (mass weighted) + real(r8), intent(in) :: tracer_mass(:,:,:) + ! temp: temperature + real(r8), intent(in) :: temp(:,:) + ! dp_dry: dry presure level thickness + real(r8), intent(in) :: dp_dry(:,:) + ! enthalpy: enthalpy in each column: sum cp*T*dp + real(r8), intent(out) :: enthalpy(:,:) + ! + ! active_species_idx_dycore: + ! array of indicies for index of thermodynamic active species in + ! dycore tracer array (if different from physics index) + ! + integer, optional, intent(in) :: active_species_idx_dycore(:) + + ! Local vars + integer :: qdx, itrac + character(len=*), parameter :: subname = 'get_enthalpy: ' + + ! + ! "mass-weighted" cp (dp must be dry) + ! + if (dry_air_species_num == 0) then + enthalpy(:,:) = thermodynamic_active_species_cp(0) * & + dp_dry(:,:) + else + if (present(active_species_idx_dycore)) then + call get_cp_dry(tracer_mass, active_species_idx_dycore, & + enthalpy, fact=1.0_r8/dp_dry(:,:)) + else + call get_cp_dry(tracer_mass, thermodynamic_active_species_idx, & + enthalpy, fact=1.0_r8/dp_dry(:,:)) + end if + enthalpy(:,:) = enthalpy(:,:) * dp_dry(:,:) + end if + ! + ! tracer is in units of m*dp ("mass"), where: + ! m is the dry mixing ratio + ! dp is the dry pressure level thickness + ! + !enthalpy(:,:) = enthalpy(:,:) * temp(:,:) !+tht + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + if (present(active_species_idx_dycore)) then + itrac = active_species_idx_dycore(qdx) + else + itrac = thermodynamic_active_species_idx(qdx) + end if + enthalpy(:,:) = enthalpy(:,:) + & + (thermodynamic_active_species_cp(qdx) * tracer_mass(:,:,itrac)) + !+tht assuming "tracer" really means water! + !enthalpy(:,:) = enthalpy(:,:) + & + ! tracer_mass(:,:,itrac)*(thermodynamic_active_species_cp(qdx) *(temp(:,:)-t00a) + cpliq*t00a + h00a) + !-tht (actually, this causes havoc -- reverting all changes) + end do + enthalpy(:,:) = enthalpy(:,:) * temp(:,:) !tht c'd out + + end subroutine get_enthalpy_1hd + + !=========================================================================== + + subroutine get_enthalpy_2hd(tracer_mass, temp, dp_dry, & + enthalpy, active_species_idx_dycore) + ! Dummy arguments + ! tracer_mass: tracer array (mass weighted) + real(r8), intent(in) :: tracer_mass(:,:,:,:) + ! temp: temperature + real(r8), intent(in) :: temp(:,:,:) + ! dp_dry: dry presure level thickness + real(r8), intent(in) :: dp_dry(:,:,:) + ! enthalpy: enthalpy in each column: sum cp*T*dp + real(r8), intent(out) :: enthalpy(:,:,:) + ! + ! active_species_idx_dycore: + ! array of indicies for index of thermodynamic active species in + ! dycore tracer array (if different from physics index) + ! + integer, optional, intent(in) :: active_species_idx_dycore(:) + + ! Local variables + integer :: jdx + character(len=*), parameter :: subname = 'get_enthalpy_2hd: ' + + do jdx = 1, SIZE(tracer_mass, 2) + call get_enthalpy(tracer_mass(:, jdx, :, :), temp(:, jdx, :), & + dp_dry(:, jdx, :), enthalpy(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + end do + + end subroutine get_enthalpy_2hd + + !=========================================================================== + + !************************************************************************** + ! + ! get_virtual_temp: Compute virtual temperature T_v + ! + ! tracer is in units of dry mixing ratio unless optional argument + ! dp_dry is present in which case tracer is in units of "mass" (=m*dp) + ! + ! If temperature is not supplied then just return factor that T + ! needs to be multiplied by to get T_v + ! + !************************************************************************** + ! + subroutine get_virtual_temp_1hd(tracer, T_v, temp, dp_dry, sum_q, & + active_species_idx_dycore) + use cam_abortutils, only: endrun + use string_utils, only: int2str + use air_composition, only: dry_air_species_num, get_R_dry + + ! Dummy Arguments + ! tracer: tracer array + real(r8), intent(in) :: tracer(:, :, :) + ! T_v: virtual temperature + real(r8), intent(out) :: T_v(:, :) + ! temp: temperature + real(r8), optional, intent(in) :: temp(:, :) + ! dp_dry: dry pressure level thickness + real(r8), optional, intent(in) :: dp_dry(:, :) + ! sum_q: sum tracer + real(r8), optional, intent(out) :: sum_q(:, :) + ! + ! array of indicies for index of thermodynamic active species in + ! dycore tracer array (if different from physics index) + ! + integer, optional, intent(in) :: active_species_idx_dycore(:) + + ! Local Variables + integer :: itrac, qdx + real(r8) :: sum_species(SIZE(tracer, 1), SIZE(tracer, 2)) + real(r8) :: factor(SIZE(tracer, 1), SIZE(tracer, 2)) + real(r8) :: Rd(SIZE(tracer, 1), SIZE(tracer, 2)) + integer :: idx_local(thermodynamic_active_species_num) + character(len=*), parameter :: subname = 'get_virtual_temp_1hd: ' + + if (present(active_species_idx_dycore)) then + if (SIZE(active_species_idx_dycore) /= & + thermodynamic_active_species_num) then + call endrun(subname//"SIZE mismatch "// & + int2str(SIZE(active_species_idx_dycore))//' /= '// & + int2str(thermodynamic_active_species_num)) + end if + idx_local = active_species_idx_dycore + else + idx_local = thermodynamic_active_species_idx + end if + + call get_sum_species(tracer, idx_local, sum_species, dp_dry=dp_dry, factor=factor) + + call get_R_dry(tracer, idx_local, Rd, fact=factor) + t_v(:, :) = Rd(:, :) + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + itrac = idx_local(qdx) + t_v(:, :) = t_v(:, :) + (thermodynamic_active_species_R(qdx) * & + tracer(:, :, itrac) * factor(:, :)) + end do + if (present(temp)) then + t_v(:, :) = t_v(:, :) * temp(:, :) / (Rd(:, :) * sum_species) + else + t_v(:, :) = t_v(:, :) / (Rd(:, :) * sum_species) + end if + if (present(sum_q)) then + sum_q = sum_species + end if + + end subroutine get_virtual_temp_1hd + + !=========================================================================== + + subroutine get_virtual_temp_2hd(tracer, T_v, temp, dp_dry, sum_q, & + active_species_idx_dycore) + + ! Dummy Arguments + ! tracer: tracer array + real(r8), intent(in) :: tracer(:, :, :, :) + ! T_v: virtual temperature + real(r8), intent(out) :: T_v(:, :, :) + ! temp: temperature + real(r8), optional, intent(in) :: temp(:, :, :) + ! dp_dry: dry pressure level thickness + real(r8), optional, intent(in) :: dp_dry(:, :, :) + ! sum_q: sum tracer + real(r8), optional, intent(out) :: sum_q(:, :, :) + ! + ! array of indicies for index of thermodynamic active species in + ! dycore tracer array (if different from physics index) + ! + integer, optional, intent(in) :: active_species_idx_dycore(:) + + ! Local vars + integer :: jdx + character(len=*), parameter :: subname = 'get_virtual_temp_2hd: ' + + ! Rather than do a bunch of copying into temp variables, do the + ! combinatorics + do jdx = 1, SIZE(tracer, 2) + if (present(temp) .and. present(dp_dry) .and. present(sum_q)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + temp=temp(:, jdx, :), dp_dry=dp_dry(:, jdx, :), & + sum_q=sum_q(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(temp) .and. present(dp_dry)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + temp=temp(:, jdx, :), dp_dry=dp_dry(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(temp) .and. present(sum_q)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + temp=temp(:, jdx, :), sum_q=sum_q(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(dp_dry) .and. present(sum_q)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + dp_dry=dp_dry(:, jdx, :), sum_q=sum_q(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(temp)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + temp=temp(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(dp_dry)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + dp_dry=dp_dry(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(sum_q)) then + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + sum_q=sum_q(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else + call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + end if + end do + + end subroutine get_virtual_temp_2hd + + !=========================================================================== + + ! + !*************************************************************************** + ! + ! get_sum_species: + ! + ! Compute sum of thermodynamically active species + ! + ! tracer is in units of dry mixing ratio unless optional argument + ! dp_dry is present in which case tracer is in units of "mass" (=m*dp) + ! + !*************************************************************************** + ! + subroutine get_sum_species_1hd(tracer, active_species_idx, & + sum_species, dp_dry, factor) + use air_composition, only: dry_air_species_num + + ! Dummy arguments + ! tracer: Tracer array + real(r8), intent(in) :: tracer(:, :, :) + ! active_species_idx: Index for thermodynamic active tracers + integer, intent(in) :: active_species_idx(:) + ! dp_dry: Dry pressure level thickness. + ! If present, then tracer is in units of mass + real(r8), optional, intent(in) :: dp_dry(:, :) + ! sum_species: sum species + real(r8), intent(out) :: sum_species(:, :) + ! factor: to moist factor + real(r8), optional, intent(out) :: factor(:, :) + ! Local variables + real(r8) :: factor_loc(SIZE(tracer, 1), SIZE(tracer, 2)) + integer :: qdx, itrac + if (present(dp_dry)) then + factor_loc = 1.0_r8 / dp_dry(:,:) + else + factor_loc = 1.0_r8 + end if + sum_species = 1.0_r8 ! all dry air species sum to 1 + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + itrac = active_species_idx(qdx) + sum_species(:,:) = sum_species(:,:) + (tracer(:,:,itrac) * factor_loc(:,:)) + end do + if (present(factor)) then + factor = factor_loc + end if + end subroutine get_sum_species_1hd + + !=========================================================================== + + subroutine get_sum_species_2hd(tracer, active_species_idx, & + sum_species,dp_dry, factor) + + ! Dummy arguments + ! tracer: Tracer array + real(r8), intent(in) :: tracer(:, :, :, :) + ! active_species_idx: Index for thermodynamic active tracers + integer, intent(in) :: active_species_idx(:) + ! dp_dry: Dry pressure level thickness. + ! If present, then tracer is in units of mass + real(r8), optional, intent(in) :: dp_dry(:, :, :) + ! sum_species: sum species + real(r8), intent(out) :: sum_species(:, :, :) + ! factor: to moist factor + real(r8), optional, intent(out) :: factor(:, :, :) + ! Local variable + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(dp_dry) .and. present(factor)) then + call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & + sum_species(:, jdx, :), dp_dry=dp_dry(:, jdx, :), factor=factor(:, jdx, :)) + else if (present(dp_dry)) then + call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & + sum_species(:, jdx, :), dp_dry=dp_dry(:, jdx, :)) + else if (present(factor)) then + call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & + sum_species(:, jdx, :), factor=factor(:, jdx, :)) + else + call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & + sum_species(:, jdx, :)) + end if + end do + + end subroutine get_sum_species_2hd + + !=========================================================================== + + !*************************************************************************** + ! + ! get_dp: Compute pressure level thickness from dry pressure and + ! thermodynamic active species mixing ratios + ! + ! Tracer can either be in units of dry mixing ratio (mixing_ratio=1) or + ! "mass" (=m*dp_dry) (mixing_ratio=2) + ! + !*************************************************************************** + ! + subroutine get_dp_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, dp, ps, ptop) + use air_composition, only: dry_air_species_num + use string_utils, only: int2str + + real(r8), intent(in) :: tracer(:, :, :) ! tracers; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:, :) ! dry pressure level thickness + real(r8), intent(out) :: dp(:, :) ! pressure level thickness + real(r8), optional,intent(out) :: ps(:) ! surface pressure (if ps present then ptop + ! must be present) + real(r8), optional,intent(in) :: ptop ! pressure at model top + + integer :: idx, kdx, m_cnst, qdx + + character(len=*), parameter :: subname = 'get_dp_1hd: ' + + dp = dp_dry + if (mixing_ratio == DRY_MIXING_RATIO) then + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + m_cnst = active_species_idx(qdx) + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + dp(idx, kdx) = dp(idx, kdx) + dp_dry(idx, kdx)*tracer(idx, kdx, m_cnst) + end do + end do + end do + else if (mixing_ratio == MASS_MIXING_RATIO) then + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + m_cnst = active_species_idx(qdx) + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + dp(idx, kdx) = dp(idx, kdx) + tracer(idx, kdx, m_cnst) + end do + end do + end do + else + call endrun(subname//'unrecognized input ('//int2str(mixing_ratio)//') for mixing_ratio') + end if + if (present(ps)) then + if (present(ptop)) then + ps = ptop + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + ps(idx) = ps(idx) + dp(idx, kdx) + end do + end do + else + call endrun(subname//'if ps is present ptop must be present') + end if + end if + end subroutine get_dp_1hd + + subroutine get_dp_2hd(tracer, mixing_ratio, active_species_idx, dp_dry, dp, ps, ptop) + ! Version of get_dp for arrays that have a second horizontal index + real(r8), intent(in) :: tracer(:,:,:,:) ! tracers; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:,:,:) ! dry pressure level thickness + real(r8), intent(out) :: dp(:,:,:) ! pressure level thickness + real(r8), optional,intent(out) :: ps(:,:) ! surface pressure + real(r8), optional,intent(in) :: ptop ! pressure at model top + + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(ps)) then + call get_dp(tracer(:, jdx, :, :), mixing_ratio, active_species_idx, & + dp_dry(:, jdx, :), dp(:, jdx, :), ps=ps(:,jdx), ptop=ptop) + else + call get_dp(tracer(:, jdx, :, :), mixing_ratio, active_species_idx, & + dp_dry(:, jdx, :), dp(:, jdx, :), ptop=ptop) + end if + end do + + end subroutine get_dp_2hd + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute mid-level (full level) pressure from dry pressure and water tracers + ! + !************************************************************************************************************************* + ! + subroutine get_pmid_from_dpdry_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, pmid, pint, dp) + + real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness + real(r8), intent(in) :: ptop ! model top pressure + real(r8), intent(out) :: pmid(:,:) ! mid-level pressure + real(r8), optional, intent(out) :: pint(:,:) ! half-level pressure + real(r8), optional, intent(out) :: dp(:,:) ! presure level thickness + + real(r8) :: dp_local(SIZE(tracer, 1), SIZE(tracer, 2)) ! local pressure level thickness + real(r8) :: pint_local(SIZE(tracer, 1), SIZE(tracer, 2) + 1)! local interface pressure + + call get_dp(tracer, mixing_ratio, active_species_idx, dp_dry, dp_local) + + call get_pmid_from_dp(dp_local, ptop, pmid, pint_local) + + if (present(pint)) pint=pint_local + if (present(dp)) dp=dp_local + end subroutine get_pmid_from_dpdry_1hd + + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute mid-level (full level) pressure + ! + !************************************************************************************************************************* + ! + subroutine get_pmid_from_dp_1hd(dp, ptop, pmid, pint) + use dycore, only: dycore_is + real(r8), intent(in) :: dp(:,:) ! pressure level thickness + real(r8), intent(in) :: ptop ! pressure at model top + real(r8), intent(out) :: pmid(:,:) ! mid (full) level pressure + real(r8), optional, intent(out) :: pint(:,:) ! pressure at interfaces (half levels) + + real(r8) :: pint_local(SIZE(dp, 1), SIZE(dp,2) + 1) + integer :: kdx + + pint_local(:, 1) = ptop + do kdx = 2, SIZE(dp, 2) + 1 + pint_local(:, kdx) = dp(:, kdx - 1) + pint_local(:, kdx - 1) + end do + + if (dycore_is('LR') .or. dycore_is('FV3')) then + do kdx = 1, SIZE(dp, 2) + pmid(:, kdx) = dp(:, kdx) / (log(pint_local(:, kdx + 1)) - log(pint_local(:, kdx))) + end do + else + do kdx = 1, SIZE(dp, 2) + pmid(:, kdx) = 0.5_r8 * (pint_local(:, kdx) + pint_local(:, kdx + 1)) + end do + end if + if (present(pint)) pint=pint_local + end subroutine get_pmid_from_dp_1hd + + !=========================================================================== + + !**************************************************************************************************************** + ! + ! Compute Exner pressure + ! + !**************************************************************************************************************** + ! + subroutine get_exner_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, inv_exner, exner, poverp0) + use string_utils, only: int2str + real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness + real(r8), intent(in) :: ptop ! pressure at model top + real(r8), intent(in) :: p00 ! reference pressure for Exner pressure (usually 1000hPa) + logical , intent(in) :: inv_exner ! logical for outputting inverse Exner or Exner pressure + real(r8), intent(out) :: exner(:,:) + real(r8), optional, intent(out) :: poverp0(:,:) ! for efficiency when a routine needs this variable + + real(r8) :: pmid(SIZE(tracer, 1), SIZE(tracer, 2)) + real(r8) :: kappa_dry(SIZE(tracer, 1), SIZE(tracer, 2)) + character(len=*), parameter :: subname = 'get_exner_1hd: ' + ! + ! compute mid level pressure + ! + call get_pmid_from_dp(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, pmid) + ! + ! compute kappa = Rd / cpd + ! + if (mixing_ratio == DRY_MIXING_RATIO) then + call get_kappa_dry(tracer, active_species_idx, kappa_dry) + else if (mixing_ratio == MASS_MIXING_RATIO) then + call get_kappa_dry(tracer, active_species_idx, kappa_dry, 1.0_r8 / dp_dry) + else + call endrun(subname//'unrecognized input ('//int2str(mixing_ratio)//') for mixing_ratio') + end if + if (inv_exner) then + exner(:,:) = (p00 / pmid(:,:)) ** kappa_dry(:,:) + else + exner(:,:) = (pmid(:,:) / p00) ** kappa_dry(:,:) + end if + if (present(poverp0)) poverp0 = pmid(:,:) / p00 + end subroutine get_exner_1hd + + !=========================================================================== + + !**************************************************************************************************************** + ! + ! Compute virtual potential temperature from dp_dry, m, T and ptop. + ! + !**************************************************************************************************************** + ! + subroutine get_virtual_theta_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, temp, theta_v) + real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness + real(r8), intent(in) :: ptop ! pressure at model top + real(r8), intent(in) :: p00 ! reference pressure for Exner pressure (usually 1000hPa) + real(r8), intent(in) :: temp(:,:) ! temperature + real(r8), intent(out) :: theta_v(:,:) ! virtual potential temperature + + real(r8) :: iexner(SIZE(tracer, 1), SIZE(tracer, 2)) + + call get_exner(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, .true., iexner) + + theta_v(:,:) = temp(:,:) * iexner(:,:) + + end subroutine get_virtual_theta_1hd + + !=========================================================================== + + !**************************************************************************************************************** + ! + ! Compute geopotential from dry pressure level thichkness, water tracers, model top pressure and temperature + ! + !**************************************************************************************************************** + ! + subroutine get_gz_from_dp_dry_ptop_temp_1hd(tracer, mixing_ratio, active_species_idx, & + dp_dry, ptop, temp, phis, gz, pmid, dp, T_v) + use air_composition, only: get_R_dry + use string_utils, only: int2str + real(r8), intent(in) :: tracer(:,:,:) ! tracer; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness + real(r8), intent(in) :: ptop ! pressure at model top + real(r8), intent(in) :: temp(:,:) ! temperature + real(r8), intent(in) :: phis(:) ! surface geopotential + real(r8), intent(out) :: gz(:,:) ! geopotential + real(r8), optional, intent(out) :: pmid(:,:) ! mid-level pressure + real(r8), optional, intent(out) :: dp(:,:) ! pressure level thickness + real(r8), optional, intent(out) :: t_v(:,:) ! virtual temperature + + + real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: pmid_local, t_v_local, dp_local, R_dry + real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2) + 1) :: pint + character(len=*), parameter :: subname = 'get_gz_from_dp_dry_ptop_temp_1hd: ' + + + call get_pmid_from_dp(tracer, mixing_ratio, active_species_idx, & + dp_dry, ptop, pmid_local, pint=pint, dp=dp_local) + if (mixing_ratio == DRY_MIXING_RATIO) then + call get_virtual_temp(tracer, t_v_local, temp=temp, active_species_idx_dycore=active_species_idx) + call get_R_dry(tracer, active_species_idx, R_dry) + else if (mixing_ratio == MASS_MIXING_RATIO) then + call get_virtual_temp(tracer, t_v_local, temp=temp, dp_dry=dp_dry, active_species_idx_dycore=active_species_idx) + call get_R_dry(tracer,active_species_idx, R_dry, fact=1.0_r8 / dp_dry) + else + call endrun(subname//'unrecognized input ('//int2str(mixing_ratio)//') for mixing_ratio') + end if + call get_gz(dp_local, T_v_local, R_dry, phis, ptop, gz, pmid_local) + + if (present(pmid)) pmid=pmid_local + if (present(T_v)) T_v=T_v_local + if (present(dp)) dp=dp_local + end subroutine get_gz_from_dp_dry_ptop_temp_1hd + + !=========================================================================== + + !*************************************************************************** + ! + ! Compute geopotential from pressure level thickness and virtual temperature + ! + !*************************************************************************** + ! + subroutine get_gz_given_dp_Tv_Rdry_1hd(dp, T_v, R_dry, phis, ptop, gz, pmid) + use dycore, only: dycore_is + real(r8), intent(in) :: dp (:,:) ! pressure level thickness + real(r8), intent(in) :: T_v (:,:) ! virtual temperature + real(r8), intent(in) :: R_dry(:,:) ! R dry + real(r8), intent(in) :: phis (:) ! surface geopotential + real(r8), intent(in) :: ptop ! model top presure + real(r8), intent(out) :: gz(:,:) ! geopotential + real(r8), optional, intent(out) :: pmid(:,:) ! mid-level pressure + + + real(r8), dimension(SIZE(dp, 1), SIZE(dp, 2)) :: pmid_local + real(r8), dimension(SIZE(dp, 1), SIZE(dp, 2) + 1) :: pint + real(r8), dimension(SIZE(dp, 1)) :: gzh, Rdry_tv + integer :: kdx + + call get_pmid_from_dp(dp, ptop, pmid_local, pint) + + ! + ! integrate hydrostatic eqn + ! + gzh = phis + if (dycore_is('LR') .or. dycore_is('FV3')) then + do kdx = SIZE(dp, 2), 1, -1 + Rdry_tv(:) = R_dry(:, kdx) * T_v(:, kdx) + gz(:, kdx) = gzh(:) + Rdry_tv(:) * (1.0_r8 - pint(:, kdx) / pmid_local(:, kdx)) + gzh(:) = gzh(:) + Rdry_tv(:) * (log(pint(:, kdx + 1)) - log(pint(:, kdx))) + end do + else + do kdx = SIZE(dp,2), 1, -1 + Rdry_tv(:) = R_dry(:,kdx) * T_v(:, kdx) + gz(:,kdx) = gzh(:) + Rdry_tv(:) * 0.5_r8 * dp(:, kdx) / pmid_local(:, kdx) + gzh(:) = gzh(:) + Rdry_tv(:) * dp(:, kdx) / pmid_local(:, kdx) + end do + end if + if (present(pmid)) pmid=pmid_local + end subroutine get_gz_given_dp_Tv_Rdry_1hd + + subroutine get_gz_given_dp_Tv_Rdry_2hd(dp, T_v, R_dry, phis, ptop, gz, pmid) + ! Version of get_gz_given_dp_Tv_Rdry for arrays that have a second horizontal index + real(r8), intent(in) :: dp (:,:,:) ! pressure level thickness + real(r8), intent(in) :: T_v (:,:,:) ! virtual temperature + real(r8), intent(in) :: R_dry(:,:,:) ! R dry + real(r8), intent(in) :: phis (:,:) ! surface geopotential + real(r8), intent(in) :: ptop ! model top presure + real(r8), intent(out) :: gz(:,:,:) ! geopotential + real(r8), optional, intent(out) :: pmid(:,:,:) ! mid-level pressure + + integer :: jdx + + do jdx = 1, SIZE(dp, 2) + if (present(pmid)) then + call get_gz(dp(:, jdx, :), T_v(:, jdx, :), R_dry(:, jdx, :), phis(:, jdx), & + ptop, gz(:, jdx, :), pmid=pmid(:, jdx, :)) + else + call get_gz(dp(:, jdx, :), T_v(:, jdx, :), R_dry(:, jdx, :), phis(:, jdx), ptop, gz(:, jdx, :)) + end if + end do + + + end subroutine get_gz_given_dp_Tv_Rdry_2hd + + !=========================================================================== + + !*************************************************************************** + ! + ! Compute Richardson number at cell interfaces (half levels) + ! + !*************************************************************************** + ! + subroutine get_Richardson_number_1hd(tracer,mixing_ratio, active_species_idx, dp_dry, ptop, & + p00, temp, v, Richardson_number, pmid, dp) + real(r8), intent(in) :: tracer(:,:,:) ! tracer; quantity specified by mixing_ratio arg + integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio + ! 2 => tracer is mass (q*dp) + integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array + real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness + real(r8), intent(in) :: ptop ! pressure at model top + real(r8), intent(in) :: p00 ! reference pressure for Exner pressure (usually 1000hPa) + real(r8), intent(in) :: temp(:,:) ! temperature + real(r8), intent(in) :: v(:,:,:) ! velocity components + real(r8), intent(out) :: Richardson_number(:,:) + real(r8), optional, intent(out) :: pmid(:,:) + real(r8), optional, intent(out) :: dp(:,:) + + real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: gz, theta_v + real(r8), dimension(SIZE(tracer, 1)) :: pt1, pt2, phis + integer :: kdx, kdxm1 + real(r8), parameter:: ustar2 = 1.E-4_r8 + + phis = 0.0_r8 + call get_gz(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, temp, phis, gz, pmid=pmid, dp=dp) + call get_virtual_theta(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, temp, theta_v) + Richardson_number(:, 1) = 0.0_r8 + Richardson_number(:, SIZE(tracer, 2) + 1) = 0.0_r8 + do kdx = SIZE(tracer, 2), 2, -1 + kdxm1 = kdx - 1 + pt1(:) = theta_v(:, kdxm1) + pt2(:) = theta_v(:, kdx) + Richardson_number(:, kdx) = (gz(:, kdxm1) - gz(:, kdx)) * (pt1 - pt2) / ( 0.5_r8*(pt1 + pt2) * & + ((v(:, 1, kdxm1) - v(:, 1, kdx)) ** 2 + (v(:, 2, kdxm1) - v(:, 2, kdx)) ** 2 + ustar2) ) + end do + end subroutine get_Richardson_number_1hd + + ! + !**************************************************************************************************************** + ! + ! get surface pressure from dry pressure and thermodynamic active species (e.g., forms of water: water vapor, cldliq, etc.) + ! + !**************************************************************************************************************** + ! + subroutine get_ps_1hd(tracer_mass, active_species_idx, dp_dry, ps, ptop) + use air_composition, only: dry_air_species_num + + real(r8), intent(in) :: tracer_mass(:,:,:) ! Tracer array (q*dp) + real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness + real(r8), intent(out) :: ps(:) ! surface pressure + real(r8), intent(in) :: ptop + integer, intent(in) :: active_species_idx(:) + + integer :: idx, kdx, m_cnst, qdx + real(r8) :: dp(SIZE(tracer_mass, 1), SIZE(tracer_mass, 2)) ! dry pressure level thickness + + dp = dp_dry + do qdx = dry_air_species_num + 1, thermodynamic_active_species_num + m_cnst = active_species_idx(qdx) + do kdx = 1, SIZE(tracer_mass, 2) + do idx = 1, SIZE(tracer_mass, 1) + dp(idx, kdx) = dp(idx, kdx) + tracer_mass(idx, kdx, m_cnst) + end do + end do + end do + ps = ptop + do kdx = 1, SIZE(tracer_mass, 2) + do idx = 1, SIZE(tracer_mass, 1) + ps(idx) = ps(idx) + dp(idx, kdx) + end do + end do + end subroutine get_ps_1hd + + subroutine get_ps_2hd(tracer_mass, active_species_idx, dp_dry, ps, ptop) + ! Version of get_ps for arrays that have a second horizontal index + real(r8), intent(in) :: tracer_mass(:,:,:,:) ! Tracer array (q*dp) + real(r8), intent(in) :: dp_dry(:,:,:) ! dry pressure level thickness + real(r8), intent(out) :: ps(:,:) ! surface pressure + real(r8), intent(in) :: ptop + integer, intent(in) :: active_species_idx(:) + + integer :: jdx + + do jdx = 1, SIZE(tracer_mass, 2) + call get_ps(tracer_mass(:, jdx, :, :), active_species_idx, dp_dry(:, jdx, :), ps(:, jdx), ptop) + end do + + end subroutine get_ps_2hd + + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute generalized kappa =Rdry/cpdry + ! + !************************************************************************************************************************* + ! + subroutine get_kappa_dry_1hd(tracer, active_species_idx, kappa_dry, fact) + use air_composition, only: dry_air_species_num, get_R_dry, get_cp_dry + use physconst, only: rair, cpair + + real(r8), intent(in) :: tracer(:,:,:) !tracer array + integer, intent(in) :: active_species_idx(:) !index of thermodynamic active tracers + real(r8), intent(out) :: kappa_dry(:,:) !kappa dry + real(r8), optional, intent(in) :: fact(:,:) !factor for converting tracer to dry mixing ratio + ! + real(r8), allocatable, dimension(:,:) :: cp_dry,R_dry + integer :: ierr + character(len=*), parameter :: subname = "get_kappa_dry_1hd" + character(len=*), parameter :: errstr = subname//": failed to allocate " + ! + ! dry air not species dependent + if (dry_air_species_num==0) then + kappa_dry = rair / cpair + else + allocate(R_dry(SIZE(kappa_dry, 1), SIZE(kappa_dry, 2)), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"R_dry") + end if + allocate(cp_dry(SIZE(kappa_dry, 1), SIZE(kappa_dry, 2)), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"cp_dry") + end if + call get_cp_dry(tracer, active_species_idx, cp_dry, fact=fact) + call get_R_dry( tracer, active_species_idx, R_dry, fact=fact) + kappa_dry = R_dry / cp_dry + deallocate(R_dry, cp_dry) + end if + end subroutine get_kappa_dry_1hd + + subroutine get_kappa_dry_2hd(tracer, active_species_idx, kappa_dry, fact) + ! Version of get_kappa_dry for arrays that have a second horizontal index + real(r8), intent(in) :: tracer(:,:,:,:) !tracer array + integer, intent(in) :: active_species_idx(:) !index of thermodynamic active tracers + real(r8), intent(out) :: kappa_dry(:,:,:) !kappa dry + real(r8), optional, intent(in) :: fact(:,:,:) !factor for converting tracer to dry mixing ratio + + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(fact)) then + call get_kappa_dry(tracer(:, jdx, :, :), active_species_idx, kappa_dry(:, jdx, :), fact=fact(:, jdx, :)) + else + call get_kappa_dry(tracer(:, jdx, :, :), active_species_idx, kappa_dry(:, jdx, :)) + end if + end do + + end subroutine get_kappa_dry_2hd + + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute reference pressure levels + ! + !************************************************************************************************************************* + ! + subroutine get_dp_ref_1hd(hyai, hybi, ps0, phis, dp_ref, ps_ref) + use physconst, only: tref, rair + real(r8), intent(in) :: hyai(:) + real(r8), intent(in) :: hybi(:) + real(r8), intent(in) :: ps0 + real(r8), intent(in) :: phis(:) + real(r8), intent(out) :: dp_ref(:,:) + real(r8), intent(out) :: ps_ref(:) + integer :: kdx + ! + ! use static reference pressure (hydrostatic balance incl. effect of topography) + ! + ps_ref(:) = ps0 * exp(-phis(:) / (rair * tref)) + do kdx = 1, SIZE(dp_ref, 2) + dp_ref(:,kdx) = ((hyai(kdx + 1) - hyai(kdx)) * ps0 + (hybi(kdx + 1) - hybi(kdx)) * ps_ref(:)) + end do + end subroutine get_dp_ref_1hd + + subroutine get_dp_ref_2hd(hyai, hybi, ps0, phis, dp_ref, ps_ref) + ! Version of get_dp_ref for arrays that have a second horizontal index + real(r8), intent(in) :: hyai(:) + real(r8), intent(in) :: hybi(:) + real(r8), intent(in) :: ps0 + real(r8), intent(in) :: phis(:,:) + real(r8), intent(out) :: dp_ref(:,:,:) + real(r8), intent(out) :: ps_ref(:,:) + integer :: jdx + + do jdx = 1, SIZE(dp_ref, 2) + call get_dp_ref(hyai, hybi, ps0, phis(:, jdx), dp_ref(:, jdx, :), ps_ref(:, jdx)) + end do + + end subroutine get_dp_ref_2hd + + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute dry densisty from temperature (temp) and pressure (dp_dry and tracer) + ! + !************************************************************************************************************************* + ! + subroutine get_rho_dry_1hd(tracer, temp, ptop, dp_dry, tracer_mass, rho_dry, rhoi_dry, & + active_species_idx_dycore) + use air_composition, only: get_R_dry + ! args + real(r8), intent(in) :: tracer(:,:,:) ! Tracer array + real(r8), intent(in) :: temp(:,:) ! Temperature + real(r8), intent(in) :: ptop + real(r8), intent(in) :: dp_dry(:,:) + logical, intent(in) :: tracer_mass + real(r8), optional,intent(out) :: rho_dry(:,:) + real(r8), optional,intent(out) :: rhoi_dry(:,:) + ! + ! array of indicies for index of thermodynamic active species in dycore tracer array + ! (if different from physics index) + ! + integer, optional, intent(in) :: active_species_idx_dycore(:) + + ! local vars + integer :: idx, kdx + real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: pmid + real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2) + 1) :: pint + real(r8), allocatable :: R_dry(:,:) + integer, dimension(thermodynamic_active_species_num) :: idx_local + integer :: ierr + character(len=*), parameter :: subname = "get_rho_dry_1hd" + character(len=*), parameter :: errstr = subname//": failed to allocate " + + if (present(active_species_idx_dycore)) then + idx_local = active_species_idx_dycore + else + idx_local = thermodynamic_active_species_idx + end if + ! + ! we assume that air is dry where molecular viscosity may be significant + ! + call get_pmid_from_dp(dp_dry, ptop, pmid, pint=pint) + if (present(rhoi_dry)) then + allocate(R_dry(SIZE(tracer, 1), SIZE(tracer, 2) + 1), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"R_dry") + end if + if (tracer_mass) then + call get_R_dry(tracer, idx_local, R_dry, fact=1.0_r8 / dp_dry) + else + call get_R_dry(tracer, idx_local, R_dry) + end if + do kdx = 2, SIZE(tracer, 2) + 1 + rhoi_dry(:, kdx) = 0.5_r8 * (temp(:, kdx) + temp(:, kdx - 1))!could be more accurate! + rhoi_dry(:, kdx) = pint(:,kdx) / (rhoi_dry(:, kdx) * R_dry(:, kdx)) !ideal gas law for dry air + end do + ! + ! extrapolate top level value + ! + kdx=1 + rhoi_dry(:, kdx) = 1.5_r8 * (temp(:, kdx) - 0.5_r8 * temp(:, kdx + 1)) + rhoi_dry(:, kdx) = pint(:, kdx) / (rhoi_dry(:, kdx) * R_dry(:, kdx)) !ideal gas law for dry air + deallocate(R_dry) + end if + if (present(rho_dry)) then + allocate(R_dry(SIZE(tracer, 1), size(rho_dry, 2)), stat=ierr) + if (ierr /= 0) then + call endrun(errstr//"R_dry") + end if + if (tracer_mass) then + call get_R_dry(tracer, idx_local, R_dry, fact=1.0_r8 / dp_dry) + else + call get_R_dry(tracer, idx_local, R_dry) + end if + do kdx = 1, SIZE(rho_dry, 2) + do idx = 1, SIZE(rho_dry, 1) + rho_dry(idx, kdx) = pmid(idx, kdx) / (temp(idx, kdx) * R_dry(idx, kdx)) !ideal gas law for dry air + end do + end do + deallocate(R_dry) + end if + end subroutine get_rho_dry_1hd + + subroutine get_rho_dry_2hd(tracer, temp, ptop, dp_dry, tracer_mass, rho_dry, rhoi_dry, & + active_species_idx_dycore) + ! Version of get_rho_dry for arrays that have a second horizontal index + real(r8), intent(in) :: tracer(:,:,:,:) ! Tracer array + real(r8), intent(in) :: temp(:,:,:) ! Temperature + real(r8), intent(in) :: ptop + real(r8), intent(in) :: dp_dry(:,:,:) + logical, intent(in) :: tracer_mass + real(r8), optional,intent(out) :: rho_dry(:,:,:) + real(r8), optional,intent(out) :: rhoi_dry(:,:,:) + ! + ! array of indicies for index of thermodynamic active species in dycore tracer array + ! (if different from physics index) + ! + integer, optional, intent(in) :: active_species_idx_dycore(:) + + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(rho_dry) .and. present(rhoi_dry)) then + call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), & + tracer_mass, rho_dry=rho_dry(:, jdx, :), rhoi_dry=rhoi_dry(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(rho_dry)) then + call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), & + tracer_mass, rho_dry=rho_dry(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore) + else if (present(rhoi_dry)) then + call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), & + tracer_mass, rhoi_dry=rhoi_dry(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore) + else + call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), tracer_mass, & + active_species_idx_dycore=active_species_idx_dycore) + end if + end do + + end subroutine get_rho_dry_2hd + !=========================================================================== + + !************************************************************************************************************************* + ! + ! compute 3D molecular diffusion and thermal conductivity + ! + !************************************************************************************************************************* + ! + subroutine get_molecular_diff_coef_1hd(temp, get_at_interfaces, sponge_factor, kmvis, kmcnd, & + tracer, fact, active_species_idx_dycore, mbarv_in) + use air_composition, only: dry_air_species_num, get_mbarv + use air_composition, only: kv1, kc1, kv2, kc2, kv_temp_exp, kc_temp_exp + + ! args + real(r8), intent(in) :: temp(:,:) ! temperature + logical, intent(in) :: get_at_interfaces ! true: compute kmvis and kmcnd at interfaces + ! false: compute kmvis and kmcnd at mid-levels + real(r8), intent(in) :: sponge_factor(:) ! multiply kmvis and kmcnd with sponge_factor + ! (for sponge layer) + real(r8), intent(out) :: kmvis(:,:) + real(r8), intent(out) :: kmcnd(:,:) + real(r8), intent(in) :: tracer(:,:,:) ! tracer array + integer, intent(in), optional :: active_species_idx_dycore(:) ! index of active species in tracer + real(r8), intent(in), optional :: fact(:,:) ! if tracer is in units of mass or moist + ! fact converts to dry mixing ratio: tracer/fact + real(r8), intent(in), optional :: mbarv_in(:,:) ! composition dependent atmosphere mean mass + ! + ! local vars + ! + integer :: idx, kdx, icnst, ispecies + real(r8):: mbarvi, mm, residual ! Mean mass at mid level + real(r8):: cnst_vis, cnst_cnd, temp_local + real(r8), dimension(SIZE(tracer,1), SIZE(sponge_factor, 1)) :: factor, mbarv + integer, dimension(thermodynamic_active_species_num) :: idx_local + character(len=*), parameter :: subname = 'get_molecular_diff_coef_1hd: ' + + !-------------------------------------------- + ! Set constants needed for updates + !-------------------------------------------- + + if (dry_air_species_num==0) then + + cnst_vis = (kv1 * mmro2 * o2_mwi + kv2 * mmrn2 * n2_mwi) * mbar + cnst_cnd = (kc1 * mmro2 * o2_mwi + kc2 * mmrn2 * n2_mwi) * mbar + if (get_at_interfaces) then + do kdx = 2, SIZE(sponge_factor, 1) + do idx = 1, SIZE(tracer, 1) + temp_local = 0.5_r8 * (temp(idx, kdx) + temp(idx, kdx - 1)) + kmvis(idx, kdx) = sponge_factor(kdx) * cnst_vis * temp_local ** kv_temp_exp + kmcnd(idx, kdx) = sponge_factor(kdx) * cnst_cnd * temp_local ** kc_temp_exp + end do + end do + ! + ! extrapolate top level value + ! + kmvis(1:SIZE(tracer, 1), 1) = 1.5_r8 * kmvis(1:SIZE(tracer, 1), 2) - 0.5_r8 * kmvis(1:SIZE(tracer, 1), 3) + kmcnd(1:SIZE(tracer, 1), 1) = 1.5_r8 * kmcnd(1:SIZE(tracer, 1), 2) - 0.5_r8 * kmcnd(1:SIZE(tracer, 1), 3) + else if (.not. get_at_interfaces) then + do kdx = 1, SIZE(sponge_factor, 1) + do idx = 1, SIZE(tracer, 1) + kmvis(idx, kdx) = sponge_factor(kdx) * cnst_vis * temp(idx, kdx) ** kv_temp_exp + kmcnd(idx, kdx) = sponge_factor(kdx) * cnst_cnd * temp(idx, kdx) ** kc_temp_exp + end do + end do + else + call endrun(subname//'get_at_interfaces must be .true. or .false.') + end if + else + if (present(active_species_idx_dycore)) then + idx_local = active_species_idx_dycore + else + idx_local = thermodynamic_active_species_idx + end if + if (present(fact)) then + factor = fact(:,:) + else + factor = 1.0_r8 + endif + if (present(mbarv_in)) then + mbarv = mbarv_in + else + call get_mbarv(tracer, idx_local, mbarv, fact=factor) + end if + ! + ! major species dependent code + ! + if (get_at_interfaces) then + do kdx = 2, SIZE(sponge_factor, 1) + do idx = 1, SIZE(tracer, 1) + kmvis(idx, kdx) = 0.0_r8 + kmcnd(idx, kdx) = 0.0_r8 + residual = 1.0_r8 + do icnst = 1, dry_air_species_num + ispecies = idx_local(icnst) + mm = 0.5_r8 * (tracer(idx, kdx, ispecies) * factor(idx, kdx) + & + tracer(idx, kdx - 1, ispecies) * factor(idx, kdx-1)) + kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & + thermodynamic_active_species_mwi(icnst) * mm + kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & + thermodynamic_active_species_mwi(icnst) * mm + residual = residual - mm + end do + icnst = 0 ! N2 + kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & + thermodynamic_active_species_mwi(icnst) * residual + kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & + thermodynamic_active_species_mwi(icnst) * residual + + temp_local = 0.5_r8 * (temp(idx, kdx - 1) + temp(idx, kdx)) + mbarvi = 0.5_r8 * (mbarv(idx, kdx - 1) + mbarv(idx, kdx)) + kmvis(idx, kdx) = kmvis(idx, kdx) * mbarvi * temp_local ** kv_temp_exp + kmcnd(idx, kdx) = kmcnd(idx, kdx) * mbarvi * temp_local ** kc_temp_exp + enddo + end do + do idx = 1, SIZE(tracer, 1) + kmvis(idx, 1) = 1.5_r8 * kmvis(idx, 2) - .5_r8 * kmvis(idx, 3) + kmcnd(idx, 1) = 1.5_r8 * kmcnd(idx, 2) - .5_r8 * kmcnd(idx, 3) + kmvis(idx, SIZE(sponge_factor, 1) + 1) = kmvis(idx, SIZE(sponge_factor, 1)) + kmcnd(idx, SIZE(sponge_factor, 1) + 1) = kmcnd(idx, SIZE(sponge_factor, 1)) + end do + else if (.not. get_at_interfaces) then + do kdx = 1, SIZE(sponge_factor, 1) + do idx = 1, SIZE(tracer, 1) + kmvis(idx, kdx) = 0.0_r8 + kmcnd(idx, kdx) = 0.0_r8 + residual = 1.0_r8 + do icnst = 1, dry_air_species_num - 1 + ispecies = idx_local(icnst) + mm = tracer(idx, kdx, ispecies) * factor(idx, kdx) + kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & + thermodynamic_active_species_mwi(icnst) * mm + kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & + thermodynamic_active_species_mwi(icnst) * mm + residual = residual - mm + end do + icnst = dry_air_species_num + kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & + thermodynamic_active_species_mwi(icnst) * residual + kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & + thermodynamic_active_species_mwi(icnst) * residual + + kmvis(idx, kdx) = kmvis(idx, kdx) * mbarv(idx, kdx) * temp(idx, kdx) ** kv_temp_exp + kmcnd(idx, kdx) = kmcnd(idx, kdx) * mbarv(idx, kdx) * temp(idx, kdx) ** kc_temp_exp + end do + end do + else + call endrun(subname//'get_at_interfaces must be .true. or .false.') + end if + end if + end subroutine get_molecular_diff_coef_1hd + + subroutine get_molecular_diff_coef_2hd(temp, get_at_interfaces, sponge_factor, kmvis, kmcnd, & + tracer, fact, active_species_idx_dycore, mbarv_in) + ! Version of get_molecular_diff_coef for arrays that have a second horizontal index + real(r8), intent(in) :: temp(:,:,:) ! temperature + logical, intent(in) :: get_at_interfaces ! true: compute kmvis and kmcnd at interfaces + ! false: compute kmvis and kmcnd at mid-levels + real(r8), intent(in) :: sponge_factor(:) ! multiply kmvis and kmcnd with sponge_factor + ! (for sponge layer) + real(r8), intent(out) :: kmvis(:,:,:) + real(r8), intent(out) :: kmcnd(:,:,:) + real(r8), intent(in) :: tracer(:,:,:,:) ! tracer array + integer, intent(in), optional :: active_species_idx_dycore(:) ! index of active species in tracer + real(r8), intent(in), optional :: fact(:,:,:) ! if tracer is in units of mass or moist + ! fact converts to dry mixing ratio: tracer/fact + real(r8), intent(in), optional :: mbarv_in(:,:,:) ! composition dependent atmosphere mean mass + integer :: jdx + + do jdx = 1, SIZE(tracer, 2) + if (present(fact) .and. present(mbarv_in)) then + call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & + kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), fact=fact(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore, mbarv_in=mbarv_in(:, jdx, :)) + else if (present(fact)) then + call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & + kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), fact=fact(:, jdx, :), & + active_species_idx_dycore=active_species_idx_dycore) + else if (present(mbarv_in)) then + call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & + kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), & + active_species_idx_dycore=active_species_idx_dycore, mbarv_in=mbarv_in(:, jdx, :)) + else + call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & + kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), & + active_species_idx_dycore=active_species_idx_dycore) + end if + end do + + end subroutine get_molecular_diff_coef_2hd + !=========================================================================== + + !*************************************************************************** + ! + ! compute reference vertical profile of density, molecular diffusion and thermal conductivity + ! + !*************************************************************************** + ! + subroutine get_molecular_diff_coef_reference(tref,press,sponge_factor,kmvis_ref,kmcnd_ref,rho_ref) + use physconst, only: rair + use air_composition, only: kv1, kv2, kc1, kc2, kv_temp_exp, kc_temp_exp + ! args + real(r8), intent(in) :: tref !reference temperature + real(r8), intent(in) :: press(:) !pressure + real(r8), intent(in) :: sponge_factor(:) !multiply kmvis and kmcnd with sponge_factor (for sponge layer) + real(r8), intent(out) :: kmvis_ref(:) !reference molecular diffusion coefficient + real(r8), intent(out) :: kmcnd_ref(:) !reference thermal conductivity coefficient + real(r8), intent(out) :: rho_ref(:) !reference density + + ! local vars + integer :: kdx + + !-------------------------------------------- + ! Set constants needed for updates + !-------------------------------------------- + + do kdx = 1, SIZE(press, 1) + rho_ref(kdx) = press(kdx) / (tref * rair) !ideal gas law for dry air + kmvis_ref(kdx) = sponge_factor(kdx) * & + (kv1 * mmro2 * o2_mwi + & + kv2 * mmrn2 * n2_mwi) * mbar * & + tref ** kv_temp_exp + kmcnd_ref(kdx) = sponge_factor(kdx) * & + (kc1 * mmro2 * o2_mwi + & + kc2 * mmrn2 * n2_mwi) * mbar * & + tref ** kc_temp_exp + end do + end subroutine get_molecular_diff_coef_reference + + !========================================================================== + + ! + !*************************************************************************** + ! + ! cam_thermo_calc_kappav: update species dependent kappa for FV dycore + ! + !*************************************************************************** + ! + subroutine cam_thermo_calc_kappav_2hd(tracer, kappav, cpv) + use air_composition, only: get_R_dry, get_cp_dry + ! assumes moist MMRs + + ! Dummy arguments + real(r8), intent(in) :: tracer(:, :, :, :) + real(r8), intent(out) :: kappav(:, :, :) + real(r8), optional, intent(out) :: cpv(:, :, :) + + ! Local variables + real(r8) :: rgas_var(SIZE(tracer, 1), SIZE(tracer, 2), SIZE(tracer, 3)) + real(r8) :: cp_var(SIZE(tracer, 1), SIZE(tracer, 2), SIZE(tracer, 3)) + integer :: ind, jnd, knd + + !----------------------------------------------------------------------- + ! Calculate constituent dependent specific heat, gas constant and cappa + !----------------------------------------------------------------------- + call get_R_dry(tracer, thermodynamic_active_species_idx, rgas_var) + call get_cp_dry(tracer, thermodynamic_active_species_idx, cp_var) + !$omp parallel do private(ind,jnd,knd) + do knd = 1, SIZE(tracer, 3) + do jnd = 1, SIZE(tracer, 2) + do ind = 1, SIZE(tracer, 1) + kappav(ind,jnd,knd) = rgas_var(ind,jnd,knd) / cp_var(ind,jnd,knd) + end do + end do + end do + + if (present(cpv)) then + cpv(:,:,:) = cp_var(:,:,:) + end if + + end subroutine cam_thermo_calc_kappav_2hd + + !=========================================================================== + ! + !*************************************************************************** + ! + ! compute column integrated total energy consistent with vertical + ! coordinate as well as vertical integrals of water mass (H2O,wv,liq,ice) + ! + ! if subroutine is asked to compute "te" then the latent heat terms are + ! added to the kinetic (ke), internal + geopotential (se) energy terms + ! + ! subroutine assumes that enthalpy term (rho*cp*T) uses dry air heat capacity !tht: why? not true + ! + !*************************************************************************** + ! + subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & + cp_or_cv, U, V, T, vcoord, ptop, phis, z_mid, dycore_idx, qidx, & + te, se, po, ke, wv, H2O, liq, ice) + + use cam_logfile, only: iulog + use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure + use air_composition, only: wv_idx + use physconst, only: rga, latvap, latice + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a, h00a_vap, h00a_ice !+tht + + ! Dummy arguments + ! tracer: tracer mixing ratio + ! + ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry + real(r8), intent(in) :: tracer(:,:,:) + logical, intent(in) :: moist_mixing_ratio + ! pdel: pressure level thickness + real(r8), intent(in) :: pdel_in(:,:) + ! cp_or_cv: dry air heat capacity under constant pressure or + ! constant volume (depends on vcoord) + real(r8), intent(in) :: cp_or_cv(:,:) + real(r8), intent(in) :: U(:,:) + real(r8), intent(in) :: V(:,:) + real(r8), intent(in) :: T(:,:) + integer, intent(in) :: vcoord ! vertical coordinate + real(r8), intent(in), optional :: ptop(:) + real(r8), intent(in), optional :: phis(:) + real(r8), intent(in), optional :: z_mid(:,:) + ! dycore_idx: use dycore index for thermodynamic active species + logical, intent(in), optional :: dycore_idx + ! qidx: Index of water vapor + integer, intent(in), optional :: qidx + ! H2O: vertically integrated total water + real(r8), intent(out), optional :: H2O(:) + ! TE: vertically integrated total energy + real(r8), intent(out), optional :: te (:) + ! KE: vertically integrated kinetic energy + real(r8), intent(out), optional :: ke (:) + ! SE: vertically integrated enthalpy (pressure coordinate) + ! or internal energy (z coordinate) + real(r8), intent(out), optional :: se (:) + ! PO: vertically integrated PHIS term (pressure coordinate) + ! or potential energy (z coordinate) + real(r8), intent(out), optional :: po (:) + ! WV: vertically integrated water vapor + real(r8), intent(out), optional :: wv (:) + ! liq: vertically integrated liquid + real(r8), intent(out), optional :: liq(:) + ! ice: vertically integrated ice + real(r8), intent(out), optional :: ice(:) + + ! Local variables + real(r8) :: ke_vint(SIZE(tracer, 1)) ! Vertical integral of KE + real(r8) :: se_vint(SIZE(tracer, 1)) ! Vertical integral of enthalpy or internal energy + real(r8) :: po_vint(SIZE(tracer, 1)) ! Vertical integral of PHIS or potential energy + real(r8) :: wv_vint(SIZE(tracer, 1)) ! Vertical integral of wv + real(r8) :: liq_vint(SIZE(tracer, 1)) ! Vertical integral of liq + real(r8) :: ice_vint(SIZE(tracer, 1)) ! Vertical integral of ice + real(r8) :: wtot_vint(SIZE(tracer, 1))! Vertical integral of water + real(r8) :: pdel(SIZE(tracer, 1),SIZE(tracer, 2)) !moist pressure level thickness + real(r8) :: latsub ! latent heat of sublimation + + integer :: ierr + integer :: kdx, idx ! coord indices + integer :: qdx ! tracer index + integer :: wvidx ! water vapor index + integer, allocatable :: species_idx(:) + integer, allocatable :: species_liq_idx(:) + integer, allocatable :: species_ice_idx(:) + character(len=*), parameter :: subname = 'get_hydrostatic_energy' + + allocate(species_idx(thermodynamic_active_species_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_idx array') + end if + allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_liq_idx array') + end if + allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_ice_idx array') + end if + + if (present(dycore_idx))then + if (dycore_idx) then + species_idx(:) = thermodynamic_active_species_idx_dycore(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + + if (present(qidx)) then + wvidx = qidx + else + wvidx = wv_idx + end if + + if (moist_mixing_ratio) then + pdel = pdel_in + else + pdel = pdel_in + do qdx = dry_air_species_num+1, thermodynamic_active_species_num + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx)) + end do + end if + + ke_vint = 0._r8 + se_vint = 0._r8 + select case (vcoord) + case(vc_moist_pressure, vc_dry_pressure) + if (.not. present(ptop).or. (.not. present(phis))) then + write(iulog, *) subname, ' ptop and phis must be present for ', & + 'moist/dry pressure vertical coordinate' + call endrun(subname//': ptop and phis must be present for '// & + 'moist/dry pressure vertical coordinate') + end if + po_vint = ptop + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + ke_vint(idx) = ke_vint(idx) + (pdel(idx, kdx) * & + 0.5_r8 * (U(idx, kdx)**2 + V(idx, kdx)**2)) * rga + se_vint(idx) = se_vint(idx) + (T(idx, kdx) * & + cp_or_cv(idx, kdx) * pdel(idx, kdx) * rga) + po_vint(idx) = po_vint(idx)+pdel(idx, kdx) + + end do + end do + do idx = 1, SIZE(tracer, 1) + po_vint(idx) = (phis(idx) * po_vint(idx) * rga) + end do + case(vc_height) + if (.not. present(phis)) then + write(iulog, *) subname, ' phis must be present for ', & + 'heigt-based vertical coordinate' + call endrun(subname//': phis must be present for '// & + 'height-based vertical coordinate') + end if + po_vint = 0._r8 + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + ke_vint(idx) = ke_vint(idx) + (pdel(idx, kdx) * & + 0.5_r8 * (U(idx, kdx)**2 + V(idx, kdx)**2) * rga) + se_vint(idx) = se_vint(idx) + (T(idx, kdx) * & + cp_or_cv(idx, kdx) * pdel(idx, kdx) * rga) + ! z_mid is height above ground + po_vint(idx) = po_vint(idx) + (z_mid(idx, kdx) + & + phis(idx) * rga) * pdel(idx, kdx) + end do + end do + case default + write(iulog, *) subname, ' vertical coordinate not supported: ', vcoord + call endrun(subname//': vertical coordinate not supported') + end select + if (present(te)) then + te = se_vint + po_vint+ ke_vint + end if + if (present(se)) then + se = se_vint + end if + if (present(po)) then + po = po_vint + end if + if (present(ke)) then + ke = ke_vint + end if + ! + ! vertical integral of total liquid water + ! + if (.not.moist_mixing_ratio) then + pdel = pdel_in! set pseudo density to dry + end if + + wv_vint = 0._r8 + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + wv_vint(idx) = wv_vint(idx) + (tracer(idx, kdx, wvidx) * & + pdel(idx, kdx) * rga) + end do + end do + if (present(wv)) wv = wv_vint + + liq_vint = 0._r8 + do qdx = 1, thermodynamic_active_species_liq_num + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + liq_vint(idx) = liq_vint(idx) + (pdel(idx, kdx) * & + tracer(idx, kdx, species_liq_idx(qdx)) * rga) + end do + end do + end do + if (present(liq)) liq = liq_vint + + ! + ! vertical integral of total frozen (ice) water + ! + ice_vint = 0._r8 + do qdx = 1, thermodynamic_active_species_ice_num + do kdx = 1, SIZE(tracer, 2) + do idx = 1, SIZE(tracer, 1) + ice_vint(idx) = ice_vint(idx) + (pdel(idx, kdx) * & + tracer(idx, kdx, species_ice_idx(qdx)) * rga) + end do + end do + end do + if (present(ice)) ice = ice_vint + + ! Compute vertical integrals of total water. + wtot_vint = wv_vint + liq_vint + ice_vint + if (present(H2O)) then + H2O = wtot_vint + end if + + ! latent heat terms depend on enthalpy reference state + !tht: note choices in physconst however, ensuring they actually + latsub = latvap + latice + if (present(te)) then + select case (TRIM(enthalpy_reference_state)) + case('ice') + te = te + (latsub * wv_vint) + (latice * liq_vint) + !+tht: add t00 and h00 terms + if(vcoord.ne.vc_moist_pressure) then + te = te + wv_vint*(cpice-cpwv )*t00a + te = te + liq_vint*(cpice-cpliq)*t00a + te = te + wtot_vint*h00a_ice + endif + case('liq') + te = te + (latvap * wv_vint) - (latice * ice_vint) + !+tht: add t00 and h00 terms + if(vcoord.ne.vc_moist_pressure) then + te = te + wv_vint*(cpliq-cpwv )*t00a + te = te + ice_vint*(cpliq-cpice)*t00a + te = te + wtot_vint*h00a + endif + case('vap') + te = te - (latvap * liq_vint) - (latsub * ice_vint) + !+tht: add t00 and h00 terms + if(vcoord.ne.vc_moist_pressure) then + te = te + liq_vint*(cpwv -cpliq)*t00a + te = te + ice_vint*(cpwv -cpice)*t00a + te = te + wtot_vint*h00a_vap + endif + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(enthalpy_reference_state) + call endrun(subname//': enthalpy reference state not supported') + end select + end if + deallocate(species_idx, species_liq_idx, species_ice_idx) + end subroutine get_hydrostatic_energy_1hd +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!+tht + subroutine get_conserved_energy(moist_mixing_ratio, ktop, kbot & + , cp_or_cv, T, tracer, pdel_in & + , pdel, te & + , qini, liqini, iceini & + , phis & + , gph & + , U, V, W, rairv & + , flatent,latent,potential,kinetic,temce & + , refstate, vcoord, dycore_idx) + + use dycore, only: dycore_is + use cam_logfile, only: iulog + use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure + use air_composition, only: wv_idx + use physconst, only: rga, latvap, latice + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a, h00a_vap, h00a_ice + +! ARGUMENTS: +! IN: + ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry + logical , intent(in) :: moist_mixing_ratio + integer , intent(in) :: ktop, kbot + ! cp_or_cv: dry air heat capacity under constant pressure or + ! constant volume (depends on vcoord) + real(r8), intent(in) :: cp_or_cv(:,:) + real(r8), intent(in) :: T(:,:) + real(r8), intent(in) :: tracer(:,:,:) + ! pdel: pressure level thickness + real(r8), intent(in) :: pdel_in(:,:) !N.B. this should be g*\rho*dz for MPAS +! OUT: conserved total energy/enthalpy per unit mass + real(r8), intent(out) :: te (:,:) + ! pdel: layer mass + real(r8), intent(out) :: pdel(:,:) !N.B. this should be g*\rho*dz for MPAS +! optional args: + real(r8), intent(in), optional :: qini(:,:), liqini(:,:), iceini(:,:) + ! surface geopotential -- should be made mandatory arg + real(r8), intent(in), optional :: phis(:) + ! geopotential height, required for MPAS: te=u_m:=c_v*T+latent+gz+KE + ! dycore_is('MPAS') and gph not present -> stop + real(r8), intent(in), optional :: gph(:,:) + !N.B. either PHIS or GPH must be present + ! horizontal winds --> add KE (should be made mandatory arguments) + real(r8), intent(in), optional :: U(:,:) + real(r8), intent(in), optional :: V(:,:) + ! vertical wind --> add to KE (non-hydrostatic) + real(r8), intent(in), optional :: W(:,:) + real(r8), intent(in), optional :: Rairv(:,:) + character(len=3),intent(in),optional :: refstate + integer, intent(in), optional :: vcoord ! vertical coordinate + ! dycore_idx: use dycore index for thermodynamic active species + logical, intent(in) , optional :: dycore_idx + real(r8), intent(out), optional :: flatent(:,:) + real(r8), intent(out), optional :: latent(:,:) + real(r8), intent(out), optional :: potential(:,:) + real(r8), intent(out), optional :: kinetic(:,:) + real(r8), intent(out), optional :: temce(:,:) ! Total Enthalpy Minus Conserved Energy + + ! Local variables + real(r8) :: qwv (SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qliq(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qice(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qtot(SIZE(tracer, 1),SIZE(tracer, 2)), latsub + real(r8) :: work(SIZE(tracer, 1),SIZE(tracer, 2)) + + integer :: ierr + integer :: kdx, idx, nkd, nid ! coord indices + integer :: qdx ! tracer index + integer :: wvidx ! water vapor index + integer, allocatable :: species_idx(:) + integer, allocatable :: species_liq_idx(:) + integer, allocatable :: species_ice_idx(:) + character(len=3) :: loc_refstate + character(len=*), parameter :: subname = 'get_conserved_energy' + + allocate(species_idx(thermodynamic_active_species_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_idx array') + end if + allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_liq_idx array') + end if + allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_ice_idx array') + end if + + nkd=SIZE(tracer, 2) + nid=SIZE(tracer, 1) + + if(present(refstate))then + loc_refstate=trim(refstate) + else + loc_refstate=trim(enthalpy_reference_state) + endif + + if (present(dycore_idx))then + if (dycore_idx) then + species_idx(:) = thermodynamic_active_species_idx_dycore(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + + if (moist_mixing_ratio) then + pdel = pdel_in*rga + else + pdel = pdel_in*rga + if(present(qini).and.present(liqini).and.present(iceini))then + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*(qini(:,:)+liqini(:,:)+iceini(:,:))*rga + else + do qdx = dry_air_species_num+1, thermodynamic_active_species_num + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx))*rga + end do + endif + end if + + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = T(idx,kdx)*cp_or_cv(idx, kdx) + end do + end do + + work(:,:)=0._r8 + if(present(phis))then + do kdx = ktop, kbot + do idx = 1, nid + work(idx,kdx) = phis(idx) + end do + end do + endif + if(dycore_is('MPAS')) then + if(.not.present(gph)) call endrun(subname//': conserved_energy function'// & + ' requires GPH in input for non-hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + work(idx,kdx) = work(idx,kdx) + gph(idx,kdx)/rga + end do + end do + endif + if (present(potential)) then + do kdx = ktop, kbot + do idx = 1, nid + potential(idx,kdx) = work(idx,kdx) + end do + end do + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + + if(present(qini).and.present(liqini).and.present(iceini))then + qwv (:,:)=qini (:,:) + qliq(:,:)=liqini(:,:) + qice(:,:)=iceini(:,:) + else + qwv (:,:) = tracer(:,:,wv_idx) + qliq(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_liq_num + qliq(:,:) = qliq(:,:) + tracer(:,:,species_liq_idx(qdx)) + enddo + qice(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_ice_num + qice(:,:) = qice(:,:) + tracer(:,:,species_ice_idx(qdx)) + enddo + endif + + latsub = latvap + latice + select case (TRIM(loc_refstate)) + case('ice') + work(:,:) = (latsub * qwv ) + (latice * qliq) + case('liq') + work(:,:) = (latvap * qwv ) - (latice * qice) + case('vap') + work(:,:) =-(latvap * qliq) - (latsub * qice) + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(loc_refstate) + call endrun(subname//': enthalpy reference state not supported') + end select + if (present(latent).or.present(flatent)) then + if (present(flatent)) then + do kdx = ktop, kbot + do idx = 1, nid + flatent(idx,kdx) = work(idx,kdx) + end do + end do + endif + if (present(latent)) then + do kdx = ktop, kbot + do idx = 1, nid + latent(idx,kdx) = work(idx,kdx) + end do + end do + endif + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + + ! add t00 and h00 terms + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + qtot(:,:) = qice(:,:) + qliq(:,:) + qwv (:,:) + select case (TRIM(loc_refstate)) + case('ice') + work(:,:) = qwv (:,:)*(cpice-cpwv )*t00a & + + qliq(:,:)*(cpice-cpliq)*t00a & + + qtot(:,:)*h00a_ice + case('liq') + work(:,:) = qwv (:,:)*(cpliq-cpwv )*t00a & + + qice(:,:)*(cpliq-cpice)*t00a & + + qtot(:,:)*h00a + case('vap') + work(:,:) = qliq(:,:)*(cpwv -cpliq)*t00a & + + qice(:,:)*(cpwv -cpice)*t00a & + + qtot(:,:)*h00a_vap + end select + if (present(latent)) then + do kdx = ktop, kbot + do idx = 1, nid + latent(idx,kdx) = latent(idx,kdx)+work(idx,kdx) + end do + end do + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + endif + endif + + if(present(U).and.present(V)) then + do kdx = ktop, kbot + do idx = 1, nid + work(idx,kdx) = .5_r8*(u(idx,kdx)**2+v(idx,kdx)**2) + enddo + enddo + if (present(kinetic)) then + do kdx = ktop, kbot + do idx = 1, nid + kinetic(idx,kdx)= work(idx,kdx) + end do + end do + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + endif + + if(present(temce)) then + if(dycore_is('MPAS'))then + if(.not.(present(rairv))) call endrun(subname//': TEMCE required but'// & + ' Rairv not provided in non-hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + temce(idx,kdx) = T(idx,kdx)*rairv(idx, kdx) + end do + end do + else + if(.not.(present(gph))) call endrun(subname//': TEMCE required but'// & + ' GPH not provided in hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + temce(idx,kdx) = gph(idx,kdx)/rga + end do + end do + endif + endif + + deallocate(species_idx, species_liq_idx, species_ice_idx) + + end subroutine get_conserved_energy + + subroutine inv_conserved_energy(moist_mixing_ratio & + , ktop, kbot & + , te, cp_or_cv, tracer, pdel_in & + , pdel, T & + , phis & + , gph & + , U, V, W & + , flatent,latent,potential,kinetic & + , refstate, vcoord, dycore_idx) + + use cam_logfile, only: iulog + use dycore, only: dycore_is + use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure + use air_composition, only: wv_idx + use physconst, only: rga, latvap, latice + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a, h00a_vap, h00a_ice + +! ARGUMENTS: +! IN: + ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry + logical , intent(in) :: moist_mixing_ratio + integer , intent(in) :: ktop, kbot + ! conserved energy/enthalpy + real(r8), intent(in) :: te(:,:) + ! cp_or_cv: dry air heat capacity under constant pressure or + ! constant volume (depends on vcoord) + real(r8), intent(in) :: cp_or_cv(:,:) + real(r8), intent(in) :: tracer(:,:,:) + ! pdel: pressure level thickness + real(r8), intent(in) :: pdel_in(:,:) !N.B. this should be g*\rho*dz for MPAS +! OUT: temperature + real(r8), intent(out) :: T(:,:) + ! pdel: layer mass + real(r8), intent(out) :: pdel(:,:) !N.B. this should be g*\rho*dz for MPAS +! optional args: + ! surface geopotential --> compute te=e_m:=c_p*T+latent+phis+KE (hydrostatic) + real(r8), intent(in), optional :: phis(:) + ! geopotential height --> compute te=u_m:=c_v*T+latent+gz+KE (MPAS) + ! should be =z_mid in output os subroutine geopotential_t + real(r8), intent(in), optional :: gph(:,:) + character(len=3),intent(in),optional :: refstate + integer, intent(in), optional :: vcoord ! vertical coordinate + !N.B. either PHIS or GPH must be present + ! dycore_idx: use dycore index for thermodynamic active species + logical, intent(in), optional :: dycore_idx + ! horizontal winds --> add KE (will be made mandatory arguments later) + real(r8), intent(in), optional :: U(:,:) + real(r8), intent(in), optional :: V(:,:) + ! vertical wind --> add to KE (MPAS) + real(r8), intent(in), optional :: W(:,:) + real(r8), intent(in), optional :: flatent(:,:) + real(r8), intent(in), optional :: latent(:,:) + real(r8), intent(in), optional :: potential(:,:) + real(r8), intent(in), optional :: kinetic(:,:) + + ! Local variables + real(r8) ::tetmp(SIZE(tracer, 1),SIZE(tracer, 2)) + real(r8) :: qwv (SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qliq(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qice(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qtot(SIZE(tracer, 1),SIZE(tracer, 2)), latsub + + integer :: ierr + integer :: kdx, idx, nkd, nid ! coord indices + integer :: qdx ! tracer index + integer :: wvidx ! water vapor index + integer, allocatable :: species_idx(:) + integer, allocatable :: species_liq_idx(:) + integer, allocatable :: species_ice_idx(:) + character(len=3) :: loc_refstate + character(len=*), parameter :: subname = 'get_conserved_energy' + + allocate(species_idx(thermodynamic_active_species_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_idx array') + end if + allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_liq_idx array') + end if + allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_ice_idx array') + end if + + nkd=SIZE(tracer, 2) + nid=SIZE(tracer, 1) + + if(present(refstate))then + loc_refstate=trim(refstate) + else + loc_refstate=trim(enthalpy_reference_state) + endif + + if (present(dycore_idx))then + if (dycore_idx) then + species_idx(:) = thermodynamic_active_species_idx_dycore(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + + if (moist_mixing_ratio) then + pdel = pdel_in*rga + else + pdel = pdel_in*rga + do qdx = dry_air_species_num+1, thermodynamic_active_species_num + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx))*rga + end do + end if + + if(present(kinetic)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = te(idx,kdx) - kinetic(idx,kdx) + enddo + enddo + else if(present(U).and.present(V)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = te(idx,kdx) - .5_r8*(u(idx,kdx)**2+v(idx,kdx)**2) + enddo + enddo + else + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = te(idx,kdx) + end do + end do + endif + + if(present(potential)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - potential(idx,kdx) + end do + end do + else + if(present(phis))then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - phis(idx) + end do + end do + endif + if(dycore_is('MPAS')) then + if(.not.present(gph)) call endrun(subname//': conserved_energy function'// & + ' requires GPH in input for non-hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - gph(idx,kdx)/rga + end do + end do + endif + endif + + if (present(latent)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - latent(idx,kdx) + end do + end do + else + qwv (:,:) = tracer(:,:,wv_idx) + qliq(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_liq_num + qliq(:,:) = qliq(:,:) + tracer(:,:,species_liq_idx(qdx)) + enddo + qice(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_ice_num + qice(:,:) = qice(:,:) + tracer(:,:,species_ice_idx(qdx)) + enddo + qtot(:,:) = qice(:,:) + qliq(:,:) + qwv (:,:) + if (present(flatent)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - flatent(idx,kdx) + end do + end do + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + ! add t00 and h00 terms + select case (TRIM(loc_refstate)) + case('ice') + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpice-cpwv )*t00a & + +qliq(:,:)*(cpice-cpliq)*t00a & + +qtot(:,:)*h00a_ice ) + case('liq') + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpliq-cpwv )*t00a & + +qice(:,:)*(cpliq-cpice)*t00a & + +qtot(:,:)*h00a ) + case('vap') + tetmp(:,:) = tetmp(:,:) -(qliq(:,:)*(cpwv -cpliq)*t00a & + +qice(:,:)*(cpwv -cpice)*t00a & + +qtot(:,:)*h00a_vap ) + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(loc_refstate) + call endrun(subname//': enthalpy reference state not supported') + end select + endif + endif + else + latsub = latvap + latice + select case (TRIM(loc_refstate)) + case('ice') + tetmp(:,:) = tetmp(:,:) - (latsub * qwv ) - (latice * qliq) + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpice-cpwv )*t00a & + +qliq(:,:)*(cpice-cpliq)*t00a & + +qtot(:,:)*h00a_ice ) + endif + endif + case('liq') + tetmp(:,:) = tetmp(:,:) - (latvap * qwv ) + (latice * qice) + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpliq-cpwv )*t00a & + +qice(:,:)*(cpliq-cpice)*t00a & + +qtot(:,:)*h00a ) + endif + endif + case('vap') + tetmp(:,:) = tetmp(:,:) + (latvap * qliq) + (latsub * qice) + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + tetmp(:,:) = tetmp(:,:) -(qliq(:,:)*(cpwv -cpliq)*t00a & + +qice(:,:)*(cpwv -cpice)*t00a & + +qtot(:,:)*h00a_vap ) + endif + endif + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(loc_refstate) + call endrun(subname//': enthalpy reference state not supported') + end select + endif + endif + + do kdx = ktop, kbot + do idx = 1, nid + T(idx,kdx) = tetmp(idx,kdx)/cp_or_cv(idx, kdx) + end do + end do + + deallocate(species_idx, species_liq_idx, species_ice_idx) + + end subroutine inv_conserved_energy +!-tht +!------------------------------------------------------------------------------- +end module cam_thermo diff --git a/src/physics/camnor_phys/physics/camsrfexch.F90 b/src/physics/camnor_phys/physics/camsrfexch.F90 new file mode 100644 index 0000000000..1dea2a7d10 --- /dev/null +++ b/src/physics/camnor_phys/physics/camsrfexch.F90 @@ -0,0 +1,708 @@ +module camsrfexch + + !----------------------------------------------------------------------- + ! Module to handle data that is exchanged between the CAM atmosphere + ! model and the surface models (land, sea-ice, and ocean). + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 + use constituents, only: pcnst + use ppgrid, only: pcols, begchunk, endchunk + use phys_grid, only: get_ncols_p, phys_grid_initialized + use infnan, only: posinf, assignment(=) + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use srf_field_check, only: active_Sl_ram1, active_Sl_fv, active_Sl_soilw, & + active_Fall_flxdst1, active_Fall_flxvoc, active_Fall_flxfire + use cam_control_mod, only: aqua_planet, simple_phys + + + implicit none + private + + ! Public interfaces + public atm2hub_alloc ! Atmosphere to surface data allocation method + public hub2atm_alloc ! Merged hub surface to atmosphere data allocation method + public atm2hub_deallocate + public hub2atm_deallocate + public cam_export + public get_prec_vars + ! Public data types + public cam_out_t ! Data from atmosphere + public cam_in_t ! Merged surface data + + !--------------------------------------------------------------------------- + ! This is the data that is sent from the atmosphere to the surface models + !--------------------------------------------------------------------------- + + type cam_out_t + integer :: lchnk ! chunk index + integer :: ncol ! number of columns in chunk + real(r8) :: tbot(pcols) ! bot level temperature + real(r8) :: zbot(pcols) ! bot level height above surface + real(r8) :: topo(pcols) ! surface topographic height (m) + real(r8) :: ubot(pcols) ! bot level u wind + real(r8) :: vbot(pcols) ! bot level v wind + real(r8) :: wind_dir(pcols) ! direction of bottom level wind + real(r8) :: qbot(pcols,pcnst) ! bot level specific humidity + real(r8) :: pbot(pcols) ! bot level pressure + real(r8) :: rho(pcols) ! bot level density + real(r8) :: netsw(pcols) ! + real(r8) :: flwds(pcols) ! + real(r8) :: precsc(pcols) ! + real(r8) :: precsl(pcols) ! + real(r8) :: precc(pcols) ! + real(r8) :: precl(pcols) ! + real(r8) :: hrain(pcols) ! material enth. flx for liquid precip + real(r8) :: hsnow(pcols) ! material enth. flx for frozen precip + real(r8) :: hevap(pcols) ! material enth. flx for evaporation + real(r8) :: hmat (pcols) ! material enth. flx at surface, total + real(r8) :: hlat (pcols) ! variable latent heat component of hmat + real(r8) :: soll(pcols) ! + real(r8) :: sols(pcols) ! + real(r8) :: solld(pcols) ! + real(r8) :: solsd(pcols) ! + real(r8) :: thbot(pcols) ! + real(r8) :: co2prog(pcols) ! prognostic co2 + real(r8) :: co2diag(pcols) ! diagnostic co2 + real(r8) :: ozone(pcols) ! surface ozone concentration (mole/mole) + real(r8) :: lightning_flash_freq(pcols) ! cloud-to-ground lightning flash frequency (/min) + real(r8) :: psl(pcols) + real(r8) :: bcphiwet(pcols) ! wet deposition of hydrophilic black carbon + real(r8) :: bcphidry(pcols) ! dry deposition of hydrophilic black carbon + real(r8) :: bcphodry(pcols) ! dry deposition of hydrophobic black carbon + real(r8) :: ocphiwet(pcols) ! wet deposition of hydrophilic organic carbon + real(r8) :: ocphidry(pcols) ! dry deposition of hydrophilic organic carbon + real(r8) :: ocphodry(pcols) ! dry deposition of hydrophobic organic carbon + real(r8) :: dstwet1(pcols) ! wet deposition of dust (bin1) + real(r8) :: dstdry1(pcols) ! dry deposition of dust (bin1) + real(r8) :: dstwet2(pcols) ! wet deposition of dust (bin2) + real(r8) :: dstdry2(pcols) ! dry deposition of dust (bin2) + real(r8) :: dstwet3(pcols) ! wet deposition of dust (bin3) + real(r8) :: dstdry3(pcols) ! dry deposition of dust (bin3) + real(r8) :: dstwet4(pcols) ! wet deposition of dust (bin4) + real(r8) :: dstdry4(pcols) ! dry deposition of dust (bin4) + real(r8), pointer, dimension(:) :: nhx_nitrogen_flx ! nitrogen deposition fluxes (kgN/m2/s) + real(r8), pointer, dimension(:) :: noy_nitrogen_flx ! nitrogen deposition fluxes (kgN/m2/s) + end type cam_out_t + + !--------------------------------------------------------------------------- + ! This is the merged state of sea-ice, land and ocean surface parameterizations + !--------------------------------------------------------------------------- + + type cam_in_t + integer :: lchnk ! chunk index + integer :: ncol ! number of active columns + real(r8) :: asdir(pcols) ! albedo: shortwave, direct + real(r8) :: asdif(pcols) ! albedo: shortwave, diffuse + real(r8) :: aldir(pcols) ! albedo: longwave, direct + real(r8) :: aldif(pcols) ! albedo: longwave, diffuse + real(r8) :: lwup(pcols) ! longwave up radiative flux + real(r8) :: lhf(pcols) ! latent heat flux + real(r8) :: shf(pcols) ! sensible heat flux + real(r8) :: wsx(pcols) ! surface u-stress (N) + real(r8) :: wsy(pcols) ! surface v-stress (N) + real(r8) :: tref(pcols) ! ref height surface air temp + real(r8) :: qref(pcols) ! ref height specific humidity + real(r8) :: u10(pcols) ! 10m wind speed + real(r8) :: ugustOut(pcols) ! gustiness added + real(r8) :: u10withGusts(pcols) ! 10m wind speed with gusts added + real(r8) :: ts(pcols) ! merged surface temp + real(r8) :: sst(pcols) ! sea surface temp + real(r8) :: snowhland(pcols) ! snow depth (liquid water equivalent) over land + real(r8) :: snowhice(pcols) ! snow depth over ice + real(r8) :: fco2_lnd(pcols) ! co2 flux from lnd + real(r8) :: fco2_ocn(pcols) ! co2 flux from ocn + real(r8) :: fdms(pcols) ! dms flux from ocn + real(r8) :: fbrf(pcols) ! bromoform flux from ocn + real(r8) :: fn2o_ocn(pcols) ! n2o flux from ocn + real(r8) :: fnh3_ocn(pcols) ! nh3 flux from ocn + real(r8) :: landfrac(pcols) ! land area fraction + real(r8) :: icefrac(pcols) ! sea-ice areal fraction + real(r8) :: ocnfrac(pcols) ! ocean areal fraction + real(r8) :: cflx(pcols,pcnst) ! constituent flux (emissions) + real(r8) :: evap_ocn(pcols) !+tht evaporation over ocean + real(r8) :: hrof (pcols) !+tht evaporation over ocean + real(r8) :: ustar(pcols) ! atm/ocn saved version of ustar + real(r8) :: re(pcols) ! atm/ocn saved version of re + real(r8) :: ssq(pcols) ! atm/ocn saved version of ssq + real(r8), pointer, dimension(:) :: ram1 !aerodynamical resistance (s/m) (pcols) + real(r8), pointer, dimension(:) :: fv !friction velocity (m/s) (pcols) + real(r8), pointer, dimension(:) :: soilw !volumetric soil water (m3/m3) + real(r8), pointer, dimension(:,:) :: depvel ! deposition velocities + real(r8), pointer, dimension(:,:) :: dstflx ! dust fluxes + real(r8), pointer, dimension(:,:) :: meganflx ! MEGAN fluxes + real(r8), pointer, dimension(:,:) :: fireflx ! wild fire emissions + real(r8), pointer, dimension(:) :: fireztop ! wild fire emissions vert distribution top + end type cam_in_t + +!=============================================================================== +CONTAINS +!=============================================================================== + + subroutine hub2atm_alloc( cam_in ) + + ! Allocate space for the surface to atmosphere data type. And initialize + ! the values. + + use shr_drydep_mod, only: n_drydep + use shr_megan_mod, only: shr_megan_mechcomps_n + use shr_fire_emis_mod,only: shr_fire_emis_mechcomps_n + + ! ARGUMENTS: + type(cam_in_t), pointer :: cam_in(:) ! Merged surface state + + ! LOCAL VARIABLES: + integer :: c ! chunk index + integer :: ierror ! Error code + character(len=*), parameter :: sub = 'hub2atm_alloc' + !----------------------------------------------------------------------- + + if ( .not. phys_grid_initialized() ) call endrun(sub//": phys_grid not called yet") + allocate (cam_in(begchunk:endchunk), stat=ierror) + if ( ierror /= 0 )then + write(iulog,*) sub//': Allocation error: ', ierror + call endrun(sub//': allocation error') + end if + + do c = begchunk,endchunk + nullify(cam_in(c)%ram1) + nullify(cam_in(c)%fv) + nullify(cam_in(c)%soilw) + nullify(cam_in(c)%depvel) + nullify(cam_in(c)%dstflx) + nullify(cam_in(c)%meganflx) + nullify(cam_in(c)%fireflx) + nullify(cam_in(c)%fireztop) + enddo + do c = begchunk,endchunk + if (active_Sl_ram1) then + allocate (cam_in(c)%ram1(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error ram1') + endif + if (active_Sl_fv) then + allocate (cam_in(c)%fv(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error fv') + endif + if (active_Sl_soilw) then + allocate (cam_in(c)%soilw(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error soilw') + end if + if (active_Fall_flxdst1) then + ! Assume 4 bins from surface model .... + allocate (cam_in(c)%dstflx(pcols,4), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error dstflx') + endif + if (active_Fall_flxvoc .and. shr_megan_mechcomps_n>0) then + allocate (cam_in(c)%meganflx(pcols,shr_megan_mechcomps_n), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error meganflx') + endif + end do + + if (n_drydep>0) then + do c = begchunk,endchunk + allocate (cam_in(c)%depvel(pcols,n_drydep), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error depvel') + end do + endif + + if (active_Fall_flxfire .and. shr_fire_emis_mechcomps_n>0) then + do c = begchunk,endchunk + allocate(cam_in(c)%fireflx(pcols,shr_fire_emis_mechcomps_n), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error fireflx') + allocate(cam_in(c)%fireztop(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error fireztop') + enddo + endif + + do c = begchunk,endchunk + cam_in(c)%lchnk = c + cam_in(c)%ncol = get_ncols_p(c) + cam_in(c)%asdir (:) = 0._r8 + cam_in(c)%asdif (:) = 0._r8 + cam_in(c)%aldir (:) = 0._r8 + cam_in(c)%aldif (:) = 0._r8 + cam_in(c)%lwup (:) = 0._r8 + cam_in(c)%lhf (:) = 0._r8 + cam_in(c)%shf (:) = 0._r8 + cam_in(c)%wsx (:) = 0._r8 + cam_in(c)%wsy (:) = 0._r8 + cam_in(c)%tref (:) = 0._r8 + cam_in(c)%qref (:) = 0._r8 + cam_in(c)%u10 (:) = 0._r8 + cam_in(c)%ugustOut (:) = 0._r8 + cam_in(c)%u10withGusts (:) = 0._r8 + cam_in(c)%ts (:) = 0._r8 + cam_in(c)%sst (:) = 0._r8 + cam_in(c)%snowhland(:) = 0._r8 + cam_in(c)%snowhice (:) = 0._r8 + cam_in(c)%fco2_lnd (:) = 0._r8 + cam_in(c)%fco2_ocn (:) = 0._r8 + cam_in(c)%fdms (:) = 0._r8 + cam_in(c)%fbrf (:) = 0._r8 + cam_in(c)%fn2o_ocn (:) = 0._r8 + cam_in(c)%fnh3_ocn (:) = 0._r8 + cam_in(c)%landfrac (:) = posinf + cam_in(c)%icefrac (:) = posinf + cam_in(c)%ocnfrac (:) = posinf + + if (associated(cam_in(c)%ram1)) & + cam_in(c)%ram1 (:) = 0.1_r8 + if (associated(cam_in(c)%fv)) & + cam_in(c)%fv (:) = 0.1_r8 + if (associated(cam_in(c)%soilw)) & + cam_in(c)%soilw (:) = 0.0_r8 + if (associated(cam_in(c)%dstflx)) & + cam_in(c)%dstflx(:,:) = 0.0_r8 + if (associated(cam_in(c)%meganflx)) & + cam_in(c)%meganflx(:,:) = 0.0_r8 + + cam_in(c)%cflx (:,:) = 0._r8 + cam_in(c)%evap_ocn (:) = 0._r8 + cam_in(c)%ustar (:) = 0._r8 + cam_in(c)%re (:) = 0._r8 + cam_in(c)%ssq (:) = 0._r8 + if (n_drydep>0) then + cam_in(c)%depvel (:,:) = 0._r8 + endif + if (active_Fall_flxfire .and. shr_fire_emis_mechcomps_n>0) then + cam_in(c)%fireflx(:,:) = 0._r8 + cam_in(c)%fireztop(:) = 0._r8 + endif + end do + + end subroutine hub2atm_alloc + + !=============================================================================== + + subroutine atm2hub_alloc( cam_out ) + + ! Allocate space for the atmosphere to surface data type. And initialize + ! the values. + + ! ARGUMENTS: + type(cam_out_t), pointer :: cam_out(:) ! Atmosphere to surface input + + ! LOCAL VARIABLES: + integer :: c ! chunk index + integer :: ierror ! Error code + character(len=*), parameter :: sub = 'atm2hub_alloc' + !----------------------------------------------------------------------- + + if (.not. phys_grid_initialized()) call endrun(sub//": phys_grid not called yet") + allocate (cam_out(begchunk:endchunk), stat=ierror) + if ( ierror /= 0 )then + write(iulog,*) sub//': Allocation error: ', ierror + call endrun(sub//': allocation error: cam_out') + end if + + do c = begchunk,endchunk + cam_out(c)%lchnk = c + cam_out(c)%ncol = get_ncols_p(c) + cam_out(c)%tbot(:) = 0._r8 + cam_out(c)%zbot(:) = 0._r8 + cam_out(c)%topo(:) = 0._r8 + cam_out(c)%ubot(:) = 0._r8 + cam_out(c)%vbot(:) = 0._r8 + cam_out(c)%wind_dir(:) = 0._r8 + cam_out(c)%qbot(:,:) = 0._r8 + cam_out(c)%pbot(:) = 0._r8 + cam_out(c)%rho(:) = 0._r8 + cam_out(c)%netsw(:) = 0._r8 + cam_out(c)%flwds(:) = 0._r8 + cam_out(c)%precsc(:) = 0._r8 + cam_out(c)%precsl(:) = 0._r8 + cam_out(c)%precc(:) = 0._r8 + cam_out(c)%precl(:) = 0._r8 + cam_out(c)%soll(:) = 0._r8 + cam_out(c)%sols(:) = 0._r8 + cam_out(c)%solld(:) = 0._r8 + cam_out(c)%solsd(:) = 0._r8 + cam_out(c)%thbot(:) = 0._r8 + cam_out(c)%co2prog(:) = 0._r8 + cam_out(c)%co2diag(:) = 0._r8 + cam_out(c)%ozone(:) = 0._r8 + cam_out(c)%lightning_flash_freq(:) = 0._r8 + cam_out(c)%psl(:) = 0._r8 + cam_out(c)%bcphidry(:) = 0._r8 + cam_out(c)%bcphodry(:) = 0._r8 + cam_out(c)%bcphiwet(:) = 0._r8 + cam_out(c)%ocphidry(:) = 0._r8 + cam_out(c)%ocphodry(:) = 0._r8 + cam_out(c)%ocphiwet(:) = 0._r8 + cam_out(c)%dstdry1(:) = 0._r8 + cam_out(c)%dstwet1(:) = 0._r8 + cam_out(c)%dstdry2(:) = 0._r8 + cam_out(c)%dstwet2(:) = 0._r8 + cam_out(c)%dstdry3(:) = 0._r8 + cam_out(c)%dstwet3(:) = 0._r8 + cam_out(c)%dstdry4(:) = 0._r8 + cam_out(c)%dstwet4(:) = 0._r8 + + cam_out(c)%hevap(:) = 0._r8 !+tht + + nullify(cam_out(c)%nhx_nitrogen_flx) + nullify(cam_out(c)%noy_nitrogen_flx) + if (.not.(simple_phys .or. aqua_planet)) then + allocate (cam_out(c)%nhx_nitrogen_flx(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error nhx_nitrogen_flx') + cam_out(c)%nhx_nitrogen_flx(:) = 0._r8 + allocate (cam_out(c)%noy_nitrogen_flx(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error noy_nitrogen_flx') + cam_out(c)%noy_nitrogen_flx(:) = 0._r8 + endif + + end do + + end subroutine atm2hub_alloc + + !=============================================================================== + + subroutine atm2hub_deallocate(cam_out) + + type(cam_out_t), pointer :: cam_out(:) ! Atmosphere to surface input + !----------------------------------------------------------------------- + + if(associated(cam_out)) then + deallocate(cam_out) + end if + nullify(cam_out) + + end subroutine atm2hub_deallocate + + !=============================================================================== + + subroutine hub2atm_deallocate(cam_in) + + type(cam_in_t), pointer :: cam_in(:) ! Atmosphere to surface input + + integer :: c + !----------------------------------------------------------------------- + + if(associated(cam_in)) then + do c=begchunk,endchunk + if(associated(cam_in(c)%ram1)) then + deallocate(cam_in(c)%ram1) + nullify(cam_in(c)%ram1) + end if + if(associated(cam_in(c)%fv)) then + deallocate(cam_in(c)%fv) + nullify(cam_in(c)%fv) + end if + if(associated(cam_in(c)%soilw)) then + deallocate(cam_in(c)%soilw) + nullify(cam_in(c)%soilw) + end if + if(associated(cam_in(c)%dstflx)) then + deallocate(cam_in(c)%dstflx) + nullify(cam_in(c)%dstflx) + end if + if(associated(cam_in(c)%meganflx)) then + deallocate(cam_in(c)%meganflx) + nullify(cam_in(c)%meganflx) + end if + if(associated(cam_in(c)%depvel)) then + deallocate(cam_in(c)%depvel) + nullify(cam_in(c)%depvel) + end if + + enddo + + deallocate(cam_in) + end if + nullify(cam_in) + + end subroutine hub2atm_deallocate + + +!====================================================================== + +subroutine cam_export(state,cam_in,cam_out,pbuf) + + ! Transfer atmospheric fields into necessary surface data structures + + use physics_types, only: physics_state + use ppgrid, only: pver + use cam_history, only: outfld + use chem_surfvals, only: chem_surfvals_get + use co2_cycle, only: co2_transport, c_i + use physconst, only: rair, mwdry, mwco2, gravit, mwo3, cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, t00o, h00a, h00o + use constituents, only: pcnst + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc, pbuf_set_field + use rad_constituents, only: rad_cnst_get_gas + use cam_control_mod, only: simple_phys + use air_composition, only: hliq_idx, hice_idx, fliq_idx, fice_idx + use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars + use cam_history, only: outfld!xxx debug + implicit none + + ! Input arguments + type(physics_state), intent(in) :: state + type (cam_in_t ), intent(in) :: cam_in + type (cam_out_t), intent(inout) :: cam_out + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variables + + integer :: i ! Longitude index + integer :: m ! constituent index + integer :: lchnk ! Chunk index + integer :: ncol + integer :: psl_idx + integer :: srf_ozone_idx, lightning_idx + integer :: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx !tht + + real(r8):: ubot, vbot + + real(r8), pointer :: psl(:) + + real(r8), pointer :: o3_ptr(:,:), srf_o3_ptr(:) + real(r8), pointer :: lightning_ptr(:) + + ! enthalpy variables (if applicable) + real(r8), dimension(:,:), pointer :: enthalpy_prec_ac + real(r8), dimension(:) , pointer :: hevap_ocn + real(r8), dimension(pcols) :: fliq_tot, fice_tot + real(r8), dimension(pcols,num_enthalpy_vars) :: enthalpy_prec_bc + + character(len=*), parameter :: sub = 'cam_export' + !----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + psl_idx = pbuf_get_index('PSL') + call pbuf_get_field(pbuf, psl_idx, psl) + + if (compute_enthalpy_flux) then + enthalpy_prec_bc_idx = pbuf_get_index('ENTHALPY_PREC_BC', errcode=i) + enthalpy_prec_ac_idx = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) + if (enthalpy_prec_bc_idx==0.or.enthalpy_prec_ac_idx==0) then !tht + call endrun(sub//": pbufs for enthalpy flux not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) + + !------------------------------------------------------------------ + ! + ! compute precipitation fluxes and set associated physics buffers + ! + !------------------------------------------------------------------ + call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot,& + precc_out=cam_out%precc,precl_out=cam_out%precl,& + precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) + + ! fliq_tot holds liquid precipitation from tphysbc and + ! tphysac from previous physics time-step: back out fliq_bc + ! Idem for ice + enthalpy_prec_bc(:ncol,fice_idx) = fice_tot(:ncol) -enthalpy_prec_ac(:ncol,fice_idx) ! out of atm + enthalpy_prec_bc(:ncol,fliq_idx) = fliq_tot(:ncol) -enthalpy_prec_ac(:ncol,fliq_idx) ! out of atm + + ! compute precipitation enthalpy fluxes from tphysbc + !tht: correct for reference T of latent heats (liquid reference state), and use tbot (=T(pver), updated later below) + enthalpy_prec_bc(:ncol,hice_idx) = -enthalpy_prec_bc(:ncol,fice_idx)*(cpice*(state%T(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) + enthalpy_prec_bc(:ncol,hliq_idx) = -enthalpy_prec_bc(:ncol,fliq_idx)*(cpliq*(state%T(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) + + ! export all prec_bc to pbuf + call pbuf_set_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) + + ! Compute enthalpy fluxes for the coupler: + cam_out%hsnow(:ncol) = enthalpy_prec_bc(:ncol,hice_idx)+enthalpy_prec_ac(:ncol,hice_idx) ! into atm + cam_out%hrain(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hliq_idx) ! into atm + !tht: change enthalpy flux to sign convention of ocean model and change zero points + cam_out%hsnow(:ncol) = -cam_out%hsnow(:ncol) + fice_tot(:ncol)*((h00o-h00a)+(cpliq-cpice)*(t00o-t00a)) ! into ocn; fice_tot is out of atm + cam_out%hrain(:ncol) = -cam_out%hrain(:ncol) + fliq_tot(:ncol)* (h00o-h00a)! +0. ! into ocn; fliq_tot is out of atm + + !+tht: hevap is one time-step old, consistently with rest of enthalpy_prec_ac + enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP', errcode=i) + if (enthalpy_evop_idx==0) then + call endrun(sub//": pbuf for enthalpy evop not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_evop_idx, hevap_ocn) + cam_out%hevap(:ncol) = -hevap_ocn(:ncol) - cam_in%evap_ocn(:ncol)*((h00o-h00a)+(cpliq-cpwv )*(t00o-t00a)) ! into ocn; cflux is into atm + !-tht + + !call outfld("hsnow_liq_ref" , cam_out%hsnow, pcols ,lchnk )!xxx debug + !call outfld("hrain_liq_ref" , cam_out%hrain, pcols ,lchnk )!xxx debug + !call outfld("hevap_liq_ref" , cam_out%hevap, pcols ,lchnk )!xxx debug + + cam_out%hmat(:ncol) = cam_out%hsnow(:ncol) + cam_out%hrain(:ncol) + cam_out%hevap(:ncol) !tht: this is into ocean +!+tht variable latent heat component +! N.B.: approximate due to difference between ts and tbot, also note lagged SST + cam_out%hlat(:ncol) = cam_in%evap_ocn(:ncol)*(cpliq-cpwv )*(cam_in%sst(:ncol)-t00a) & + -fice_tot (:ncol)*(cpliq-cpice)*(cam_in%sst(:ncol)-t00a) +!-tht + else + call get_prec_vars(ncol,pbuf,& + precc_out=cam_out%precc,precl_out=cam_out%precl,& + precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) + cam_out%hmat(:ncol) = 0._r8 + cam_out%hlat(:ncol) = 0._r8 + end if + + srf_ozone_idx = pbuf_get_index('SRFOZONE', errcode=i) + lightning_idx = pbuf_get_index('LGHT_FLASH_FREQ', errcode=i) + + do i=1,ncol + cam_out%tbot(i) = state%t(i,pver) + cam_out%thbot(i) = state%t(i,pver) * state%exner(i,pver) + cam_out%zbot(i) = state%zm(i,pver) + cam_out%topo(i) = state%phis(i) / gravit + cam_out%ubot(i) = state%u(i,pver) + cam_out%vbot(i) = state%v(i,pver) + cam_out%pbot(i) = state%pmid(i,pver) + cam_out%psl(i) = psl(i) + cam_out%rho(i) = cam_out%pbot(i)/(rair*cam_out%tbot(i)) + ! Direction of bottom level wind + ubot = state%u(i,pver) + vbot = state%v(i,pver) + if ((ubot == 0.0_r8) .and. (vbot == 0.0_r8)) then + cam_out%wind_dir(i) = 0.0_r8 ! Default to U for zero wind + else + cam_out%wind_dir(i) = atan2(vbot,ubot) + end if + end do + do m = 1, pcnst + do i = 1, ncol + cam_out%qbot(i,m) = state%q(i,pver,m) + end do + end do + + cam_out%co2diag(:ncol) = chem_surfvals_get('CO2VMR') * 1.0e+6_r8 + if (co2_transport()) then + do i=1,ncol + cam_out%co2prog(i) = state%q(i,pver,c_i(4)) * 1.0e+6_r8 *mwdry/mwco2 + end do + end if + + ! get bottom layer ozone concentrations to export to surface models + if (srf_ozone_idx > 0) then + call pbuf_get_field(pbuf, srf_ozone_idx, srf_o3_ptr) + cam_out%ozone(:ncol) = srf_o3_ptr(:ncol) + else if (.not.simple_phys) then + call rad_cnst_get_gas(0, 'O3', state, pbuf, o3_ptr) + cam_out%ozone(:ncol) = o3_ptr(:ncol,pver) * mwdry/mwo3 ! mole/mole + endif + + ! get cloud to ground lightning flash freq (/min) to export to surface models + if (lightning_idx>0) then + call pbuf_get_field(pbuf, lightning_idx, lightning_ptr) + cam_out%lightning_flash_freq(:ncol) = lightning_ptr(:ncol) + end if +end subroutine cam_export +! +! Precipation and snow rates from shallow convection, deep convection and stratiform processes. +! Compute total convective and stratiform precipitation and snow rates +! +subroutine get_prec_vars(ncol,pbuf,fliq,fice, precc_out,precl_out,precsc_out,precsl_out) + use ppgrid, only: pcols + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc + + integer, intent(in) :: ncol + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), dimension(pcols) , optional, intent(out):: fliq!rain flux (out of atm) in SI units + real(r8), dimension(pcols) , optional, intent(out):: fice!snow flux (out of atm) in SI units + + real(r8), dimension(pcols), optional, intent(out):: precc_out !total precipitation from convection + real(r8), dimension(pcols), optional, intent(out):: precl_out !total large scale precipitation + real(r8), dimension(pcols), optional, intent(out):: precsc_out!frozen precipitation from convection + real(r8), dimension(pcols), optional, intent(out):: precsl_out!frozen large scale precipitation + + integer :: i + + real(r8), pointer :: prec_dp(:) !total precipitation from from deep convection + real(r8), pointer :: snow_dp(:) !frozen precipitation from deep convection + real(r8), pointer :: prec_sh(:) !total precipitation from shallow convection + real(r8), pointer :: snow_sh(:) !frozen precipitation from from shallow convection + real(r8), pointer :: prec_sed(:) !total precipitation from cloud sedimentation + real(r8), pointer :: snow_sed(:) !frozen precipitation from sedimentation + real(r8), pointer :: prec_pcw(:) !total precipitation from from microphysics + real(r8), pointer :: snow_pcw(:) !frozen precipitation from from microphysics + + real(r8), dimension(pcols):: precc, precl, precsc, precsl + integer :: prec_dp_idx, snow_dp_idx, prec_sh_idx, snow_sh_idx + integer :: prec_sed_idx,snow_sed_idx,prec_pcw_idx,snow_pcw_idx + ! + ! get fields from pbuf + ! + prec_dp_idx = pbuf_get_index('PREC_DP', errcode=i) + snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=i) + prec_sh_idx = pbuf_get_index('PREC_SH', errcode=i) + snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=i) + prec_sed_idx = pbuf_get_index('PREC_SED', errcode=i) + snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=i) + prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=i) + snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=i) + + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) + end if + if (snow_dp_idx > 0) then + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) + end if + if (snow_sh_idx > 0) then + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) + end if + if (prec_sed_idx > 0) then + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) + end if + if (snow_sed_idx > 0) then + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) + end if + if (prec_pcw_idx > 0) then + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) + end if + if (snow_pcw_idx > 0) then + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) + end if + + precc = 0._r8 + precl = 0._r8 + precsc = 0._r8 + precsl = 0._r8 + if (prec_dp_idx > 0) then + precc(:ncol) = precc(:ncol) + prec_dp(:ncol) + end if + if (prec_sh_idx > 0) then + precc(:ncol) = precc(:ncol) + prec_sh(:ncol) + end if + if (prec_sed_idx > 0) then + precl(:ncol) = precl(1:ncol) + prec_sed(:ncol) + end if + if (prec_pcw_idx > 0) then + precl(:ncol) = precl(1:ncol) + prec_pcw(:ncol) + end if + if (snow_dp_idx > 0) then + precsc(:ncol) = precsc(:ncol) + snow_dp(:ncol) + end if + if (snow_sh_idx > 0) then + precsc(:ncol) = precsc(:ncol) + snow_sh(:ncol) + end if + if (snow_sed_idx > 0) then + precsl(:ncol) = precsl(:ncol) + snow_sed(:ncol) + end if + if (snow_pcw_idx > 0) then + precsl(:ncol)= precsl(:ncol) + snow_pcw(:ncol) + end if + + do i=1,ncol + precc(i) = MAX(precc(i), 0.0_r8) + precl(i) = MAX(precl(i), 0.0_r8) + precsc(i) = MAX(precsc(i),0.0_r8) + precsl(i) = MAX(precsl(i),0.0_r8) + if (precsc(i).gt.precc(i)) precsc(i)=precc(i) + if (precsl(i).gt.precl(i)) precsl(i)=precl(i) + end do + if (present(precc_out )) precc_out (:ncol) = precc (:ncol) + if (present(precl_out )) precl_out (:ncol) = precl (:ncol) + if (present(precsc_out)) precsc_out(:ncol) = precsc(:ncol) + if (present(precsl_out)) precsl_out(:ncol) = precsl(:ncol) + + if (present(fice)) fice(:ncol) = 1000.0_r8*(precsc(:ncol)+precsl(:ncol)) !snow flux + if (present(fliq)) fliq(:ncol) = 1000.0_r8*(precc (:ncol)-precsc(:ncol)+precl(:ncol)-precsl(:ncol))!rain flux + end subroutine get_prec_vars + +end module camsrfexch diff --git a/src/physics/camnor_phys/physics/check_energy.F90 b/src/physics/camnor_phys/physics/check_energy.F90 new file mode 100644 index 0000000000..427452e6b1 --- /dev/null +++ b/src/physics/camnor_phys/physics/check_energy.F90 @@ -0,0 +1,1195 @@ + +module check_energy + +!--------------------------------------------------------------------------------- +! Purpose: +! +! Module to check +! 1. vertically integrated total energy and water conservation for each +! column within the physical parameterizations +! +! 2. global mean total energy conservation between the physics output state +! and the input state on the next time step. +! +! 3. add a globally uniform heating term to account for any change of total energy in 2. +! +! Author: Byron Boville Oct 31, 2002 +! +! Modifications: +! 03.03.29 Boville Add global energy check and fixer. +! +! 25.06.14 Added formulation of enthalpy adjustment created by Peter Lauritzen (NCAR) and Thomas Toniazzo (Bjerknes Centre / NORCE) +! +!--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver, begchunk, endchunk + use spmd_utils, only: masterproc + + use gmean_mod, only: gmean + use physconst, only: gravit, rga, latvap, latice, cpair, rair + use air_composition, only: cpairv, cp_or_cv_dycore + use physics_types, only: physics_state, physics_tend, physics_ptend, physics_ptend_init + use constituents, only: cnst_get_ind, pcnst, cnst_name, cnst_get_type_byind + use time_manager, only: is_first_step + use cam_logfile, only: iulog + + implicit none + private + + ! Public types: + public check_tracers_data + + ! Public methods + public :: check_energy_readnl ! read namelist values + public :: check_energy_register ! register fields in physics buffer + public :: check_energy_get_integrals ! get energy integrals computed in check_energy_gmean + public :: check_energy_init ! initialization of module + public :: check_energy_timestep_init ! timestep initialization of energy integrals and cumulative boundary fluxes + public :: check_energy_cam_chng ! check changes in integrals against cumulative boundary fluxes + public :: check_energy_gmean ! global means of physics input and output total energy + public :: check_energy_cam_fix ! add heating rate required for global mean total energy conservation + public :: check_tracers_init ! initialize tracer integrals and cumulative boundary fluxes + public :: check_tracers_chng ! check changes in integrals against cumulative boundary fluxes + public :: tot_energy_phys ! calculate and output total energy and axial angular momentum diagnostics + + public :: enthalpy_adjustment !tht + + ! Private module data + logical :: print_energy_errors = .false. + + real(r8) :: teout_glob ! global mean energy of output state + real(r8) :: teinp_glob ! global mean energy of input state + real(r8) :: tedif_glob ! global mean energy difference + real(r8) :: psurf_glob ! global mean surface pressure + real(r8) :: ptopb_glob ! global mean top boundary pressure + real(r8) :: heat_glob ! global mean heating rate + + ! Physics buffer indices + + integer, public :: teout_idx = 0 ! teout index in physics buffer + integer, public :: dtcore_idx = 0 ! dtcore index in physics buffer + integer, public :: dqcore_idx = 0 ! dqcore index in physics buffer + integer, public :: ducore_idx = 0 ! ducore index in physics buffer + integer, public :: dvcore_idx = 0 ! dvcore index in physics buffer + + type check_tracers_data + real(r8) :: tracer(pcols,pcnst) ! initial vertically integrated total (kinetic + static) energy + real(r8) :: tracer_tnd(pcols,pcnst) ! cumulative boundary flux of total energy + integer :: count(pcnst) ! count of values with significant imbalances + end type check_tracers_data + + +!=============================================================================== +contains +!=============================================================================== + +subroutine check_energy_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_logical + use cam_abortutils, only: endrun + + ! update the CCPP-ized namelist option + use check_energy_chng, only: check_energy_chng_init + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: sub = 'check_energy_readnl' + + namelist /check_energy_nl/ print_energy_errors + !----------------------------------------------------------------------------- + + ! Read namelist + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'check_energy_nl', status=ierr) + if (ierr == 0) then + read(unitn, check_energy_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub//': FATAL: reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(print_energy_errors, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: print_energy_errors") + + if (masterproc) then + write(iulog,*) 'check_energy options:' + write(iulog,*) ' print_energy_errors =', print_energy_errors + end if + + ! update the CCPP-ized namelist option + call check_energy_chng_init(print_energy_errors_in=print_energy_errors) + +end subroutine check_energy_readnl + +!=============================================================================== + + subroutine check_energy_register() +! +! Register fields in the physics buffer. +! +!----------------------------------------------------------------------- + + use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls + use physics_buffer, only : pbuf_register_subcol + use subcol_utils, only : is_subcol_on + +!----------------------------------------------------------------------- + +! Request physics buffer space for fields that persist across timesteps. + + call pbuf_add_field('TEOUT', 'global',dtype_r8 , (/pcols,dyn_time_lvls/), teout_idx) + call pbuf_add_field('DTCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),dtcore_idx) + ! DQCORE refers to dycore tendency of water vapor + call pbuf_add_field('DQCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),dqcore_idx) + call pbuf_add_field('DUCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),ducore_idx) + call pbuf_add_field('DVCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),dvcore_idx) + if(is_subcol_on()) then + call pbuf_register_subcol('TEOUT', 'phys_register', teout_idx) + call pbuf_register_subcol('DTCORE', 'phys_register', dtcore_idx) + call pbuf_register_subcol('DQCORE', 'phys_register', dqcore_idx) + call pbuf_register_subcol('DUCORE', 'phys_register', ducore_idx) + call pbuf_register_subcol('DVCORE', 'phys_register', dvcore_idx) + end if + + end subroutine check_energy_register + + + subroutine check_energy_get_integrals(tedif_glob_out, heat_glob_out) + +!----------------------------------------------------------------------- +! Purpose: Return energy integrals +!----------------------------------------------------------------------- + + real(r8), intent(out), optional :: tedif_glob_out + real(r8), intent(out), optional :: heat_glob_out + + if ( present(tedif_glob_out) ) then + tedif_glob_out = tedif_glob + endif + + if ( present(heat_glob_out) ) then + heat_glob_out = heat_glob + endif + + end subroutine check_energy_get_integrals +!================================================================================================ + + subroutine check_energy_init() +! +! Initialize the energy conservation module +! +!----------------------------------------------------------------------- + use cam_history, only: addfld, add_default, horiz_only + use phys_control, only: phys_getopts + + implicit none + + logical :: history_budget, history_waccm + integer :: history_budget_histfile_num ! output history file number for budget fields + +!----------------------------------------------------------------------- + + call phys_getopts( history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm ) + +! register history variables + call addfld('TEINP', horiz_only, 'A', 'J/m2', 'Total energy of physics input') + call addfld('TEOUT', horiz_only, 'A', 'J/m2', 'Total energy of physics output') + call addfld('TEFIX', horiz_only, 'A', 'J/m2', 'Total energy after fixer') + call addfld('EFIX', horiz_only, 'A', 'W/m2', 'Effective sensible heat flux due to energy fixer') + call addfld('DTCORE', (/ 'lev' /), 'A', 'K/s' , 'T tendency due to dynamical core') + call addfld('DQCORE', (/ 'lev' /), 'A', 'kg/kg/s' , 'Water vapor tendency due to dynamical core') + + if ( history_budget ) then + call add_default ('DTCORE', history_budget_histfile_num, ' ') + end if + if ( history_waccm ) then + call add_default ('DTCORE', 1, ' ') + end if + + end subroutine check_energy_init + +!=============================================================================== + subroutine check_energy_timestep_init(state, tend, pbuf, col_type) + use physics_buffer, only: physics_buffer_desc, pbuf_set_field + use cam_abortutils, only: endrun + use dyn_tests_utils, only: vc_physics, vc_dycore + use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS + use physics_types, only: phys_te_idx, dyn_te_idx + + ! CCPP-ized subroutine + use check_energy_chng, only: check_energy_chng_timestep_init + + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + integer, optional :: col_type ! Flag indicating whether using grid or subcolumns + + real(r8) :: local_cp_phys(state%psetcols,pver) + real(r8) :: local_cp_or_cv_dycore(state%psetcols,pver) + real(r8) :: teout(state%ncol) ! dummy teout argument + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + character(len=512) :: errmsg + integer :: errflg + + lchnk = state%lchnk + ncol = state%ncol + + ! The code below is split into not-subcolumns and subcolumns code, as there is different handling of the + ! cp passed into the hydrostatic energy call. CAM-SIMA does not support subcolumns, so we keep this special + ! handling inside this CAM interface. (hplin, 9/9/24) + + if(state%psetcols == pcols) then + ! No subcolumns + local_cp_phys(:ncol,:) = cpairv(:ncol,:,lchnk) + local_cp_or_cv_dycore(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) + else if (state%psetcols > pcols) then + ! Subcolumns code + ! Subcolumns specific error handling + if(.not. all(cpairv(:,:,lchnk) == cpair)) then + call endrun('check_energy_timestep_init: cpairv is not allowed to vary when subcolumns are turned on') + endif + + local_cp_phys(1:ncol,:) = cpair + + if (vc_dycore == ENERGY_FORMULA_DYCORE_MPAS) then + ! MPAS specific hydrostatic energy computation (internal energy) + local_cp_or_cv_dycore(:ncol,:) = cpair-rair + else if(vc_dycore == ENERGY_FORMULA_DYCORE_SE) then + ! SE specific hydrostatic energy (enthalpy) + local_cp_or_cv_dycore(:ncol,:) = cpair + else + ! cp_or_cv is not used in the underlying subroutine, zero it out to be sure + local_cp_or_cv_dycore(:ncol,:) = 0.0_r8 + endif + end if + + ! Call CCPP-ized underlying subroutine. + call check_energy_chng_timestep_init( & + ncol = ncol, & + pver = pver, & + pcnst = pcnst, & + is_first_timestep = is_first_step(), & + q = state%q(1:ncol,1:pver,1:pcnst), & + pdel = state%pdel(1:ncol,1:pver), & + u = state%u(1:ncol,1:pver), & + v = state%v(1:ncol,1:pver), & + T = state%T(1:ncol,1:pver), & + pintdry = state%pintdry(1:ncol,1:pver), & + phis = state%phis(1:ncol), & + zm = state%zm(1:ncol,:), & + cp_phys = local_cp_phys(1:ncol,:), & + cp_or_cv_dycore = local_cp_or_cv_dycore(1:ncol,:), & + te_ini_phys = state%te_ini(1:ncol,phys_te_idx), & + te_ini_dyn = state%te_ini(1:ncol,dyn_te_idx), & + tw_ini = state%tw_ini(1:ncol), & + te_cur_phys = state%te_cur(1:ncol,phys_te_idx), & + te_cur_dyn = state%te_cur(1:ncol,dyn_te_idx), & + tw_cur = state%tw_cur(1:ncol), & + tend_te_tnd = tend%te_tnd(1:ncol), & + tend_tw_tnd = tend%tw_tnd(1:ncol), & + temp_ini = state%temp_ini(:ncol,:), & + z_ini = state%z_ini(:ncol,:), & + count = state%count, & + teout = teout(1:ncol), & ! dummy argument - actual teout written to pbuf directly below + energy_formula_physics = vc_physics, & + energy_formula_dycore = vc_dycore, & + errmsg = errmsg, & + errflg = errflg & + ) + + ! initialize physics buffer + if (is_first_step()) then + call pbuf_set_field(pbuf, teout_idx, state%te_ini(:,dyn_te_idx), col_type=col_type) + end if + + end subroutine check_energy_timestep_init + + + subroutine check_energy_cam_chng(state, tend, name, nstep, ztodt, & + flx_vap, flx_cnd, flx_ice, flx_sen) + use dyn_tests_utils, only: vc_physics, vc_dycore + use cam_abortutils, only: endrun + use physics_types, only: phys_te_idx, dyn_te_idx + use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS + use check_energy_chng, only: check_energy_chng_run + + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + character*(*),intent(in) :: name ! parameterization name for fluxes + integer , intent(in) :: nstep ! current timestep number + real(r8), intent(in) :: ztodt ! physics timestep (s) + real(r8), intent(in) :: flx_vap(:) ! (pcols) - boundary flux of vapor (kg/m2/s) + real(r8), intent(in) :: flx_cnd(:) ! (pcols) - boundary flux of lwe liquid+ice (m/s) + real(r8), intent(in) :: flx_ice(:) ! (pcols) - boundary flux of lwe ice (m/s) + real(r8), intent(in) :: flx_sen(:) ! (pcols) - boundary flux of sensible heat (W/m2) + + real(r8) :: local_cp_phys(state%psetcols,pver) + real(r8) :: local_cp_or_cv_dycore(state%psetcols,pver) + real(r8) :: scaling_dycore(state%ncol,pver) + character(len=512) :: errmsg + integer :: errflg + + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + + lchnk = state%lchnk + ncol = state%ncol + + if(state%psetcols == pcols) then + ! No subcolumns + local_cp_phys(:ncol,:) = cpairv(:ncol,:,lchnk) + + ! Only if using MPAS or SE energy formula cp_or_cv_dycore is nonzero. + if(vc_dycore == ENERGY_FORMULA_DYCORE_MPAS .or. vc_dycore == ENERGY_FORMULA_DYCORE_SE) then + local_cp_or_cv_dycore(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) + + scaling_dycore(:ncol,:) = cpairv(:ncol,:,lchnk)/local_cp_or_cv_dycore(:ncol,:) ! cp/cv scaling + endif + else if(state%psetcols > pcols) then + ! Subcolumns + if(.not. all(cpairv(:,:,:) == cpair)) then + call endrun('check_energy_chng: cpairv is not allowed to vary when subcolumns are turned on') + endif + local_cp_phys(:,:) = cpair + ! Note: cp_or_cv set above for pressure coordinate + if (vc_dycore == ENERGY_FORMULA_DYCORE_MPAS) then + ! compute cv if vertical coordinate is height: cv = cp - R + local_cp_or_cv_dycore(:ncol,:) = cpair-rair + scaling_dycore(:ncol,:) = cpairv(:ncol,:,lchnk)/local_cp_or_cv_dycore(:ncol,:) ! cp/cv scaling + else if (vc_dycore == ENERGY_FORMULA_DYCORE_SE) then + ! SE specific hydrostatic energy + local_cp_or_cv_dycore(:ncol,:) = cpair + scaling_dycore(:ncol,:) = 1.0_r8 + else + ! Moist pressure... use phys formula, cp_or_cv_dycore is unused. Reset for safety + local_cp_or_cv_dycore(:ncol,:) = 0.0_r8 + scaling_dycore(:ncol,:) = 0.0_r8 + end if + endif + + ! Call CCPP-ized underlying subroutine. + call check_energy_chng_run(nstep,lchnk,masterproc, & + ncol = ncol, & + pver = pver, & + pcnst = pcnst, & + iulog = iulog, & + q = state%q(1:ncol,1:pver,1:pcnst), & + pdel = state%pdel(1:ncol,1:pver), & + u = state%u(1:ncol,1:pver), & + v = state%v(1:ncol,1:pver), & + T = state%T(1:ncol,1:pver), & + pintdry = state%pintdry(1:ncol,1:pver), & + phis = state%phis(1:ncol), & + zm = state%zm(1:ncol,:), & + cp_phys = local_cp_phys(1:ncol,:), & + cp_or_cv_dycore = local_cp_or_cv_dycore(1:ncol,:), & + scaling_dycore = scaling_dycore(1:ncol,:), & + te_cur_phys = state%te_cur(1:ncol,phys_te_idx), & + te_cur_dyn = state%te_cur(1:ncol,dyn_te_idx), & + tw_cur = state%tw_cur(1:ncol), & + tend_te_tnd = tend%te_tnd(1:ncol), & + tend_tw_tnd = tend%tw_tnd(1:ncol), & + temp_ini = state%temp_ini(:ncol,:), & + z_ini = state%z_ini(:ncol,:), & + count = state%count, & + ztodt = ztodt, & + latice = latice, & + latvap = latvap, & + energy_formula_physics = vc_physics, & + energy_formula_dycore = vc_dycore, & + name = name, & + flx_vap = flx_vap, & + flx_cnd = flx_cnd, & + flx_ice = flx_ice, & + flx_sen = flx_sen, & + errmsg = errmsg, & + errflg = errflg & + ) + + end subroutine check_energy_cam_chng + + subroutine check_energy_gmean(state, pbuf2d, dtime, nstep) + + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_chunk + use physics_types, only: dyn_te_idx + + type(physics_state), intent(in), dimension(begchunk:endchunk) :: state + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + real(r8), intent(in) :: dtime ! physics time step + integer , intent(in) :: nstep ! current timestep number + + integer :: ncol ! number of active columns + integer :: lchnk ! chunk index + + real(r8) :: te(pcols,begchunk:endchunk,4) + ! total energy of input/output states (copy) + real(r8) :: te_glob(4) ! global means of total energy + real(r8), pointer :: teout(:) + + ! Copy total energy out of input and output states + do lchnk = begchunk, endchunk + ncol = state(lchnk)%ncol + ! input energy using dynamical core energy formula + te(:ncol,lchnk,1) = state(lchnk)%te_ini(:ncol,dyn_te_idx) + ! output energy + call pbuf_get_field(pbuf_get_chunk(pbuf2d,lchnk),teout_idx, teout) + + te(:ncol,lchnk,2) = teout(1:ncol) + ! surface pressure for heating rate + te(:ncol,lchnk,3) = state(lchnk)%pint(:ncol,pver+1) + ! model top pressure for heating rate (not constant for z-based vertical coordinate!) + te(:ncol,lchnk,4) = state(lchnk)%pint(:ncol,1) + end do + + ! Compute global means of input and output energies and of + ! surface pressure for heating rate (assume uniform ptop) + call gmean(te, te_glob, 4) + + if (begchunk .le. endchunk) then + teinp_glob = te_glob(1) + teout_glob = te_glob(2) + psurf_glob = te_glob(3) + ptopb_glob = te_glob(4) + + ! Global mean total energy difference + tedif_glob = teinp_glob - teout_glob + heat_glob = -tedif_glob/dtime * gravit / (psurf_glob - ptopb_glob) + if (masterproc) then + write(iulog,'(1x,a9,1x,i8,5(1x,e25.17))') "nstep, te", nstep, teinp_glob, teout_glob, & + heat_glob, psurf_glob, ptopb_glob + end if + else + heat_glob = 0._r8 + end if ! (begchunk .le. endchunk) + + end subroutine check_energy_gmean + +!=============================================================================== + subroutine check_energy_cam_fix(state, ptend, nstep, eshflx) + ! Add heating rate required for global mean total energy conservation + + ! SCAM support + use scamMod, only: single_column, use_camiop, heat_glob_scm + use cam_history, only: write_camiop + use cam_history, only: outfld + + ! CCPP-ized subroutine + use check_energy_fix, only: check_energy_fix_run + + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend + + integer , intent(in) :: nstep ! time step number + real(r8), intent(out) :: eshflx(pcols) ! effective sensible heat flux + + integer :: ncol ! number of atmospheric columns in chunk + integer :: lchnk ! chunk number + real(r8) :: heat_out(pcols) + character(len=64) :: dummy_scheme_name ! dummy scheme name for CCPP-ized scheme + + integer :: errflg + character(len=512) :: errmsg + + lchnk = state%lchnk + ncol = state%ncol + + call physics_ptend_init(ptend, state%psetcols, 'chkenergyfix', ls=.true.) + +#if ( defined OFFLINE_DYN ) + ! disable the energy fix for offline driver + heat_glob = 0._r8 +#endif + + ! Special handling of energy fix for SCAM - supplied via CAMIOP - zero's for normal IOPs + if (single_column) then + if (use_camiop) then + heat_glob = heat_glob_scm(1) + else + heat_glob = 0._r8 + endif + endif + + if (nstep > 0 .and. write_camiop) then + heat_out(:ncol) = heat_glob + call outfld('heat_glob', heat_out(:ncol), pcols, lchnk) + endif + + ! Call the CCPP-ized subroutine (for non-SCAM) + ! to compute the effective sensible heat flux and save to ptend%s + call check_energy_fix_run( & + ncol = ncol, & + pver = pver, & + pint = state%pint(:ncol,:), & + gravit = gravit, & + heat_glob = heat_glob, & + ptend_s = ptend%s(:ncol,:), & + eshflx = eshflx(:ncol), & + scheme_name = dummy_scheme_name, & + errmsg = errmsg, & + errflg = errflg & + ) + + end subroutine check_energy_cam_fix + subroutine check_tracers_init(state, tracerint) + +!----------------------------------------------------------------------- +! Compute initial values of tracers integrals, +! zero cumulative tendencies +!----------------------------------------------------------------------- + +!------------------------------Arguments-------------------------------- + + type(physics_state), intent(in) :: state + type(check_tracers_data), intent(out) :: tracerint + +!---------------------------Local storage------------------------------- + + real(r8) :: tr(pcols) ! vertical integral of tracer + real(r8) :: trpdel(pcols, pver) ! pdel for tracer + + integer ncol ! number of atmospheric columns + integer i,k,m ! column, level,constituent indices + integer :: ixcldice, ixcldliq ! CLDICE and CLDLIQ indices + integer :: ixrain, ixsnow ! RAINQM and SNOWQM indices + integer :: ixgrau ! GRAUQM index +!----------------------------------------------------------------------- + + ncol = state%ncol + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('RAINQM', ixrain, abort=.false.) + call cnst_get_ind('SNOWQM', ixsnow, abort=.false.) + call cnst_get_ind('GRAUQM', ixgrau, abort=.false.) + + + do m = 1,pcnst + + if ( any(m == (/ 1, ixcldliq, ixcldice, & + ixrain, ixsnow, ixgrau /)) ) exit ! dont process water substances + ! they are checked in check_energy + + if (cnst_get_type_byind(m).eq.'dry') then + trpdel(:ncol,:) = state%pdeldry(:ncol,:) + else + trpdel(:ncol,:) = state%pdel(:ncol,:) + endif + + ! Compute vertical integrals of tracer + tr = 0._r8 + do k = 1, pver + do i = 1, ncol + tr(i) = tr(i) + state%q(i,k,m)*trpdel(i,k)*rga + end do + end do + + ! Compute vertical integrals of frozen static tracers and total water. + do i = 1, ncol + tracerint%tracer(i,m) = tr(i) + end do + + ! zero cummulative boundary fluxes + tracerint%tracer_tnd(:ncol,m) = 0._r8 + + tracerint%count(m) = 0 + + end do + + return + end subroutine check_tracers_init + +!=============================================================================== + subroutine check_tracers_chng(state, tracerint, name, nstep, ztodt, cflx) + +!----------------------------------------------------------------------- +! Check that the tracers and water change matches the boundary fluxes +! these checks are not save when there are tracers transformations, as +! they only check to see whether a mass change in the column is +! associated with a flux +!----------------------------------------------------------------------- + + use cam_abortutils, only: endrun + + + implicit none + +!------------------------------Arguments-------------------------------- + + type(physics_state) , intent(in ) :: state + type(check_tracers_data), intent(inout) :: tracerint! tracers integrals and boundary fluxes + character*(*),intent(in) :: name ! parameterization name for fluxes + integer , intent(in ) :: nstep ! current timestep number + real(r8), intent(in ) :: ztodt ! 2 delta t (model time increment) + real(r8), intent(in ) :: cflx(pcols,pcnst) ! boundary flux of tracers (kg/m2/s) + +!---------------------------Local storage------------------------------- + + real(r8) :: tracer_inp(pcols,pcnst) ! total tracer of new (input) state + real(r8) :: tracer_xpd(pcols,pcnst) ! expected value (w0 + dt*boundary_flux) + real(r8) :: tracer_dif(pcols,pcnst) ! tracer_inp - original tracer + real(r8) :: tracer_tnd(pcols,pcnst) ! tendency from last process + real(r8) :: tracer_rer(pcols,pcnst) ! relative error in tracer column + + real(r8) :: tr(pcols) ! vertical integral of tracer + real(r8) :: trpdel(pcols, pver) ! pdel for tracer + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + integer i,k ! column, level indices + integer :: ixcldice, ixcldliq ! CLDICE and CLDLIQ indices + integer :: ixrain, ixsnow ! RAINQM and SNOWQM indices + integer :: ixgrau ! GRAUQM index + integer :: m ! tracer index + character(len=8) :: tracname ! tracername +!----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('RAINQM', ixrain, abort=.false.) + call cnst_get_ind('SNOWQM', ixsnow, abort=.false.) + call cnst_get_ind('GRAUQM', ixgrau, abort=.false.) + + do m = 1,pcnst + + if ( any(m == (/ 1, ixcldliq, ixcldice, & + ixrain, ixsnow, ixgrau /)) ) exit ! dont process water substances + ! they are checked in check_energy + tracname = cnst_name(m) + if (cnst_get_type_byind(m).eq.'dry') then + trpdel(:ncol,:) = state%pdeldry(:ncol,:) + else + trpdel(:ncol,:) = state%pdel(:ncol,:) + endif + + ! Compute vertical integrals tracers + tr = 0._r8 + do k = 1, pver + do i = 1, ncol + tr(i) = tr(i) + state%q(i,k,m)*trpdel(i,k)*rga + end do + end do + + ! Compute vertical integrals of tracer + do i = 1, ncol + tracer_inp(i,m) = tr(i) + end do + + ! compute expected values and tendencies + do i = 1, ncol + ! change in tracers + tracer_dif(i,m) = tracer_inp(i,m) - tracerint%tracer(i,m) + + ! expected tendencies from boundary fluxes for last process + tracer_tnd(i,m) = cflx(i,m) + + ! cummulative tendencies from boundary fluxes + tracerint%tracer_tnd(i,m) = tracerint%tracer_tnd(i,m) + tracer_tnd(i,m) + + ! expected new values from original values plus boundary fluxes + tracer_xpd(i,m) = tracerint%tracer(i,m) + tracerint%tracer_tnd(i,m)*ztodt + + ! relative error, expected value - input value / original + tracer_rer(i,m) = (tracer_xpd(i,m) - tracer_inp(i,m)) / tracerint%tracer(i,m) + end do + +!! final loop for error checking +! do i = 1, ncol + +!! error messages +! if (abs(enrgy_rer(i)) > 1.E-14 .or. abs(water_rer(i)) > 1.E-14) then +! tracerint%count = tracerint%count + 1 +! write(iulog,*) "significant conservations error after ", name, & +! " count", tracerint%count, " nstep", nstep, "chunk", lchnk, "col", i +! write(iulog,*) enrgy_inp(i),enrgy_xpd(i),enrgy_dif(i),tracerint%enrgy_tnd(i)*ztodt, & +! enrgy_tnd(i)*ztodt,enrgy_rer(i) +! write(iulog,*) water_inp(i),water_xpd(i),water_dif(i),tracerint%water_tnd(i)*ztodt, & +! water_tnd(i)*ztodt,water_rer(i) +! end if +! end do + + + ! final loop for error checking + if ( maxval(tracer_rer) > 1.E-14_r8 ) then + write(iulog,*) "CHECK_TRACERS TRACER large rel error" + write(iulog,*) tracer_rer + endif + + do i = 1, ncol + ! error messages + if (abs(tracer_rer(i,m)) > 1.E-14_r8 ) then + tracerint%count = tracerint%count + 1 + write(iulog,*) "CHECK_TRACERS TRACER significant conservation error after ", name, & + " count", tracerint%count, " nstep", nstep, "chunk", lchnk, "col",i + write(iulog,*)' process name, tracname, index ', name, tracname, m + write(iulog,*)" input integral ",tracer_inp(i,m) + write(iulog,*)" expected integral ", tracer_xpd(i,m) + write(iulog,*)" input - inital integral ",tracer_dif(i,m) + write(iulog,*)" cumulative tend ",tracerint%tracer_tnd(i,m)*ztodt + write(iulog,*)" process tend ",tracer_tnd(i,m)*ztodt + write(iulog,*)" relative error ",tracer_rer(i,m) + call endrun() + end if + end do + end do + + return + end subroutine check_tracers_chng + +!####################################################################### + + subroutine tot_energy_phys(state, outfld_name_suffix,vc) + use physconst, only: rga,rearth,omega + use cam_thermo, only: get_hydrostatic_energy,thermo_budget_num_vars,thermo_budget_vars, & + wvidx,wlidx,wiidx,seidx,poidx,keidx,moidx,mridx,ttidx,teidx + use cam_history, only: outfld + use dyn_tests_utils, only: vc_physics + use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS + + use cam_abortutils, only: endrun + use cam_history_support, only: max_fieldname_len + use cam_budget, only: thermo_budget_history +!------------------------------Arguments-------------------------------- + + type(physics_state), intent(inout) :: state + character(len=*), intent(in) :: outfld_name_suffix ! suffix for "outfld" + integer, optional, intent(in) :: vc ! vertical coordinate (controls energy formula to use) + +!---------------------------Local storage------------------------------- + real(r8) :: se(pcols) ! Dry Static energy (J/m2) + real(r8) :: po(pcols) ! surface potential or potential energy (J/m2) + real(r8) :: ke(pcols) ! kinetic energy (J/m2) + real(r8) :: wv(pcols) ! column integrated vapor (kg/m2) + real(r8) :: liq(pcols) ! column integrated liquid (kg/m2) + real(r8) :: ice(pcols) ! column integrated ice (kg/m2) + real(r8) :: tt(pcols) ! column integrated test tracer (kg/m2) + real(r8) :: mr(pcols) ! column integrated wind axial angular momentum (kg*m2/s) + real(r8) :: mo(pcols) ! column integrated mass axial angular momentum (kg*m2/s) + real(r8) :: tt_tmp,mr_tmp,mo_tmp,cos_lat + real(r8) :: mr_cnst, mo_cnst + real(r8) :: cp_or_cv(pcols,pver) ! cp for pressure-based vcoord and cv for height vcoord + real(r8) :: temp(pcols,pver) ! temperature + real(r8) :: scaling(pcols,pver) ! scaling for conversion of temperature increment + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k ! column, level indices + integer :: vc_loc ! local vertical coordinate variable + integer :: ixtt ! test tracer index + character(len=max_fieldname_len) :: name_out(thermo_budget_num_vars) + +!----------------------------------------------------------------------- + + if (.not.thermo_budget_history) return + + do i=1,thermo_budget_num_vars + name_out(i)=trim(thermo_budget_vars(i))//'_'//trim(outfld_name_suffix) + end do + + lchnk = state%lchnk + ncol = state%ncol + + ! The "vertical coordinate" parameter is equivalent to the dynamical core + ! energy formula parameter, which controls the dycore energy formula used + ! by get_hydrostatic_energy. + if (present(vc)) then + vc_loc = vc + else + vc_loc = vc_physics + end if + + if (state%psetcols == pcols) then + if (vc_loc == ENERGY_FORMULA_DYCORE_MPAS .or. vc_loc == ENERGY_FORMULA_DYCORE_SE) then + cp_or_cv(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) + else + cp_or_cv(:ncol,:) = cpairv(:ncol,:,lchnk) + end if + else + call endrun('tot_energy_phys: energy diagnostics not implemented/tested for subcolumns') + end if + + if (vc_loc == ENERGY_FORMULA_DYCORE_MPAS .or. vc_loc == ENERGY_FORMULA_DYCORE_SE) then + scaling(:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv(:ncol,:)!scaling for energy consistency + else + scaling(:ncol,:) = 1.0_r8 !internal energy / enthalpy same as CAM physics + end if + ! scale accumulated temperature increment for internal energy / enthalpy consistency + temp(1:ncol,:) = state%temp_ini(1:ncol,:)+scaling(1:ncol,:)*(state%T(1:ncol,:)- state%temp_ini(1:ncol,:)) + call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & + state%pdel(1:ncol,1:pver), cp_or_cv(1:ncol,1:pver), & + state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), temp(1:ncol,1:pver), & + vc_loc, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & + z_mid = state%z_ini(1:ncol,:), se = se(1:ncol), & + po = po(1:ncol), ke = ke(1:ncol), wv = wv(1:ncol), liq = liq(1:ncol), & + ice = ice(1:ncol)) + + call cnst_get_ind('TT_LW' , ixtt , abort=.false.) + tt = 0._r8 + if (ixtt > 1) then + if (name_out(ttidx) == 'TT_pAM'.or.name_out(ttidx) == 'TT_zAM') then + ! + ! after dme_adjust mixing ratios are all wet + ! + do k = 1, pver + do i = 1, ncol + tt_tmp = state%q(i,k,ixtt)*state%pdel(i,k)*rga + tt (i) = tt(i) + tt_tmp + end do + end do + else + do k = 1, pver + do i = 1, ncol + tt_tmp = state%q(i,k,ixtt)*state%pdeldry(i,k)*rga + tt (i) = tt(i) + tt_tmp + end do + end do + end if + end if + + call outfld(name_out(seidx) ,se , pcols ,lchnk ) + call outfld(name_out(poidx) ,po , pcols ,lchnk ) + call outfld(name_out(keidx) ,ke , pcols ,lchnk ) + call outfld(name_out(wvidx) ,wv , pcols ,lchnk ) + call outfld(name_out(wlidx) ,liq , pcols ,lchnk ) + call outfld(name_out(wiidx) ,ice , pcols ,lchnk ) + call outfld(name_out(ttidx) ,tt , pcols ,lchnk ) + call outfld(name_out(teidx) ,se+ke+po, pcols ,lchnk ) + ! + ! Axial angular momentum diagnostics + ! + ! Code follows + ! + ! Lauritzen et al., (2014): Held-Suarez simulations with the Community Atmosphere Model + ! Spectral Element (CAM-SE) dynamical core: A global axial angularmomentum analysis using Eulerian + ! and floating Lagrangian vertical coordinates. J. Adv. Model. Earth Syst. 6,129-140, + ! doi:10.1002/2013MS000268 + ! + ! MR is equation (6) without \Delta A and sum over areas (areas are in units of radians**2) + ! MO is equation (7) without \Delta A and sum over areas (areas are in units of radians**2) + ! + + mr_cnst = rga*rearth**3 + mo_cnst = rga*omega*rearth**4 + + mr = 0.0_r8 + mo = 0.0_r8 + do k = 1, pver + do i = 1, ncol + cos_lat = cos(state%lat(i)) + mr_tmp = mr_cnst*state%u(i,k)*state%pdel(i,k)*cos_lat + mo_tmp = mo_cnst*state%pdel(i,k)*cos_lat**2 + + mr(i) = mr(i) + mr_tmp + mo(i) = mo(i) + mo_tmp + end do + end do + + call outfld(name_out(mridx) ,mr, pcols,lchnk ) + call outfld(name_out(moidx) ,mo, pcols,lchnk ) + + end subroutine tot_energy_phys + + subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, itim_old,& + qini,totliqini,toticeini,tend) + use camsrfexch, only: cam_in_t, cam_out_t, get_prec_vars + use physics_buffer, only: pbuf_get_index, physics_buffer_desc, pbuf_set_field, pbuf_get_field + use cam_abortutils, only: endrun + use air_composition, only: hliq_idx, hice_idx, fliq_idx, fice_idx, num_enthalpy_vars + use air_composition, only: cpairv, cp_or_cv_dycore, te_init + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a !+tht + use physconst, only: rga, latvap, latice + use dyn_tests_utils, only: vc_dycore + use cam_thermo, only: get_hydrostatic_energy + use physics_types, only: physics_dme_adjust, dyn_te_idx + use cam_thermo, only: cam_thermo_water_update + use cam_history, only: outfld + use cam_budget, only: thermo_budget_history + use time_manager, only: get_nstep + integer, intent(in) :: ncol, lchnk + type(physics_state), intent(inout) :: state + type(cam_in_t), intent(in ) :: cam_in + type(cam_out_t), intent(inout) :: cam_out + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: ztodt + integer, intent(in) :: itim_old + real(r8), dimension(pcols,pver), intent(in) :: qini, totliqini, toticeini + type(physics_tend ) , intent(inout) :: tend + + integer:: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx + real(r8), dimension(:,:), pointer :: enthalpy_prec_bc + real(r8), dimension(pcols,num_enthalpy_vars) :: enthalpy_prec_ac + real(r8), dimension(pcols) :: fliq_tot, fice_tot + + integer:: dp_ntprp_idx, dp_ntsnp_idx + real(r8), dimension(:,:), pointer :: dp_ntprp, dp_ntsnp + integer:: qrain_mg_idx,qsnow_mg_idx + real(r8), dimension(:,:), pointer :: qrain_mg, qsnow_mg + + real(r8), dimension(pcols) :: te , se , po , ke + real(r8), dimension(pcols) :: te_endphys, se_endphys, po_endphys, ke_endphys + real(r8), dimension(pcols) :: te_dme , se_dme , po_dme , ke_dme + real(r8), dimension(pcols) :: te_enth_fix , se_enth_fix , po_enth_fix , ke_enth_fix + real(r8), dimension(pcols) :: fct_bc_tot, fct_ac_tot + real(r8), dimension(pcols) :: enthalpy_heating_fix_bc, enthalpy_heating_fix_ac + + real(r8), dimension(pcols) :: dEdt_physics + real(r8), dimension(pcols) :: dEdt_dme + real(r8), dimension(pcols) :: dEdt_cpdycore + real(r8), dimension(pcols) :: dEdt_enth_fix, dEdt_efix + real(r8), dimension(pcols) :: constant_latent_heat_surface !xxx diagnostics + real(r8), dimension(pcols) :: variable_latent_heat_surface_cpice_term !xxx diagnostics + real(r8), dimension(pcols) :: variable_latent_heat_surface_ls_term !xxx diagnostics + real(r8), dimension(pcols) :: variable_latent_heat_surface_lf_term !xxx diagnostics + real(r8), dimension(pcols) :: enthalpy_flux_atm, enthalpy_flux_ocn !tht + real(r8), dimension(pcols,pver) :: tmp_t, pdel_rf, qinp, totliqinp, toticeinp + real(r8), dimension(pcols) :: zero, dsema, dcp_heat, iedme + real(r8), dimension(pcols) :: water_flux_bc, water_flux_ac, enthalpy_flux_bc, enthalpy_flux_ac + real(r8), dimension(pcols) :: eflx_out + real(r8), dimension(pcols) :: mflx_out + real(r8), dimension(pcols) :: hevap_atm, hevap_ocn + real(r8), dimension(pcols) :: tevp, tprc, nocnfrc + + real(r8), dimension(pcols,pver) :: rnsrc_pbc, snsrc_pbc + real(r8), dimension(pcols,pver) :: rnsrc_pac, snsrc_pac + real(r8), dimension(pcols,pver) :: rnsrc_tot, snsrc_tot + real(r8), dimension(pcols) :: watrerr,rainerr,snowerr + + integer nstep, ixq, m, m_cnst + real(r8), dimension(pcols,pver) :: fct_bc, fct_ac + real(r8), dimension(pcols,pver) :: scale_cpdry_cpdycore, ttend_hfix + + real(r8), parameter :: eps=1.E-10_r8 + + logical, parameter :: debug=.true. + + integer :: i, k + real(r8):: tot, wgt_bc, wgt_ac +!---- + + nstep = get_nstep() + zero(:)=0._r8 + + ! scale temperature for consistency with dycore (tht: partial adj. after cp update done implicitly in dme) + do k = 1, pver + do i = 1, ncol + scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) + state%T (i,k) = state%temp_ini(i,k)+scale_cpdry_cpdycore(i,k)*(state%T(i,k)- state%temp_ini(i,k)) + tend%dtdt(i,k) = scale_cpdry_cpdycore(i,k)*tend%dtdt(i,k) + end do + end do + + !------------------------------------------------------------------------------------------- + ! from this point onwards computation consistent with variable latent heat total energy formula + ! Equation 78 in https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2022MS003117 + !------------------------------------------------------------------------------------------- + + !=== start computation of material enthalpy fluxes === + ! evaporation enthalpy flux + enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP' , errcode=i) + if (enthalpy_evop_idx==0) then + call endrun("pbufs for enthalpy evap flux not allocated") + end if + ! using merged quantities, for atmospheric mat.enthalpy flux (used in check_energy) + if (minval(cam_in%ts(:ncol)).gt.0._r8) then + hevap_atm(:ncol) = cam_in%cflx (:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm + !tht: add non-linear terms? using evap_ocn, sst + nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) + where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large + hevap_atm(:ncol)= hevap_atm(:ncol) & + + cpwv & + *(1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & + *(cam_in%cflx(:ncol,1)-cam_in%evap_ocn(:ncol)) & + *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) + tevp (:ncol)= cam_in%ts(:ncol) & + + (1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & + *(1._r8-cam_in%evap_ocn(:ncol)/cam_in%cflx(:ncol,1))& + *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) + elsewhere + tevp (:ncol)= cam_in%ts(:ncol) + endwhere + !tht: for ocean-only mat.enthalpy flux (passed to ocean) + hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) + else ! not great but better than zeros + hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm + tevp (:ncol)= state%t(:ncol,pver) + hevap_ocn (:ncol)= hevap_atm(:ncol) ! out of ocn + endif + call pbuf_set_field(pbuf, enthalpy_evop_idx, hevap_ocn) + + !------------------------------------------------------------------ + ! compute precipitation fluxes and set associated physics buffers + !------------------------------------------------------------------ + enthalpy_prec_bc_idx = pbuf_get_index('ENTHALPY_PREC_BC', errcode=i) + enthalpy_prec_ac_idx = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) + if (enthalpy_prec_bc_idx==0.or.enthalpy_prec_ac_idx==0) then + call endrun("pbufs for enthalpy precip flux not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) + call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot) + ! fliq_tot holds liquid precipitation from tphysbc and tphysac; idem for ice + enthalpy_prec_ac(:ncol,fice_idx) = fice_tot(:ncol)-enthalpy_prec_bc(:ncol,fice_idx) + enthalpy_prec_ac(:ncol,fliq_idx) = fliq_tot(:ncol)-enthalpy_prec_bc(:ncol,fliq_idx) + + ! compute precipitation enthalpy fluxes from tphysbc + tprc (:ncol) = cam_out%tbot(:ncol) + !tht: correct for reference T of latent heats (liquid reference state) + enthalpy_prec_ac(:ncol,hice_idx) = -enthalpy_prec_ac(:ncol,fice_idx)*(cpice*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) + enthalpy_prec_ac(:ncol,hliq_idx) = -enthalpy_prec_ac(:ncol,fliq_idx)*(cpliq*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) + call pbuf_set_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) + + ! compute total enthalpy flux + enthalpy_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) + enthalpy_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + +hevap_atm (:ncol) + water_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,fliq_idx)+enthalpy_prec_bc(:ncol,fice_idx) + water_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,fliq_idx)+enthalpy_prec_ac(:ncol,fice_idx) & + -cam_in%cflx(:ncol,1) + enthalpy_flux_atm(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & + +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + +hevap_atm (:ncol) + enthalpy_flux_ocn(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & + +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + +hevap_ocn (:ncol) + enthalpy_flux_ocn(:ncol) = cam_in%ocnfrac(:ncol)*enthalpy_flux_ocn(:ncol) + + if (debug) then + call outfld("enth_prec_ac_hice" , enthalpy_prec_ac(:,hice_idx) , pcols ,lchnk ) + call outfld("enth_prec_ac_hliq" , enthalpy_prec_ac(:,hliq_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_hice" , enthalpy_prec_bc(:,hice_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_hliq" , enthalpy_prec_bc(:,hliq_idx) , pcols ,lchnk ) + call outfld("enth_prec_ac_fice" , enthalpy_prec_ac(:,fice_idx) , pcols ,lchnk ) + call outfld("enth_prec_ac_fliq" , enthalpy_prec_ac(:,fliq_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_fice" , enthalpy_prec_bc(:,fice_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_fliq" , enthalpy_prec_bc(:,fliq_idx) , pcols ,lchnk ) + call outfld("enth_hevap_atm" , hevap_atm (:) , pcols ,lchnk ) + call outfld("enth_hevap_ocn" , hevap_ocn (:) , pcols ,lchnk ) + endif + !=== end computation of material enthalpy fluxes === + + !+++ diags + ! compute total energy after physics using equation 78 + call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & + state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & + state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& + vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & + te = te_endphys(:ncol), se=se_endphys(:ncol), po=po_endphys(:ncol), ke=ke_endphys(:ncol)) + ! the column integrated total energy change should match accumlated te_tnd: + ! dEdt_physics=te_tnd + call outfld ('te_tnd',tend%te_tnd , pcols, lchnk) + dEdt_physics(:ncol) = (te_endphys(:ncol)-te_init(:ncol,1,lchnk))/ztodt + call outfld ('dEdt_physics', dEdt_physics, pcols, lchnk) + !--- sgaid + + !+ get pbuf fields for precip + dp_ntprp_idx = pbuf_get_index('dp_ntprp',errcode=i) !prec production from ZM + dp_ntsnp_idx = pbuf_get_index('dp_ntsnp',errcode=i) !snow production from ZM + call pbuf_get_field(pbuf, dp_ntprp_idx , dp_ntprp) + call pbuf_get_field(pbuf, dp_ntsnp_idx , dp_ntsnp) + qrain_mg_idx = pbuf_get_index('qrain_mg',errcode=i) !rain production from MG + qsnow_mg_idx = pbuf_get_index('qsnow_mg',errcode=i) !snow production from MG + call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) + call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) + rnsrc_pbc(:ncol,:) = dp_ntprp(:ncol,:)-dp_ntsnp(:ncol,:) + snsrc_pbc(:ncol,:) = dp_ntsnp(:ncol,:) + rnsrc_pac(:ncol,:) = qrain_mg(:ncol,:) + snsrc_pac(:ncol,:) = qsnow_mg(:ncol,:) + rnsrc_tot(:ncol,:) = rnsrc_pbc(:ncol,:)+rnsrc_pac(:ncol,:) + snsrc_tot(:ncol,:) = snsrc_pbc(:ncol,:)+snsrc_pac(:ncol,:) + !- picerp rof sdleif fubp teg + + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt & + , dme_energy_adjust=.true.,step='bc+ac' & + , ntrnprd=rnsrc_tot*ztodt & + , ntsnprd=snsrc_tot*ztodt & + , tevap=tevp, tprec=tprc & + , mflx=water_flux_bc+water_flux_ac & + , eflx=enthalpy_flux_atm & + , mflx_out=mflx_out & + , eflx_out=eflx_out & + , ent_tnd=dsema & + , pdel_rf=pdel_rf ) + + call outfld('IETEND_DME', dsema , pcols, lchnk) + + call outfld('EFLX' , enthalpy_flux_atm , pcols, lchnk) + !call outfld('EFLX_out' , eflx_out , pcols, lchnk) ! test + + call outfld('MFLX' , water_flux_bc+water_flux_ac , pcols, lchnk) + !call outfld('MFLX_out' ,-mflx_out , pcols, lchnk) ! test + + !! check energy must be called with "physics" temps to compensate for internal rescaling + !! call unnecessary, only for testing. te_cur is updated below. + !do k = 1, pver + ! do i = 1, ncol + ! scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) + ! state%T (i,k) = state%temp_ini(i,k)+(state%T(i,k)- state%temp_ini(i,k))/scale_cpdry_cpdycore(i,k) + ! tend%dtdt(i,k) = tend%dtdt(i,k)/scale_cpdry_cpdycore(i,k) + ! end do + !end do + !call check_energy_cam_chng(state, tend, "enthalpy_ac+bc_tend", nstep, ztodt, zero, zero, zero, dsema) + !! ...aand scale temperature back + !do k = 1, pver + ! do i = 1, ncol + ! scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) + ! state%T (i,k) = state%temp_ini(i,k)+scale_cpdry_cpdycore(i,k)*(state%T(i,k)- state%temp_ini(i,k)) + ! tend%dtdt(i,k) = scale_cpdry_cpdycore(i,k)*tend%dtdt(i,k) + ! end do + !end do + + ! compute and store new column-integrated enthalpy and associated tendency + call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & + state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & + state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& + vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & + te = te(:ncol), se=se(:ncol), po=po(:ncol), ke=ke(:ncol)) + ! Save final energy for use with global fixer in next timestep -- note sign conventions, and coupling-dependent options + state%te_cur(:ncol,dyn_te_idx) = te(:ncol) & ! *subtract* from this the h flux (sign: into atm) that is *not* passed to surface components + !- 0._r8 ! A. pass hmat to all (test atm conservation via TFIX) + !-ztodt*(enthalpy_flux_atm(:ncol)-enthalpy_flux_ocn(:ncol)) ! B. pass hmat to ocean only, fix the rest in atmo + -ztodt*(enthalpy_flux_atm(:ncol)-enthalpy_flux_ocn(:ncol)-cam_in%hrof(:ncol)) ! also remove enthalpy of run-off (if added to BLOM) + !-ztodt* enthalpy_flux_atm(:ncol) ! C. don't use hmat, fix everything in atmo + !tend%te_tnd(:ncol)=tend%te_tnd(:ncol) + enthalpy_flux_atm(:ncol) ! A. + !tend%te_tnd(:ncol)=tend%te_tnd(:ncol) + enthalpy_flux_ocn(:ncol) ! B. + tend%te_tnd(:ncol)=tend%te_tnd(:ncol) +(enthalpy_flux_ocn(:ncol)+cam_in%hrof(:ncol)) ! B. with run-off + !tend%te_tnd(:ncol)=tend%te_tnd(:ncol) + 0._r0 ! C. + + if (thermo_budget_history) then + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + endif + + call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) + ! the amount of total energy we need energy fixer to fix (associated with enthalpy flux) + dEdt_efix(:ncol) = (state%te_cur(:ncol,dyn_te_idx)-te (:ncol))/ztodt + call outfld("dEdt_efix_physics" , dEdt_efix , pcols ,lchnk ) + + ! xxx diagnostics + ! compute latent heat fluxes + !tht: correct for reference T of latent heats! (ice reference state here) + !variable_latent_heat_surface_cpice_term(:ncol)=(cam_in%cflx(:ncol,1)-fliq_tot(:ncol))* cpice * state%temp_ini(:ncol,pver) ! +0. + !variable_latent_heat_surface_ls_term (:ncol)= cam_in%cflx(:ncol,1) *((cpwv -cpice)*(state%temp_ini(:ncol,pver)-t00a)+cpice*t00a) + !variable_latent_heat_surface_lf_term (:ncol)= -fliq_tot(:ncol) *((cpliq-cpice)*(state%temp_ini(:ncol,pver)-t00a)+cpice*t00a) + !call outfld ('cpice_srf', variable_latent_heat_surface_cpice_term, pcols, lchnk) !xxx diags will remove + !call outfld ('ls_srf' , variable_latent_heat_surface_ls_term , pcols, lchnk) !xxx diags will remove + !call outfld ('lf_srf' , variable_latent_heat_surface_lf_term , pcols, lchnk) !xxx diags will remove + end subroutine enthalpy_adjustment + +end module check_energy diff --git a/src/physics/camnor_phys/physics/check_energy_chng.F90 b/src/physics/camnor_phys/physics/check_energy_chng.F90 new file mode 100644 index 0000000000..8974ad9b8b --- /dev/null +++ b/src/physics/camnor_phys/physics/check_energy_chng.F90 @@ -0,0 +1,426 @@ +module check_energy_chng + use ccpp_kinds, only: kind_phys + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + + public :: check_energy_chng_init + public :: check_energy_chng_timestep_init + public :: check_energy_chng_run + + ! Private module options. + logical :: print_energy_errors = .false. ! Turn on verbose output identifying columns that fail + ! energy/water checks? + +contains + +!> \section arg_table_check_energy_chng_init Argument Table +!! \htmlinclude arg_table_check_energy_chng_init.html + subroutine check_energy_chng_init(print_energy_errors_in) + ! Input arguments + logical, intent(in) :: print_energy_errors_in + + print_energy_errors = print_energy_errors_in + end subroutine check_energy_chng_init + + ! Compute initial values of energy and water integrals, + ! and zero out cumulative boundary tendencies. +!> \section arg_table_check_energy_chng_timestep_init Argument Table +!! \htmlinclude arg_table_check_energy_chng_timestep_init.html + subroutine check_energy_chng_timestep_init( & + ncol, pver, pcnst, & + is_first_timestep, & + q, pdel, & + u, v, T, & + pintdry, phis, zm, & + cp_phys, & ! cpairv generally, cpair fixed size for subcolumns code + cp_or_cv_dycore, & + te_ini_phys, te_ini_dyn, & + tw_ini, & + te_cur_phys, te_cur_dyn, & + tw_cur, & + tend_te_tnd, tend_tw_tnd, & + temp_ini, z_ini, & + count, & + teout, & + energy_formula_physics, energy_formula_dycore, & + errmsg, errflg) + + ! This scheme is non-portable due to dependencies on cam_thermo + ! for hydrostatic energy calculation (physics and dycore formulas) + use cam_thermo, only: get_hydrostatic_energy + use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS + + ! Input arguments + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: pcnst ! number of ccpp constituents + logical, intent(in) :: is_first_timestep ! is first step of initial run? + real(kind_phys), intent(in) :: q(:,:,:) ! constituent mass mixing ratios [kg kg-1] + real(kind_phys), intent(in) :: pdel(:,:) ! layer thickness [Pa] + real(kind_phys), intent(in) :: u(:,:) ! zonal wind [m s-1] + real(kind_phys), intent(in) :: v(:,:) ! meridional wind [m s-1] + real(kind_phys), intent(in) :: T(:,:) ! temperature [K] + real(kind_phys), intent(in) :: pintdry(:,:) ! interface pressure dry [Pa] + real(kind_phys), intent(in) :: phis(:) ! surface geopotential [m2 s-2] + real(kind_phys), intent(in) :: zm(:,:) ! geopotential height at layer midpoints [m] + real(kind_phys), intent(in) :: cp_phys(:,:) ! enthalpy (cpairv generally) [J kg-1 K-1] + real(kind_phys), intent(in) :: cp_or_cv_dycore(:,:) ! enthalpy or heat capacity, dycore dependent [J K-1 kg-1] + integer, intent(in) :: energy_formula_physics! total energy formulation physics + integer, intent(in) :: energy_formula_dycore ! total energy formulation dycore + + ! Output arguments + real(kind_phys), intent(out) :: temp_ini(:,:) ! initial temperature [K] + real(kind_phys), intent(out) :: z_ini(:,:) ! initial geopotential height [m] + integer, intent(out) :: count ! count of values with significant energy or water imbalances [1] + real(kind_phys), intent(out) :: teout(:) ! total energy for global fixer in next timestep [J m-2] + real(kind_phys), intent(out) :: tend_te_tnd(:) ! total energy tendency [J m-2 s-1] + real(kind_phys), intent(out) :: tend_tw_tnd(:) ! total water tendency [kg m-2 s-1] + + ! Input/Output arguments + real(kind_phys), intent(inout) :: te_ini_phys(:) ! physics formula: initial total energy [J m-2] + real(kind_phys), intent(inout) :: te_ini_dyn (:) ! dycore formula: initial total energy [J m-2] + real(kind_phys), intent(inout) :: tw_ini (:) ! initial total water [kg m-2] + real(kind_phys), intent(inout) :: te_cur_phys(:) ! physics formula: current total energy [J m-2] + real(kind_phys), intent(inout) :: te_cur_dyn (:) ! dycore formula: current total energy [J m-2] + real(kind_phys), intent(inout) :: tw_cur (:) ! current total water [kg m-2] + + ! Output arguments + character(len=512), intent(out) :: errmsg ! error message + integer, intent(out) :: errflg ! error flag + + errmsg = '' + errflg = 0 + + !------------------------------------------------ + ! Physics total energy. + !------------------------------------------------ + call get_hydrostatic_energy( & + tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios + moist_mixing_ratio = .true., & + pdel_in = pdel (1:ncol,1:pver), & + cp_or_cv = cp_phys (1:ncol,1:pver), & + U = u (1:ncol,1:pver), & + V = v (1:ncol,1:pver), & + T = T (1:ncol,1:pver), & + vcoord = energy_formula_physics, & ! energy formula for physics + ptop = pintdry (1:ncol,1), & + phis = phis (1:ncol), & + te = te_ini_phys(1:ncol), & ! vertically integrated total energy + H2O = tw_ini (1:ncol) & ! v.i. total water + ) + + ! Save initial state temperature and geopotential height for use in run phase + temp_ini(:ncol,:) = T (:ncol, :) + z_ini (:ncol,:) = zm(:ncol, :) + + !------------------------------------------------ + ! Dynamical core total energy. + !------------------------------------------------ + if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_SE) then + ! SE dycore specific hydrostatic energy (enthalpy) + call get_hydrostatic_energy( & + tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios + moist_mixing_ratio = .true., & + pdel_in = pdel (1:ncol,1:pver), & + cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & + U = u (1:ncol,1:pver), & + V = v (1:ncol,1:pver), & + T = T (1:ncol,1:pver), & + vcoord = energy_formula_dycore, & ! energy formula for dycore + ptop = pintdry (1:ncol,1), & + phis = phis (1:ncol), & + te = te_ini_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy + ) + + else if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_MPAS) then + ! MPAS dycore: compute cv if vertical coordinate is height: cv = cp - R (internal energy) + call get_hydrostatic_energy( & + tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios + moist_mixing_ratio = .true., & + pdel_in = pdel (1:ncol,1:pver), & + cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & + U = u (1:ncol,1:pver), & + V = v (1:ncol,1:pver), & + T = T (1:ncol,1:pver), & ! enthalpy-scaled temperature for energy consistency + vcoord = energy_formula_dycore, & ! energy formula for dycore + ptop = pintdry (1:ncol,1), & + phis = phis (1:ncol), & + z_mid = z_ini (1:ncol,:), & ! unique for MPAS + te = te_ini_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy + ) + else + ! FV dycore: dycore energy is the same as physics + te_ini_dyn(:ncol) = te_ini_phys(:ncol) + endif + + ! Set current state to be the same as initial + te_cur_phys(:ncol) = te_ini_phys(:ncol) + te_cur_dyn (:ncol) = te_ini_dyn (:ncol) + tw_cur (:ncol) = tw_ini (:ncol) + + ! Zero out current energy unbalances count + count = 0 + + ! Zero out cumulative boundary fluxes + tend_te_tnd(:ncol) = 0._kind_phys + tend_tw_tnd(:ncol) = 0._kind_phys + + ! If first timestep, initialize value of teout + if(is_first_timestep) then + teout(:ncol) = te_ini_dyn(:ncol) + endif + + end subroutine check_energy_chng_timestep_init + + + ! Check that energy and water change matches the boundary fluxes. +!> \section arg_table_check_energy_chng_run Argument Table +!! \htmlinclude arg_table_check_energy_chng_run.html + subroutine check_energy_chng_run(nstep,lchnk,masterproc, & + ncol, pver, pcnst, & + iulog, & + q, pdel, & + u, v, T, & + pintdry, phis, zm, & + cp_phys, & ! cpairv generally, cpair fixed size for subcolumns code + cp_or_cv_dycore, & + scaling_dycore, & ! From check_energy_scaling to work around subcolumns code + te_cur_phys, te_cur_dyn, & + tw_cur, & + tend_te_tnd, tend_tw_tnd, & + temp_ini, z_ini, & + count, ztodt, & + latice, latvap, & + energy_formula_physics, energy_formula_dycore, & + name, flx_vap, flx_cnd, flx_ice, flx_sen, & + errmsg, errflg) + + ! This scheme is non-portable due to dependencies on cam_thermo + ! for hydrostatic energy calculation (physics and dycore formulas) + use cam_thermo, only: get_hydrostatic_energy + + ! Dependency for energy formula used by physics and dynamical cores + use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_FV, ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS + + ! Input arguments + integer, intent(in) :: nstep + integer, intent(in) :: lchnk + logical, intent(in) :: masterproc + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: pcnst ! number of ccpp constituents + integer, intent(in) :: iulog ! log output unit + real(kind_phys), intent(in) :: q(:,:,:) ! constituent mass mixing ratios [kg kg-1] + real(kind_phys), intent(in) :: pdel(:,:) ! layer thickness [Pa] + real(kind_phys), intent(in) :: u(:,:) ! zonal wind [m s-1] + real(kind_phys), intent(in) :: v(:,:) ! meridional wind [m s-1] + real(kind_phys), intent(in) :: T(:,:) ! temperature [K] + real(kind_phys), intent(in) :: pintdry(:,:) ! interface pressure dry [Pa] + real(kind_phys), intent(in) :: phis(:) ! surface geopotential [m2 s-2] + real(kind_phys), intent(in) :: zm(:,:) ! geopotential height at layer midpoints [m] + real(kind_phys), intent(in) :: temp_ini(:,:) ! initial temperature [K] + real(kind_phys), intent(in) :: z_ini(:,:) ! initial geopotential height [m] + real(kind_phys), intent(in) :: cp_phys(:,:) ! enthalpy (cpairv generally) [J kg-1 K-1] + real(kind_phys), intent(in) :: cp_or_cv_dycore(:,:) ! enthalpy or heat capacity, dycore dependent [J K-1 kg-1] + real(kind_phys), intent(in) :: scaling_dycore(:,:) ! scaling for conversion of temperature increment [1] + real(kind_phys), intent(in) :: ztodt ! physics timestep [s] + real(kind_phys), intent(in) :: latice ! constant, latent heat of fusion of water at 0 C [J kg-1] + real(kind_phys), intent(in) :: latvap ! constant, latent heat of vaporization of water at 0 C [J kg-1] + integer, intent(in) :: energy_formula_physics! total energy formulation physics + integer, intent(in) :: energy_formula_dycore ! total energy formulation dycore + + ! Input from CCPP-scheme being checked: + ! parameterization name; surface fluxes of (1) vapor, (2) liquid+ice, (3) ice, (4) sensible heat + ! to pass in the values to be checked, call check_energy_zero_input_fluxes to reset these values + ! before a parameterization that is checked, then update these values as-needed + ! (can be all zero; in fact, most parameterizations calling _chng call with zero arguments) + ! + ! Original comment from BAB: + ! Note that the precip and ice fluxes are in precip units (m/s). + ! I would prefer to have kg/m2/s. + ! I would also prefer liquid (not total) and ice fluxes + character(len=*), intent(in) :: name ! parameterization name for fluxes + real(kind_phys), intent(in) :: flx_vap(:) ! boundary flux of vapor [kg m-2 s-1] + real(kind_phys), intent(in) :: flx_cnd(:) ! boundary flux of liquid+ice (precip?) [m s-1] + real(kind_phys), intent(in) :: flx_ice(:) ! boundary flux of ice [m s-1] + real(kind_phys), intent(in) :: flx_sen(:) ! boundary flux of sensible heat [W m-2] + + ! Input/Output arguments + real(kind_phys), intent(inout) :: te_cur_phys(:) ! physics formula: current total energy [J m-2] + real(kind_phys), intent(inout) :: te_cur_dyn (:) ! dycore formula: current total energy [J m-2] + real(kind_phys), intent(inout) :: tw_cur (:) ! current total water [kg m-2] + integer, intent(inout) :: count ! count of columns with significant energy or water imbalances [1] + real(kind_phys), intent(inout) :: tend_te_tnd(:) ! total energy tendency [J m-2 s-1] + real(kind_phys), intent(inout) :: tend_tw_tnd(:) ! total water tendency [kg m-2 s-1] + + ! Output arguments + character(len=512), intent(out) :: errmsg ! error message + integer, intent(out) :: errflg ! error flag + + ! Local variables + real(kind_phys) :: te_xpd(ncol) ! expected value (f0 + dt*boundary_flux) + real(kind_phys) :: te_dif(ncol) ! energy of input state - original energy + real(kind_phys) :: te_tnd(ncol) ! tendency from last process + real(kind_phys) :: te_rer(ncol) ! relative error in energy column + + real(kind_phys) :: tw_xpd(ncol) ! expected value (w0 + dt*boundary_flux) + real(kind_phys) :: tw_dif(ncol) ! tw_inp - original water + real(kind_phys) :: tw_tnd(ncol) ! tendency from last process + real(kind_phys) :: tw_rer(ncol) ! relative error in water column + + real(kind_phys) :: te(ncol) ! vertical integral of total energy + real(kind_phys) :: tw(ncol) ! vertical integral of total water + real(kind_phys) :: temp(ncol,pver) ! temperature + + real(kind_phys) :: se(ncol) ! enthalpy or internal energy (J/m2) + real(kind_phys) :: po(ncol) ! surface potential or potential energy (J/m2) + real(kind_phys) :: ke(ncol) ! kinetic energy (J/m2) + real(kind_phys) :: wv(ncol) ! column integrated vapor (kg/m2) + real(kind_phys) :: liq(ncol) ! column integrated liquid (kg/m2) + real(kind_phys) :: ice(ncol) ! column integrated ice (kg/m2) + + integer :: i + + errmsg = '' + errflg = 0 + + !------------------------------------------------ + ! Physics total energy. + !------------------------------------------------ + call get_hydrostatic_energy( & + tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios + moist_mixing_ratio = .true., & + pdel_in = pdel (1:ncol,1:pver), & + cp_or_cv = cp_phys(1:ncol,1:pver), & + U = u (1:ncol,1:pver), & + V = v (1:ncol,1:pver), & + T = T (1:ncol,1:pver), & + vcoord = energy_formula_physics, & ! energy formula for physics + ptop = pintdry(1:ncol,1), & + phis = phis (1:ncol), & + te = te (1:ncol), & ! vertically integrated total energy + H2O = tw (1:ncol), & ! v.i. total water + se = se (1:ncol), & ! v.i. enthalpy + po = po (1:ncol), & ! v.i. PHIS term + ke = ke (1:ncol), & ! v.i. kinetic energy + wv = wv (1:ncol), & ! v.i. water vapor + liq = liq (1:ncol), & ! v.i. liquid + ice = ice (1:ncol) & ! v.i. ice + ) + + ! compute expected values and tendencies + do i = 1, ncol + ! change in static energy and total water + te_dif(i) = te(i) - te_cur_phys(i) + tw_dif(i) = tw(i) - tw_cur (i) + + ! expected tendencies from boundary fluxes for last process + te_tnd(i) = flx_vap(i)*(latvap+latice) - (flx_cnd(i) - flx_ice(i))*1000._kind_phys*latice + flx_sen(i) + tw_tnd(i) = flx_vap(i) - flx_cnd(i) *1000._kind_phys + + ! cummulative tendencies from boundary fluxes + tend_te_tnd(i) = tend_te_tnd(i) + te_tnd(i) + tend_tw_tnd(i) = tend_tw_tnd(i) + tw_tnd(i) + + ! expected new values from previous state plus boundary fluxes + te_xpd(i) = te_cur_phys(i) + te_tnd(i)*ztodt + tw_xpd(i) = tw_cur (i) + tw_tnd(i)*ztodt + + ! relative error, expected value - input state / previous state + te_rer(i) = (te_xpd(i) - te(i)) / te_cur_phys(i) + end do + + ! relative error for total water (allow for dry atmosphere) + tw_rer = 0._kind_phys + where (tw_cur(:ncol) > 0._kind_phys) + tw_rer(:ncol) = (tw_xpd(:ncol) - tw(:ncol)) / tw_cur(:ncol) + end where + + if (masterproc) then ! for testing + if (print_energy_errors) then + if (any(abs(te_rer(1:ncol)) > 1.E-14_r8 .or. abs(tw_rer(1:ncol)) > 1.E-10_r8)) then + do i = 1, ncol + ! the relative error threshold for the water budget has been reduced to 1.e-10 + ! to avoid messages generated by QNEG3 calls + if ( abs(tw_rer(i)) > 1.E-10_r8) then + count = count + 1 + write(iulog,*) "significant WATER conservation error after ", trim(name) + write(iulog,'(a8,i5,a9,i5 ,a7,i4)') & + " count: ", count, ", nstep: ", nstep , ", col: ", i + write(iulog,*) tw(i) , tw_xpd(i) , tw_tnd(i)*ztodt & + , tw_dif(i), tw_tnd(i)*ztodt + write(iulog,*) " relative mass deficit: ",tw_rer(i) + end if + if (abs(te_rer(i)) > 1.E-14_r8 ) then + count = count + 1 + write(iulog,*) "significant ENERGY conservation error after ", trim(name) + write(iulog,'(a8,i5,a9,i5 ,a7,i4)') & + " count: ", count, ", nstep: ", nstep , ", col: ", i + write(iulog,'(3e17.7)') te_dif(i), te_tnd(i)*ztodt, te_dif(i)-(te_tnd(i)*ztodt) + endif + end do + end if + end if + end if + + ! WRITE OPERATION - copy new value to state, including total water. + ! the total water operations are consistent regardless of energy formula, + ! so it only has to be written once. + do i = 1, ncol + te_cur_phys(i) = te(i) + tw_cur(i) = tw(i) + end do + + !------------------------------------------------ + ! Dynamical core total energy. + !------------------------------------------------ + if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_SE) then + ! SE dycore specific hydrostatic energy + + ! enthalpy scaling for energy consistency + temp(1:ncol,:) = temp_ini(1:ncol,:)+scaling_dycore(1:ncol,:)*(T(1:ncol,:)-temp_ini(1:ncol,:)) + + call get_hydrostatic_energy( & + tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios + moist_mixing_ratio = .true., & + pdel_in = pdel (1:ncol,1:pver), & + cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & + U = u (1:ncol,1:pver), & + V = v (1:ncol,1:pver), & + T = temp (1:ncol,1:pver), & ! enthalpy-scaled temperature for energy consistency + vcoord = energy_formula_dycore, & ! energy formula for dycore + ptop = pintdry (1:ncol,1), & + phis = phis (1:ncol), & + te = te_cur_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy + ) + + else if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_MPAS) then + ! MPAS dycore: compute cv if vertical coordinate is height: cv = cp - R + + ! REMOVECAM: note this scaling is different with subcols off/on which is why it was put into separate scheme (hplin, 9/5/24) + temp(1:ncol,:) = temp_ini(1:ncol,:)+scaling_dycore(1:ncol,:)*(T(1:ncol,:)-temp_ini(1:ncol,:)) + + call get_hydrostatic_energy( & + tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios + moist_mixing_ratio = .true., & + pdel_in = pdel (1:ncol,1:pver), & + cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & + U = u (1:ncol,1:pver), & + V = v (1:ncol,1:pver), & + T = temp (1:ncol,1:pver), & ! enthalpy-scaled temperature for energy consistency + vcoord = energy_formula_dycore, & ! energy formula for dycore + ptop = pintdry (1:ncol,1), & + phis = phis (1:ncol), & + z_mid = z_ini (1:ncol,:), & ! unique for MPAS + te = te_cur_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy + ) + + else + ! FV dycore + te_cur_dyn(1:ncol) = te(1:ncol) + end if + end subroutine check_energy_chng_run + +end module check_energy_chng diff --git a/src/physics/camnor_phys/physics/micro_pumas_cam.F90 b/src/physics/camnor_phys/physics/micro_pumas_cam.F90 new file mode 100644 index 0000000000..b627f7d0a9 --- /dev/null +++ b/src/physics/camnor_phys/physics/micro_pumas_cam.F90 @@ -0,0 +1,3908 @@ +module micro_pumas_cam + +!--------------------------------------------------------------------------------- +! +! CAM Interfaces for MG microphysics +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use shr_kind_mod, only: cl=>shr_kind_cl +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp, psubcols +use physconst, only: gravit, rair, tmelt, cpair, rh2o, rhoh2o, & + latvap, latice, mwh2o +use phys_control, only: phys_getopts, use_hetfrz_classnuc + +use shr_const_mod, only: pi => shr_const_pi +use time_manager, only: get_curr_date, get_curr_calday +use phys_grid, only: get_rlat_all_p, get_rlon_all_p +use orbit, only: zenith + +use physics_types, only: physics_state, physics_ptend, & + physics_ptend_init, physics_state_copy, & + physics_update, physics_state_dealloc, & + physics_ptend_sum, physics_ptend_scale + +use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dyn_time_lvls, & + pbuf_old_tim_idx, pbuf_get_index, dtype_r8, dtype_i4, & + pbuf_get_field, pbuf_set_field, col_type_subcol, & + pbuf_register_subcol +use constituents, only: cnst_add, cnst_get_ind, & + cnst_name, cnst_longname, sflxnam, apcnst, bpcnst, pcnst + +use cldfrc2m, only: rhmini=>rhmini_const + +use cam_history, only: addfld, add_default, outfld, horiz_only + +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use error_messages, only: handle_errmsg +use ref_pres, only: top_lev=>trop_cloud_top_lev + +use micro_pumas_diags, only: proc_rates_type + +use subcol_utils, only: subcol_get_scheme + +implicit none +private +save + +public :: & + micro_pumas_cam_readnl, & + micro_pumas_cam_register, & + micro_pumas_cam_init_cnst, & + micro_pumas_cam_implements_cnst, & + micro_pumas_cam_init, & + micro_pumas_cam_tend, & + micro_mg_version, & + massless_droplet_destroyer + +integer :: micro_mg_version = 1 ! Version number for MG. +integer :: micro_mg_sub_version = 0 ! Second part of version number. + +real(r8) :: micro_mg_dcs = -1._r8 +real(r8), target, allocatable :: trop_levs(:) + +logical :: microp_uniform = .false. +logical :: micro_mg_adjust_cpt = .false. + +logical :: micro_do_massless_droplet_destroyer ! turn on/off destruction of massless droplets + +character(len=16) :: micro_mg_precip_frac_method = 'max_overlap' ! type of precipitation fraction method + +real(r8), parameter :: unset_r8 = huge(1.0_r8) + +! Tunable namelist parameters (set in atm_in) +real(r8) :: micro_mg_berg_eff_factor = unset_r8 ! berg efficiency factor +real(r8) :: micro_mg_accre_enhan_fact = unset_r8 ! accretion enhancment factor +real(r8) :: micro_mg_autocon_fact = unset_r8 ! autoconversion prefactor +real(r8) :: micro_mg_autocon_nd_exp = unset_r8 ! autoconversion nd exponent +real(r8) :: micro_mg_autocon_lwp_exp = unset_r8 ! autoconversion lwp exponent +real(r8) :: micro_mg_homog_size = unset_r8 ! size of freezing homogeneous ice +real(r8) :: micro_mg_vtrmi_factor = unset_r8 ! ice fall speed factor +real(r8) :: micro_mg_vtrms_factor = unset_r8 ! snow fall speed factor +real(r8) :: micro_mg_effi_factor = unset_r8 ! ice effective radius factor +real(r8) :: micro_mg_iaccr_factor = unset_r8 ! ice accretion of cloud droplet +real(r8) :: micro_mg_max_nicons = unset_r8 ! max allowed ice number concentration + + +logical, public :: do_cldliq ! Prognose cldliq flag +logical, public :: do_cldice ! Prognose cldice flag + +integer :: num_steps ! Number of MG substeps + +integer :: ncnst = 4 ! Number of constituents + +! Namelist variables for option to specify constant cloud droplet/ice number +logical :: micro_mg_nccons = .false. ! set .true. to specify constant cloud droplet number +logical :: micro_mg_nicons = .false. ! set .true. to specify constant cloud ice number +logical :: micro_mg_ngcons = .false. ! set .true. to specify constant graupel/hail number +logical :: micro_mg_nrcons = .false. ! set .true. to specify constant rain number +logical :: micro_mg_nscons = .false. ! set .true. to specify constant snow number + +! parameters for specified ice and droplet number concentration +! note: these are local in-cloud values, not grid-mean +real(r8) :: micro_mg_ncnst = 50.e6_r8 ! constant liquid droplet num concentration (m-3) +real(r8) :: micro_mg_ninst = 0.05e6_r8 ! ice num concentration when nicons=.true. (m-3) +real(r8) :: micro_mg_nrnst = 0.2e6_r8 ! rain num concentration when nrcons=.true. (m-3) +real(r8) :: micro_mg_nsnst = 0.005e6_r8 ! snow num concentration when nscons=.true. (m-3) +real(r8) :: micro_mg_ngnst = 0.0005e6_r8 ! graupel/hail num concentration when ngcons=.true. (m-3) + +logical, public :: micro_mg_do_graupel +logical, public :: micro_mg_do_hail + +! switches for IFS like behavior +logical :: micro_mg_evap_sed_off = .false. ! Turn off evaporation/sublimation based on cloud fraction for sedimenting condensate +logical :: micro_mg_icenuc_rh_off = .false. ! Remove RH conditional from ice nucleation +logical :: micro_mg_icenuc_use_meyers = .false. ! Meyers Ice Nucleation +logical :: micro_mg_evap_scl_ifs = .false. ! Scale evaporation as IFS does +logical :: micro_mg_evap_rhthrsh_ifs = .false. ! Evap RH threhold following IFS +logical :: micro_mg_rainfreeze_ifs = .false. ! Rain freezing at 0C following IFS +logical :: micro_mg_ifs_sed = .false. ! Snow sedimentation = 1 m/s following IFS +logical :: micro_mg_precip_fall_corr = .false. ! Precip fall speed following IFS (does not go to zero) + +logical :: micro_mg_implicit_fall = .false. !Implicit fall speed (sedimentation) for hydrometeors + +logical :: micro_mg_accre_sees_auto = .false. !Accretion sees autoconverted rain + +character(len=10), parameter :: & ! Constituent names + cnst_names(10) = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE', & + 'RAINQM', 'SNOWQM','NUMRAI','NUMSNO','GRAUQM','NUMGRA'/) + +integer :: & + ixq = -1, &! water vapor + ixcldliq = -1, &! cloud liquid amount index + ixcldice = -1, &! cloud ice amount index + ixnumliq = -1, &! cloud liquid number index + ixnumice = -1, &! cloud ice water index + ixrain = -1, &! rain index + ixsnow = -1, &! snow index + ixnumrain = -1, &! rain number index + ixnumsnow = -1, &! snow number index + ixgraupel = -1, &! graupel index + ixnumgraupel = -1 ! graupel number index + +! Physics buffer indices for fields registered by this module +integer :: & + cldo_idx, & + qme_idx, & + prain_idx, & + nevapr_idx, & + wsedl_idx, & + rei_idx, & + sadice_idx, & + sadsnow_idx, & + rel_idx, & + dei_idx, & + mu_idx, & + prer_evap_idx, & + lambdac_idx, & + iciwpst_idx, & + iclwpst_idx, & + des_idx, & + icswp_idx, & + cldfsnow_idx, & + degrau_idx = -1, & + icgrauwp_idx = -1, & + cldfgrau_idx = -1, & + rate1_cw2pr_st_idx = -1, & + ls_flxprc_idx, & + ls_flxsnw_idx, & + relvar_idx, & + cmeliq_idx, & + accre_enhan_idx + +! Fields for UNICON +integer :: & + am_evp_st_idx, &! Evaporation area of stratiform precipitation + evprain_st_idx, &! Evaporation rate of stratiform rain [kg/kg/s]. >= 0. + evpsnow_st_idx ! Evaporation rate of stratiform snow [kg/kg/s]. >= 0. + +! Fields needed as inputs to COSP +integer :: & + ls_mrprc_idx, ls_mrsnw_idx, & + ls_reffrain_idx, ls_reffsnow_idx, & + cv_reffliq_idx, cv_reffice_idx + +! Fields needed by Park macrophysics +integer :: & + cc_t_idx, cc_qv_idx, & + cc_ql_idx, cc_qi_idx, & + cc_nl_idx, cc_ni_idx, & + cc_qlst_idx + +! Used to replace aspects of MG microphysics +! (e.g. by CARMA) +integer :: & + tnd_qsnow_idx = -1, & + tnd_nsnow_idx = -1, & + re_ice_idx = -1 + +! Index fields for precipitation efficiency. +integer :: & + acpr_idx = -1, & + acgcme_idx = -1, & + acnum_idx = -1 + +! Physics buffer indices for fields registered by other modules +integer :: & + ast_idx = -1, & + cld_idx = -1, & + concld_idx = -1, & + prec_dp_idx = -1, & + prec_sh_idx = -1, & + qsatfac_idx = -1 + +! Pbuf fields needed for subcol_SILHS +integer :: & + qrain_idx=-1, qsnow_idx=-1, & + nrain_idx=-1, nsnow_idx=-1, & + qcsedten_idx=-1, qrsedten_idx=-1, & + qisedten_idx=-1, qssedten_idx=-1, qgsedten_idx=-1, & !+tht + vtrmc_idx=-1, umr_idx=-1, & + vtrmi_idx=-1, ums_idx=-1, & + qcsevap_idx=-1, qisevap_idx=-1 + +integer :: & + naai_idx = -1, & + naai_hom_idx = -1, & + npccn_idx = -1, & + rndst_idx = -1, & + nacon_idx = -1, & + prec_str_idx = -1, & + snow_str_idx = -1, & + prec_pcw_idx = -1, & + snow_pcw_idx = -1, & + prec_sed_idx = -1, & + snow_sed_idx = -1 + +! pbuf fields for heterogeneous freezing +integer :: & + frzimm_idx = -1, & + frzcnt_idx = -1, & + frzdep_idx = -1 + +logical :: allow_sed_supersat ! allow supersaturated conditions after sedimentation loop +character(len=16) :: micro_mg_warm_rain= 'kk2000' ! 'tau', 'emulated', 'sb2001' and ' kk2000' + +integer :: bergso_idx = -1 + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_pumas_cam_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_real8, & + mpi_logical, mpi_character + + use stochastic_emulated_cam, only: stochastic_emulated_readnl + use stochastic_tau_cam, only: stochastic_tau_readnl + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Namelist variables + logical :: micro_mg_do_cldice = .true. ! do_cldice = .true., MG microphysics is prognosing cldice + logical :: micro_mg_do_cldliq = .true. ! do_cldliq = .true., MG microphysics is prognosing cldliq + integer :: micro_mg_num_steps = 1 ! Number of substepping iterations done by MG (1.5 only for now). + + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: sub = 'micro_pumas_cam_readnl' + + namelist /micro_mg_nl/ micro_mg_version, micro_mg_sub_version, & + micro_mg_do_cldice, micro_mg_do_cldliq, micro_mg_num_steps, & + microp_uniform, micro_mg_dcs, micro_mg_precip_frac_method, & + micro_mg_berg_eff_factor, micro_mg_warm_rain, micro_mg_adjust_cpt, & + micro_mg_do_hail, micro_mg_do_graupel, micro_mg_ngcons, micro_mg_ngnst, & + micro_mg_vtrmi_factor, micro_mg_vtrms_factor, micro_mg_effi_factor, & + micro_mg_iaccr_factor, micro_mg_max_nicons, micro_mg_accre_enhan_fact, & + micro_mg_autocon_fact, micro_mg_autocon_nd_exp, micro_mg_autocon_lwp_exp, micro_mg_homog_size, & + micro_mg_nccons, micro_mg_nicons, micro_mg_ncnst, micro_mg_ninst, & + micro_mg_nrcons, micro_mg_nscons, micro_mg_nrnst, micro_mg_nsnst, & + micro_do_massless_droplet_destroyer, & + micro_mg_evap_sed_off, micro_mg_icenuc_rh_off, micro_mg_icenuc_use_meyers, & + micro_mg_evap_scl_ifs, micro_mg_evap_rhthrsh_ifs, & + micro_mg_rainfreeze_ifs, micro_mg_ifs_sed, micro_mg_precip_fall_corr, & + micro_mg_accre_sees_auto, micro_mg_implicit_fall + + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'micro_mg_nl', status=ierr) + if (ierr == 0) then + read(unitn, micro_mg_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + ! set local variables + do_cldice = micro_mg_do_cldice + do_cldliq = micro_mg_do_cldliq + num_steps = micro_mg_num_steps + + ! Verify that version numbers are valid. + select case (micro_mg_version) + case (2) + select case (micro_mg_sub_version) + case(0) + ! MG version 2.0 + case default + call bad_version_endrun() + end select + case (3) + select case (micro_mg_sub_version) + case(0) + ! MG version 3.0 + case default + call bad_version_endrun() + end select + case default + call bad_version_endrun() + end select + + if (micro_mg_dcs < 0._r8) call endrun( "micro_pumas_cam_readnl: & + µ_mg_dcs has not been set to a valid value.") + + if (micro_mg_version < 3) then + + if(micro_mg_do_graupel .or. micro_mg_do_hail ) then + call endrun ("micro_pumas_cam_readnl: Micro_mg_do_graupel and micro_mg_do_hail & + &must be false for MG versions before MG3.") + end if + + else ! micro_mg_version = 3 or greater + + if(micro_mg_do_graupel .and. micro_mg_do_hail ) then + call endrun ("micro_pumas_cam_readnl: Only one of micro_mg_do_graupel or & + µ_mg_do_hail may be true at a time.") + end if + + end if + + end if + + ! Broadcast namelist variables + call mpi_bcast(micro_mg_version, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_version") + + call mpi_bcast(micro_mg_sub_version, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_sub_version") + + call mpi_bcast(do_cldice, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_cldice") + + call mpi_bcast(do_cldliq, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_cldliq") + + call mpi_bcast(num_steps, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: num_steps") + + call mpi_bcast(microp_uniform, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: microp_uniform") + + call mpi_bcast(micro_mg_dcs, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_dcs") + + call mpi_bcast(micro_mg_berg_eff_factor, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_berg_eff_factor") + + call mpi_bcast(micro_mg_accre_enhan_fact, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_accre_enhan_fact") + + call mpi_bcast(micro_mg_autocon_fact, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_autocon_fact") + + call mpi_bcast(micro_mg_autocon_nd_exp, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_autocon_nd_exp") + + call mpi_bcast(micro_mg_autocon_lwp_exp, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_autocon_lwp_exp") + + call mpi_bcast(micro_mg_homog_size, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_homog_size") + + call mpi_bcast(micro_mg_vtrmi_factor, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_vtrmi_factor") + + call mpi_bcast(micro_mg_vtrms_factor, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_vtrms_factor") + + call mpi_bcast(micro_mg_effi_factor, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_effi_factor") + + call mpi_bcast(micro_mg_iaccr_factor, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_iaccr_factor") + + call mpi_bcast(micro_mg_max_nicons, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_max_nicons") + + call mpi_bcast(micro_mg_precip_frac_method, 16, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_precip_frac_method") + + call mpi_bcast(micro_mg_warm_rain, 16, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_warm_rain") + + call mpi_bcast(micro_mg_adjust_cpt, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_adjust_cpt") + + call mpi_bcast(micro_mg_nccons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nccons") + + call mpi_bcast(micro_mg_nicons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nicons") + + call mpi_bcast(micro_mg_nrcons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nrcons") + + call mpi_bcast(micro_mg_nscons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nscons") + + call mpi_bcast(micro_mg_ncnst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ncnst") + + call mpi_bcast(micro_mg_ninst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ninst") + + call mpi_bcast(micro_mg_nrnst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nrnst") + + call mpi_bcast(micro_mg_nsnst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nsnst") + + call mpi_bcast(micro_mg_do_hail, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_do_hail") + + call mpi_bcast(micro_mg_do_graupel, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_do_graupel") + + call mpi_bcast(micro_mg_ngcons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ngcons") + + call mpi_bcast(micro_mg_ngnst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ngnst") + + call mpi_bcast(micro_do_massless_droplet_destroyer, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_do_massless_droplet_destroyer") + + call mpi_bcast(micro_mg_evap_sed_off, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_evap_sed_off") + + call mpi_bcast(micro_mg_icenuc_rh_off, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_icenuc_rh_off") + + call mpi_bcast(micro_mg_icenuc_use_meyers, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_icenuc_use_meyers") + + call mpi_bcast(micro_mg_evap_scl_ifs, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_evap_scl_ifs") + + call mpi_bcast(micro_mg_evap_rhthrsh_ifs, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_evap_rhthrsh_ifs") + + call mpi_bcast(micro_mg_rainfreeze_ifs, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_rainfreeze_ifs") + + call mpi_bcast(micro_mg_ifs_sed, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ifs_sed") + + call mpi_bcast(micro_mg_precip_fall_corr, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_precip_fall_corr") + + call mpi_bcast(micro_mg_implicit_fall, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_implicit_fall") + + call mpi_bcast(micro_mg_accre_sees_auto, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_accre_sees_auto") + + if(micro_mg_berg_eff_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_berg_eff_factor is not set") + if(micro_mg_accre_enhan_fact == unset_r8) call endrun(sub//": FATAL: micro_mg_accre_enhan_fact is not set") + if(micro_mg_autocon_fact == unset_r8) call endrun(sub//": FATAL: micro_mg_autocon_fact is not set") + if(micro_mg_autocon_nd_exp == unset_r8) call endrun(sub//": FATAL: micro_mg_autocon_nd_exp is not set") + if(micro_mg_autocon_lwp_exp == unset_r8) call endrun(sub//": FATAL: micro_mg_autocon_lwp_exp is not set") + if(micro_mg_homog_size == unset_r8) call endrun(sub//": FATAL: micro_mg_homog_size is not set") + if(micro_mg_vtrmi_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_vtrmi_factor is not set") + if(micro_mg_vtrms_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_vtrms_factor is not set") + if(micro_mg_effi_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_effi_factor is not set") + if(micro_mg_iaccr_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_iaccr_factor is not set") + if(micro_mg_max_nicons == unset_r8) call endrun(sub//": FATAL: micro_mg_max_nicons is not set") + + if (masterproc) then + + write(iulog,*) 'MG microphysics namelist:' + write(iulog,*) ' micro_mg_version = ', micro_mg_version + write(iulog,*) ' micro_mg_sub_version = ', micro_mg_sub_version + write(iulog,*) ' micro_mg_do_cldice = ', do_cldice + write(iulog,*) ' micro_mg_do_cldliq = ', do_cldliq + write(iulog,*) ' micro_mg_num_steps = ', num_steps + write(iulog,*) ' microp_uniform = ', microp_uniform + write(iulog,*) ' micro_mg_dcs = ', micro_mg_dcs + write(iulog,*) ' micro_mg_berg_eff_factor = ', micro_mg_berg_eff_factor + write(iulog,*) ' micro_mg_accre_enhan_fact = ', micro_mg_accre_enhan_fact + write(iulog,*) ' micro_mg_autocon_fact = ' , micro_mg_autocon_fact + write(iulog,*) ' micro_mg_autocon_nd_exp = ' , micro_mg_autocon_nd_exp + write(iulog,*) ' micro_mg_autocon_lwp_exp = ' , micro_mg_autocon_lwp_exp + write(iulog,*) ' micro_mg_homog_size = ', micro_mg_homog_size + write(iulog,*) ' micro_mg_vtrmi_factor = ', micro_mg_vtrmi_factor + write(iulog,*) ' micro_mg_vtrms_factor = ', micro_mg_vtrms_factor + write(iulog,*) ' micro_mg_effi_factor = ', micro_mg_effi_factor + write(iulog,*) ' micro_mg_iaccr_factor = ', micro_mg_iaccr_factor + write(iulog,*) ' micro_mg_max_nicons = ', micro_mg_max_nicons + write(iulog,*) ' micro_mg_precip_frac_method = ', micro_mg_precip_frac_method + write(iulog,*) ' micro_mg_warm_rain = ', micro_mg_warm_rain + write(iulog,*) ' micro_mg_adjust_cpt = ', micro_mg_adjust_cpt + write(iulog,*) ' micro_mg_nccons = ', micro_mg_nccons + write(iulog,*) ' micro_mg_nicons = ', micro_mg_nicons + write(iulog,*) ' micro_mg_ncnst = ', micro_mg_ncnst + write(iulog,*) ' micro_mg_ninst = ', micro_mg_ninst + write(iulog,*) ' micro_mg_ngcons = ', micro_mg_ngcons + write(iulog,*) ' micro_mg_ngnst = ', micro_mg_ngnst + write(iulog,*) ' micro_mg_do_hail = ', micro_mg_do_hail + write(iulog,*) ' micro_mg_do_graupel = ', micro_mg_do_graupel + write(iulog,*) ' micro_do_massless_droplet_destroyer = ', micro_do_massless_droplet_destroyer + write(iulog,*) ' micro_mg_nrcons = ', micro_mg_nrcons + write(iulog,*) ' micro_mg_nscons = ', micro_mg_nscons + write(iulog,*) ' micro_mg_nrnst = ', micro_mg_nrnst + write(iulog,*) ' micro_mg_nsnst = ', micro_mg_nsnst + write(iulog,*) ' micro_mg_evap_sed_off = ', micro_mg_evap_sed_off + write(iulog,*) ' micro_mg_icenuc_rh_off = ', micro_mg_icenuc_rh_off + write(iulog,*) ' micro_mg_icenuc_use_meyers = ', micro_mg_icenuc_use_meyers + write(iulog,*) ' micro_mg_evap_scl_ifs = ', micro_mg_evap_scl_ifs + write(iulog,*) ' micro_mg_evap_rhthrsh_ifs = ', micro_mg_evap_rhthrsh_ifs + write(iulog,*) ' micro_mg_rainfreeze_ifs = ', micro_mg_rainfreeze_ifs + write(iulog,*) ' micro_mg_ifs_sed = ', micro_mg_ifs_sed + write(iulog,*) ' micro_mg_precip_fall_corr = ', micro_mg_precip_fall_corr + write(iulog,*) ' micro_mg_implicit_fall = ', micro_mg_implicit_fall + write(iulog,*) ' micro_mg_accre_sees_auto = ', micro_mg_accre_sees_auto + end if + + ! Read in the emulated or tau namelist if needed + if( trim(micro_mg_warm_rain) == 'emulated') then + call stochastic_emulated_readnl(nlfile) + else if (trim(micro_mg_warm_rain) == 'tau') then + call stochastic_tau_readnl(nlfile) + end if + +contains + + subroutine bad_version_endrun + ! Endrun wrapper with a more useful error message. + character(len=128) :: errstring + write(errstring,*) "Invalid version number specified for MG microphysics: ", & + micro_mg_version,".",micro_mg_sub_version + call endrun(errstring) + end subroutine bad_version_endrun + +end subroutine micro_pumas_cam_readnl + +!================================================================================================ + +subroutine micro_pumas_cam_register + use cam_history_support, only: add_vert_coord, hist_dimension_values + use cam_abortutils, only: handle_allocate_error + use carma_flags_mod, only: carma_model + + ! Register microphysics constituents and fields in the physics buffer. + !----------------------------------------------------------------------- + + logical :: prog_modal_aero + logical :: use_subcol_microp ! If true, then are using subcolumns in microphysics + logical :: found + + integer :: i, ierr + real(r8) :: all_levs(pver) + + allocate(trop_levs(pver-top_lev+1), stat=ierr) + call handle_allocate_error(ierr, 'micro_pumas_cam_register', 'trop_levs') + + call phys_getopts(use_subcol_microp_out = use_subcol_microp, & + prog_modal_aero_out = prog_modal_aero) + + ! Register microphysics constituents and save indices. + + call cnst_add(cnst_names(1), mwh2o, cpair, 0._r8, ixcldliq, & + longname='Grid box averaged cloud liquid amount', is_convtran1=.true.) + call cnst_add(cnst_names(2), mwh2o, cpair, 0._r8, ixcldice, & + longname='Grid box averaged cloud ice amount', is_convtran1=.true.) + + call cnst_add(cnst_names(3), mwh2o, cpair, 0._r8, ixnumliq, & + ndropmixed=prog_modal_aero.or.carma_model(:10)=='trop_strat', & + longname='Grid box averaged cloud liquid number', is_convtran1=.true.) + call cnst_add(cnst_names(4), mwh2o, cpair, 0._r8, ixnumice, & + longname='Grid box averaged cloud ice number', is_convtran1=.true.) + + ! Add history coordinate for DDT nlev + call hist_dimension_values('lev',all_levs, 1, pver, found) + + if (found) then + trop_levs(1:pver-top_lev+1) = all_levs(top_lev:pver) + call add_vert_coord('trop_cld_lev', pver-top_lev+1, & + 'troposphere hybrid level at midpoints (1000*(A+B))', 'hPa', trop_levs, & + positive='down' ) + else + call endrun( "micro_pumas_cam_register: unable to find dimension field 'lev'") + end if + + +! ---- Note is_convtran1 is set to .true. + call cnst_add(cnst_names(5), mwh2o, cpair, 0._r8, ixrain, & + longname='Grid box averaged rain amount', is_convtran1=.true.) + call cnst_add(cnst_names(6), mwh2o, cpair, 0._r8, ixsnow, & + longname='Grid box averaged snow amount', is_convtran1=.true.) + call cnst_add(cnst_names(7), mwh2o, cpair, 0._r8, ixnumrain, & + longname='Grid box averaged rain number', is_convtran1=.true.) + call cnst_add(cnst_names(8), mwh2o, cpair, 0._r8, ixnumsnow, & + longname='Grid box averaged snow number', is_convtran1=.true.) + + if (micro_mg_version > 2) then + call cnst_add(cnst_names(9), mwh2o, cpair, 0._r8, ixgraupel, & + longname='Grid box averaged graupel/hail amount', is_convtran1=.true.) + call cnst_add(cnst_names(10), mwh2o, cpair, 0._r8, ixnumgraupel, & + longname='Grid box averaged graupel/hail number', is_convtran1=.true.) + end if + + ! Request physics buffer space for fields that persist across timesteps. + + call pbuf_add_field('CLDO','global',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldo_idx) + + ! Physics buffer variables for convective cloud properties. + + call pbuf_add_field('QME', 'physpkg',dtype_r8,(/pcols,pver/), qme_idx) + call pbuf_add_field('PRAIN', 'physpkg',dtype_r8,(/pcols,pver/), prain_idx) + call pbuf_add_field('NEVAPR', 'physpkg',dtype_r8,(/pcols,pver/), nevapr_idx) + call pbuf_add_field('PRER_EVAP', 'global', dtype_r8,(/pcols,pver/), prer_evap_idx) + call pbuf_add_field('BERGSO', 'physpkg',dtype_r8,(/pcols,pver/), bergso_idx) + + call pbuf_add_field('WSEDL', 'physpkg',dtype_r8,(/pcols,pver/), wsedl_idx) + + call pbuf_add_field('REI', 'physpkg',dtype_r8,(/pcols,pver/), rei_idx) + call pbuf_add_field('SADICE', 'physpkg',dtype_r8,(/pcols,pver/), sadice_idx) + call pbuf_add_field('SADSNOW', 'physpkg',dtype_r8,(/pcols,pver/), sadsnow_idx) + call pbuf_add_field('REL', 'physpkg',dtype_r8,(/pcols,pver/), rel_idx) + + ! Mitchell ice effective diameter for radiation + call pbuf_add_field('DEI', 'physpkg',dtype_r8,(/pcols,pver/), dei_idx) + ! Size distribution shape parameter for radiation + call pbuf_add_field('MU', 'physpkg',dtype_r8,(/pcols,pver/), mu_idx) + ! Size distribution shape parameter for radiation + call pbuf_add_field('LAMBDAC', 'physpkg',dtype_r8,(/pcols,pver/), lambdac_idx) + + ! Stratiform only in cloud ice water path for radiation + call pbuf_add_field('ICIWPST', 'physpkg',dtype_r8,(/pcols,pver/), iciwpst_idx) + ! Stratiform in cloud liquid water path for radiation + call pbuf_add_field('ICLWPST', 'physpkg',dtype_r8,(/pcols,pver/), iclwpst_idx) + + ! Snow effective diameter for radiation + call pbuf_add_field('DES', 'physpkg',dtype_r8,(/pcols,pver/), des_idx) + ! In cloud snow water path for radiation + call pbuf_add_field('ICSWP', 'physpkg',dtype_r8,(/pcols,pver/), icswp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_add_field('CLDFSNOW ', 'physpkg',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldfsnow_idx) + + if (micro_mg_version > 2) then + ! Graupel effective diameter for radiation + call pbuf_add_field('DEGRAU', 'physpkg',dtype_r8,(/pcols,pver/), degrau_idx) + ! In cloud snow water path for radiation + call pbuf_add_field('ICGRAUWP', 'physpkg',dtype_r8,(/pcols,pver/), icgrauwp_idx) + ! Cloud fraction for liquid drops + graupel + call pbuf_add_field('CLDFGRAU', 'physpkg',dtype_r8,(/pcols,pver/), cldfgrau_idx) + end if + + if (prog_modal_aero) then + call pbuf_add_field('RATE1_CW2PR_ST','physpkg',dtype_r8,(/pcols,pver/), rate1_cw2pr_st_idx) + endif + + call pbuf_add_field('LS_FLXPRC', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxprc_idx) + call pbuf_add_field('LS_FLXSNW', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxsnw_idx) + + + ! Fields needed as inputs to COSP + call pbuf_add_field('LS_MRPRC', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrprc_idx) + call pbuf_add_field('LS_MRSNW', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrsnw_idx) + call pbuf_add_field('LS_REFFRAIN','physpkg',dtype_r8,(/pcols,pver/), ls_reffrain_idx) + call pbuf_add_field('LS_REFFSNOW','physpkg',dtype_r8,(/pcols,pver/), ls_reffsnow_idx) + call pbuf_add_field('CV_REFFLIQ', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffliq_idx) + call pbuf_add_field('CV_REFFICE', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffice_idx) + + ! CC_* Fields needed by Park macrophysics + call pbuf_add_field('CC_T', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_t_idx) + call pbuf_add_field('CC_qv', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qv_idx) + call pbuf_add_field('CC_ql', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ql_idx) + call pbuf_add_field('CC_qi', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qi_idx) + call pbuf_add_field('CC_nl', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_nl_idx) + call pbuf_add_field('CC_ni', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ni_idx) + call pbuf_add_field('CC_qlst', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qlst_idx) + + ! Fields for UNICON + call pbuf_add_field('am_evp_st', 'global', dtype_r8, (/pcols,pver/), am_evp_st_idx) + call pbuf_add_field('evprain_st', 'global', dtype_r8, (/pcols,pver/), evprain_st_idx) + call pbuf_add_field('evpsnow_st', 'global', dtype_r8, (/pcols,pver/), evpsnow_st_idx) + + ! Register subcolumn pbuf fields + if (use_subcol_microp) then + ! Global pbuf fields + call pbuf_register_subcol('CLDO', 'micro_pumas_cam_register', cldo_idx) + + ! CC_* Fields needed by Park macrophysics + call pbuf_register_subcol('CC_T', 'micro_pumas_cam_register', cc_t_idx) + call pbuf_register_subcol('CC_qv', 'micro_pumas_cam_register', cc_qv_idx) + call pbuf_register_subcol('CC_ql', 'micro_pumas_cam_register', cc_ql_idx) + call pbuf_register_subcol('CC_qi', 'micro_pumas_cam_register', cc_qi_idx) + call pbuf_register_subcol('CC_nl', 'micro_pumas_cam_register', cc_nl_idx) + call pbuf_register_subcol('CC_ni', 'micro_pumas_cam_register', cc_ni_idx) + call pbuf_register_subcol('CC_qlst', 'micro_pumas_cam_register', cc_qlst_idx) + + ! Physpkg pbuf fields + ! Physics buffer variables for convective cloud properties. + + call pbuf_register_subcol('QME', 'micro_pumas_cam_register', qme_idx) + call pbuf_register_subcol('PRAIN', 'micro_pumas_cam_register', prain_idx) + call pbuf_register_subcol('NEVAPR', 'micro_pumas_cam_register', nevapr_idx) + call pbuf_register_subcol('PRER_EVAP', 'micro_pumas_cam_register', prer_evap_idx) + call pbuf_register_subcol('BERGSO', 'micro_pumas_cam_register', bergso_idx) + + call pbuf_register_subcol('WSEDL', 'micro_pumas_cam_register', wsedl_idx) + + call pbuf_register_subcol('REI', 'micro_pumas_cam_register', rei_idx) + call pbuf_register_subcol('SADICE', 'micro_pumas_cam_register', sadice_idx) + call pbuf_register_subcol('SADSNOW', 'micro_pumas_cam_register', sadsnow_idx) + call pbuf_register_subcol('REL', 'micro_pumas_cam_register', rel_idx) + + ! Mitchell ice effective diameter for radiation + call pbuf_register_subcol('DEI', 'micro_pumas_cam_register', dei_idx) + ! Size distribution shape parameter for radiation + call pbuf_register_subcol('MU', 'micro_pumas_cam_register', mu_idx) + ! Size distribution shape parameter for radiation + call pbuf_register_subcol('LAMBDAC', 'micro_pumas_cam_register', lambdac_idx) + + ! Stratiform only in cloud ice water path for radiation + call pbuf_register_subcol('ICIWPST', 'micro_pumas_cam_register', iciwpst_idx) + ! Stratiform in cloud liquid water path for radiation + call pbuf_register_subcol('ICLWPST', 'micro_pumas_cam_register', iclwpst_idx) + + ! Snow effective diameter for radiation + call pbuf_register_subcol('DES', 'micro_pumas_cam_register', des_idx) + ! In cloud snow water path for radiation + call pbuf_register_subcol('ICSWP', 'micro_pumas_cam_register', icswp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_register_subcol('CLDFSNOW ', 'micro_pumas_cam_register', cldfsnow_idx) + + if (micro_mg_version > 2) then + ! Graupel effective diameter for radiation + call pbuf_register_subcol('DEGRAU', 'micro_pumas_cam_register', degrau_idx) + ! In cloud snow water path for radiation + call pbuf_register_subcol('ICGRAUWP', 'micro_pumas_cam_register', icgrauwp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_register_subcol('CLDFGRAU', 'micro_pumas_cam_register', cldfgrau_idx) + end if + + if (prog_modal_aero) then + call pbuf_register_subcol('RATE1_CW2PR_ST', 'micro_pumas_cam_register', rate1_cw2pr_st_idx) + end if + + call pbuf_register_subcol('LS_FLXPRC', 'micro_pumas_cam_register', ls_flxprc_idx) + call pbuf_register_subcol('LS_FLXSNW', 'micro_pumas_cam_register', ls_flxsnw_idx) + + ! Fields needed as inputs to COSP + call pbuf_register_subcol('LS_MRPRC', 'micro_pumas_cam_register', ls_mrprc_idx) + call pbuf_register_subcol('LS_MRSNW', 'micro_pumas_cam_register', ls_mrsnw_idx) + call pbuf_register_subcol('LS_REFFRAIN', 'micro_pumas_cam_register', ls_reffrain_idx) + call pbuf_register_subcol('LS_REFFSNOW', 'micro_pumas_cam_register', ls_reffsnow_idx) + call pbuf_register_subcol('CV_REFFLIQ', 'micro_pumas_cam_register', cv_reffliq_idx) + call pbuf_register_subcol('CV_REFFICE', 'micro_pumas_cam_register', cv_reffice_idx) + end if + + ! Additional pbuf for CARMA interface + if (.not. do_cldice) then + call pbuf_add_field('TND_QSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_qsnow_idx) + call pbuf_add_field('TND_NSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_nsnow_idx) + call pbuf_add_field('RE_ICE', 'physpkg',dtype_r8,(/pcols,pver/), re_ice_idx) + end if + + ! Precipitation efficiency fields across timesteps. + call pbuf_add_field('ACPRECL', 'global',dtype_r8,(/pcols/), acpr_idx) ! accumulated precip + call pbuf_add_field('ACGCME', 'global',dtype_r8,(/pcols/), acgcme_idx) ! accumulated condensation + call pbuf_add_field('ACNUM', 'global',dtype_i4,(/pcols/), acnum_idx) ! counter for accumulated # timesteps + + ! SGS variability -- These could be reset by CLUBB so they need to be grid only + call pbuf_add_field('RELVAR', 'global',dtype_r8,(/pcols,pver/), relvar_idx) + call pbuf_add_field('ACCRE_ENHAN','global',dtype_r8,(/pcols,pver/), accre_enhan_idx) + + ! Diagnostic fields needed for subcol_SILHS, need to be grid-only + if (subcol_get_scheme() == 'SILHS') then + call pbuf_add_field('QRAIN', 'global',dtype_r8,(/pcols,pver/), qrain_idx) + call pbuf_add_field('QSNOW', 'global',dtype_r8,(/pcols,pver/), qsnow_idx) + call pbuf_add_field('NRAIN', 'global',dtype_r8,(/pcols,pver/), nrain_idx) + call pbuf_add_field('NSNOW', 'global',dtype_r8,(/pcols,pver/), nsnow_idx) + + ! Fields for subcol_SILHS hole filling + ! Note -- hole filling is on the grid, so pbuf_register_setcols do not need to be called for these pbuf fields + call pbuf_add_field('QCSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qcsedten_idx) + call pbuf_add_field('QRSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qrsedten_idx) + call pbuf_add_field('QISEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qisedten_idx) + call pbuf_add_field('QSSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qssedten_idx) + call pbuf_add_field('VTRMC', 'physpkg', dtype_r8, (/pcols,pver/), vtrmc_idx) + call pbuf_add_field('UMR', 'physpkg', dtype_r8, (/pcols,pver/), umr_idx) + call pbuf_add_field('VTRMI', 'physpkg', dtype_r8, (/pcols,pver/), vtrmi_idx) + call pbuf_add_field('UMS', 'physpkg', dtype_r8, (/pcols,pver/), ums_idx) + call pbuf_add_field('QCSEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qcsevap_idx) + call pbuf_add_field('QISEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qisevap_idx) +!+tht + else + call pbuf_add_field('QCSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qcsedten_idx) + call pbuf_add_field('QRSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qrsedten_idx) + call pbuf_add_field('QISEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qisedten_idx) + call pbuf_add_field('QSSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qssedten_idx) + call pbuf_add_field('QGSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qgsedten_idx) +!-tht + end if + +end subroutine micro_pumas_cam_register + +!=============================================================================== + +function micro_pumas_cam_implements_cnst(name) + + ! Return true if specified constituent is implemented by the + ! microphysics package + + character(len=*), intent(in) :: name ! constituent name + logical :: micro_pumas_cam_implements_cnst ! return value + + !----------------------------------------------------------------------- + + micro_pumas_cam_implements_cnst = any(name == cnst_names) + +end function micro_pumas_cam_implements_cnst + +!=============================================================================== + +subroutine micro_pumas_cam_init_cnst(name, latvals, lonvals, mask, q) + + ! Initialize the microphysics constituents, if they are + ! not read from the initial file. + + character(len=*), intent(in) :: name ! constituent name + real(r8), intent(in) :: latvals(:) ! lat in degrees (ncol) + real(r8), intent(in) :: lonvals(:) ! lon in degrees (ncol) + logical, intent(in) :: mask(:) ! Only initialize where .true. + real(r8), intent(out) :: q(:,:) ! kg tracer/kg dry air (gcol, plev + !----------------------------------------------------------------------- + integer :: k + + if (micro_pumas_cam_implements_cnst(name)) then + do k = 1, size(q, 2) + where(mask) + q(:, k) = 0.0_r8 + end where + end do + end if + +end subroutine micro_pumas_cam_init_cnst + +!=============================================================================== + +subroutine micro_pumas_cam_init(pbuf2d) + use time_manager, only: is_first_step + use micro_pumas_utils, only: micro_pumas_utils_init + use micro_pumas_ccpp, only: micro_pumas_ccpp_init + use stochastic_tau_cam, only: stochastic_tau_init_cam + use stochastic_emulated_cam, only: stochastic_emulated_init_cam + + !----------------------------------------------------------------------- + ! + ! Initialization for MG microphysics + ! + !----------------------------------------------------------------------- + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + integer :: m, mm + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_budget ! Output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + logical :: use_subcol_microp + logical :: do_clubb_sgs + integer :: budget_histfile ! output history file number for budget fields + integer :: ierr + character(len=512) :: errstring ! return status (non-blank for error return) + + character(len=cl) :: stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, & + stochastic_emulated_filename_output_scale + + !----------------------------------------------------------------------- + + call phys_getopts(use_subcol_microp_out=use_subcol_microp, & + do_clubb_sgs_out =do_clubb_sgs) + + if (do_clubb_sgs) then + allow_sed_supersat = .false. + else + allow_sed_supersat = .true. + endif + + if (masterproc) then + write(iulog,"(A,I2,A,I2)") "Initializing MG version ",micro_mg_version,".",micro_mg_sub_version + if (.not. do_cldliq) & + write(iulog,*) "MG prognostic cloud liquid has been turned off via namelist." + if (.not. do_cldice) & + write(iulog,*) "MG prognostic cloud ice has been turned off via namelist." + write(iulog,*) "Number of microphysics substeps is: ",num_steps + end if + + ! Set constituent number for later loops. + if(micro_mg_version == 2) then + ncnst = 8 + else + ncnst = 10 + end if + + ! If Machine learning is turned on, perform its initializations + if (trim(micro_mg_warm_rain) == 'tau') then + call stochastic_tau_init_cam() + else if( trim(micro_mg_warm_rain) == 'emulated') then + call stochastic_emulated_init_cam(stochastic_emulated_filename_quantile, & + stochastic_emulated_filename_input_scale, & + stochastic_emulated_filename_output_scale) + end if + + call micro_pumas_ccpp_init(gravit, rair, rh2o, cpair, tmelt, latvap, latice, & + rhmini, iulog, micro_mg_do_hail, micro_mg_do_graupel, & + microp_uniform, do_cldice, use_hetfrz_classnuc, & + allow_sed_supersat, micro_mg_evap_sed_off, & + micro_mg_icenuc_rh_off, micro_mg_icenuc_use_meyers, & + micro_mg_evap_scl_ifs, micro_mg_evap_rhthrsh_ifs, & + micro_mg_rainfreeze_ifs, micro_mg_ifs_sed, & + micro_mg_precip_fall_corr, micro_mg_accre_sees_auto, & + micro_mg_implicit_fall, micro_mg_nccons, & + micro_mg_nicons, micro_mg_ngcons, micro_mg_nrcons, & + micro_mg_nscons, micro_mg_precip_frac_method, & + micro_mg_warm_rain, & + stochastic_emulated_filename_quantile, & + stochastic_emulated_filename_input_scale, & + stochastic_emulated_filename_output_scale, & + micro_mg_dcs, & + micro_mg_berg_eff_factor, micro_mg_accre_enhan_fact, & + micro_mg_autocon_fact, micro_mg_autocon_nd_exp, & + micro_mg_autocon_lwp_exp, micro_mg_homog_size, & + micro_mg_vtrmi_factor, micro_mg_vtrms_factor, & + micro_mg_effi_factor, micro_mg_iaccr_factor, & + micro_mg_max_nicons, micro_mg_ncnst, & + micro_mg_ninst, micro_mg_ngnst, micro_mg_nrnst, & + micro_mg_nsnst, errstring, ierr) + + call handle_errmsg(errstring, subname="micro_pumas_cam_init") + + ! Retrieve the index for water vapor + call cnst_get_ind('Q', ixq) + + ! Register history variables + do m = 1, ncnst + call cnst_get_ind(cnst_names(m), mm) + if ( any(mm == (/ ixcldliq, ixcldice, ixrain, ixsnow, ixgraupel /)) ) then + ! mass mixing ratios + call addfld(cnst_name(mm), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(mm), sampled_on_subcycle=.true.) + call addfld(sflxnam(mm), horiz_only, 'A', 'kg/m2/s', trim(cnst_name(mm))//' surface flux', sampled_on_subcycle=.true.) + else if ( any(mm == (/ ixnumliq, ixnumice, ixnumrain, ixnumsnow, ixnumgraupel /)) ) then + ! number concentrations + call addfld(cnst_name(mm), (/ 'lev' /), 'A', '1/kg', cnst_longname(mm), sampled_on_subcycle=.true.) + call addfld(sflxnam(mm), horiz_only, 'A', '1/m2/s', trim(cnst_name(mm))//' surface flux', sampled_on_subcycle=.true.) + else + call endrun( "micro_pumas_cam_init: & + &Could not call addfld for constituent with unknown units.") + endif + end do + + call addfld(apcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldliq))//' after physics', sampled_on_subcycle=.true.) + call addfld(apcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldice))//' after physics', sampled_on_subcycle=.true.) + call addfld(bpcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldliq))//' before physics', sampled_on_subcycle=.true.) + call addfld(bpcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldice))//' before physics', sampled_on_subcycle=.true.) + + call addfld(apcnst(ixrain), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixrain))//' after physics', sampled_on_subcycle=.true.) + call addfld(apcnst(ixsnow), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixsnow))//' after physics', sampled_on_subcycle=.true.) + call addfld(bpcnst(ixrain), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixrain))//' before physics', sampled_on_subcycle=.true.) + call addfld(bpcnst(ixsnow), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixsnow))//' before physics', sampled_on_subcycle=.true.) + + if (micro_mg_version > 2) then + call addfld(apcnst(ixgraupel), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixgraupel))//' after physics', sampled_on_subcycle=.true.) + call addfld(bpcnst(ixgraupel), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixgraupel))//' before physics', sampled_on_subcycle=.true.) + end if + + call addfld ('CME', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of cond-evap within the cloud', sampled_on_subcycle=.true.) + call addfld ('PRODPREC', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of conversion of condensate to precip', sampled_on_subcycle=.true.) + call addfld ('EVAPPREC', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling precip', sampled_on_subcycle=.true.) + call addfld ('EVAPSNOW', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling snow', sampled_on_subcycle=.true.) + call addfld ('HPROGCLD', (/ 'lev' /), 'A', 'W/kg' , 'Heating from prognostic clouds', sampled_on_subcycle=.true.) + call addfld ('FICE', (/ 'lev' /), 'A', 'fraction', 'Fractional ice content within cloud', sampled_on_subcycle=.true.) + call addfld ('CLDFSNOW', (/ 'lev' /), 'A', '1', 'Cloud fraction adjusted for snow', sampled_on_subcycle=.true.) + call addfld ('ICWMRST', (/ 'lev' /), 'A', 'kg/kg', 'Prognostic in-stratus water mixing ratio', sampled_on_subcycle=.true.) + call addfld ('ICIMRST', (/ 'lev' /), 'A', 'kg/kg', 'Prognostic in-stratus ice mixing ratio', sampled_on_subcycle=.true.) + + ! MG microphysics diagnostics + call addfld ('QCSEVAP', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling cloud water', sampled_on_subcycle=.true.) + call addfld ('QISEVAP', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of sublimation of falling cloud ice', sampled_on_subcycle=.true.) + call addfld ('QVRES', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of residual condensation term', sampled_on_subcycle=.true.) + call addfld ('CMEIOUT', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of deposition/sublimation of cloud ice',sampled_on_subcycle=.true.) + call addfld ('VTRMC', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted cloud water fallspeed', sampled_on_subcycle=.true.) + call addfld ('VTRMI', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted cloud ice fallspeed', sampled_on_subcycle=.true.) + call addfld ('QCSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Cloud water mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) + call addfld ('QISEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Cloud ice mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) + call addfld ('PRAO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud water by rain', sampled_on_subcycle=.true.) + call addfld ('PRCO', (/ 'lev' /), 'A', 'kg/kg/s', 'Autoconversion of cloud water', sampled_on_subcycle=.true.) + call addfld ('MNUCCCO', (/ 'lev' /), 'A', 'kg/kg/s', 'Immersion freezing of cloud water', sampled_on_subcycle=.true.) + call addfld ('MNUCCTO', (/ 'lev' /), 'A', 'kg/kg/s', 'Contact freezing of cloud water', sampled_on_subcycle=.true.) + call addfld ('MNUCCDO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Homogeneous and heterogeneous nucleation from vapor', sampled_on_subcycle=.true.) + call addfld ('MNUCCDOhet', (/ 'lev' /), 'A', 'kg/kg/s', 'Heterogeneous nucleation from vapor', sampled_on_subcycle=.true.) + call addfld ('MSACWIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water from rime-splintering', sampled_on_subcycle=.true.) + call addfld ('PSACWSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud water by snow', sampled_on_subcycle=.true.) + call addfld ('BERGSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water to snow from bergeron', sampled_on_subcycle=.true.) + call addfld ('BERGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water to cloud ice from bergeron',sampled_on_subcycle=.true.) + call addfld ('MELTO', (/ 'lev' /), 'A', 'kg/kg/s', 'Melting of cloud ice', sampled_on_subcycle=.true.) + call addfld ('MELTSTOT', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Melting of snow', sampled_on_subcycle=.true.) + call addfld ('MNUDEPO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Deposition Nucleation', sampled_on_subcycle=.true.) + call addfld ('HOMOO', (/ 'lev' /), 'A', 'kg/kg/s', 'Homogeneous freezing of cloud water', sampled_on_subcycle=.true.) + call addfld ('QCRESO', (/ 'lev' /), 'A', 'kg/kg/s', 'Residual condensation term for cloud water', sampled_on_subcycle=.true.) + call addfld ('PRCIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Autoconversion of cloud ice to snow', sampled_on_subcycle=.true.) + call addfld ('PRAIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud ice to snow', sampled_on_subcycle=.true.) + call addfld ('QIRESO', (/ 'lev' /), 'A', 'kg/kg/s', 'Residual deposition term for cloud ice', sampled_on_subcycle=.true.) + call addfld ('MNUCCRO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Heterogeneous freezing of rain to snow', sampled_on_subcycle=.true.) + call addfld ('MNUCCRIO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Heterogeneous freezing of rain to ice', sampled_on_subcycle=.true.) + call addfld ('PRACSO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Accretion of rain by snow', sampled_on_subcycle=.true.) + call addfld ('VAPDEPSO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Vapor deposition onto snow', sampled_on_subcycle=.true.) + call addfld ('MELTSDT', (/ 'trop_cld_lev' /), 'A', 'W/kg', 'Latent heating rate due to melting of snow', sampled_on_subcycle=.true.) + call addfld ('FRZRDT', (/ 'trop_cld_lev' /), 'A', 'W/kg', 'Latent heating rate due to homogeneous freezing of rain', sampled_on_subcycle=.true.) + call addfld ('QRSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rain mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) + call addfld ('QSSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Snow mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) + call addfld ('NNUCCCO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Immersion freezing of cloud water', sampled_on_subcycle=.true.) + call addfld ('NNUCCTO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Contact freezing of cloud water', sampled_on_subcycle=.true.) + call addfld ('NNUCCDO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Ice nucleation', sampled_on_subcycle=.true.) + call addfld ('NNUDEPO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Deposition Nucleation', sampled_on_subcycle=.true.) + call addfld ('NHOMO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Homogeneous freezing of cloud water', sampled_on_subcycle=.true.) + call addfld ('NNUCCRO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to heterogeneous freezing of rain to snow', sampled_on_subcycle=.true.) + call addfld ('NNUCCRIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Heterogeneous freezing of rain to ice', sampled_on_subcycle=.true.) + call addfld ('NSACWIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Ice Multiplication- Rime-splintering', sampled_on_subcycle=.true.) + call addfld ('NPRAO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of cloud water by rain', sampled_on_subcycle=.true.) + call addfld ('NPSACWSO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of cloud water by snow', sampled_on_subcycle=.true.) + call addfld ('NPRAIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of cloud ice to snow', sampled_on_subcycle=.true.) + call addfld ('NPRACSO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of rain by snow', sampled_on_subcycle=.true.) + call addfld ('NPRCO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Autoconversion of cloud water [to rain]', sampled_on_subcycle=.true.) + call addfld ('NPRCIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Autoconversion of cloud ice to snow', sampled_on_subcycle=.true.) + call addfld ('NCSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to cloud liquid sedimentation', sampled_on_subcycle=.true.) + call addfld ('NISEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to cloud ice sedimentation', sampled_on_subcycle=.true.) + call addfld ('NRSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to rain sedimentation', sampled_on_subcycle=.true.) + call addfld ('NSSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to snow sedimentation', sampled_on_subcycle=.true.) + call addfld ('NMELTO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Melting of cloud ice', sampled_on_subcycle=.true.) + call addfld ('NMELTS', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Melting of snow', sampled_on_subcycle=.true.) + + if (trim(micro_mg_warm_rain) == 'kk2000') then + call addfld ('qctend_KK2000', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'cloud liquid mass tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) + call addfld ('nctend_KK2000', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'cloud number mass tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) + call addfld ('qrtend_KK2000', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'rain mass tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) + call addfld ('nrtend_KK2000', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'rain number tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) + end if + if (trim(micro_mg_warm_rain) == 'sb2001') then + call addfld ('qctend_SB2001', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'cloud liquid mass tendency due to autoconversion & accretion from SB2001', sampled_on_subcycle=.true.) + call addfld ('nctend_SB2001', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'cloud liquid number tendency due to autoconversion & accretion from SB2001',sampled_on_subcycle=.true.) + call addfld ('qrtend_SB2001', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'rain mass tendency due to autoconversion & accretion from SB2001', sampled_on_subcycle=.true.) + call addfld ('nrtend_SB2001', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'rain number tendency due to autoconversion & accretion from SB2001', sampled_on_subcycle=.true.) + end if + call addfld ('LAMC', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter lambda for liquid', sampled_on_subcycle=.true. ) + call addfld ('LAMR', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter lambda for rain', sampled_on_subcycle=.true.) + call addfld ('PGAM', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter mu (pgam) for liquid', sampled_on_subcycle=.true.) + call addfld ('N0R', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter n0 for rain', sampled_on_subcycle=.true.) + + if (micro_mg_version > 2) then + call addfld ('NMELTG', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Melting of graupel', sampled_on_subcycle=.true.) + call addfld ('NGSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to graupel sedimentation', sampled_on_subcycle=.true.) + call addfld ('PSACRO', (/ 'lev' /), 'A', 'kg/kg/s', 'Collisions between rain & snow (Graupel collecting snow)',sampled_on_subcycle=.true.) + call addfld ('PRACGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Change in q collection rain by graupel', sampled_on_subcycle=.true.) + call addfld ('PSACWGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Change in q collection droplets by graupel', sampled_on_subcycle=.true.) + call addfld ('PGSACWO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q conversion to graupel due to collection droplets by snow', sampled_on_subcycle=.true.) + call addfld ('PGRACSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q conversion to graupel due to collection rain by snow', sampled_on_subcycle=.true.) + call addfld ('PRDGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Deposition of graupel', sampled_on_subcycle=.true.) + call addfld ('QMULTGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q change due to ice mult droplets/graupel', sampled_on_subcycle=.true.) + call addfld ('QMULTRGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q change due to ice mult rain/graupel', sampled_on_subcycle=.true.) + call addfld ('QGSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Graupel/Hail mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) + call addfld ('NPRACGO', (/ 'lev' /), 'A', '#/kg/s', 'Change N collection rain by graupel', sampled_on_subcycle=.true.) + call addfld ('NSCNGO', (/ 'lev' /), 'A', '#/kg/s', 'Change N conversion to graupel due to collection droplets by snow', sampled_on_subcycle=.true.) + call addfld ('NGRACSO', (/ 'lev' /), 'A', '#/kg/s', 'Change N conversion to graupel due to collection rain by snow', sampled_on_subcycle=.true.) + call addfld ('NMULTGO', (/ 'lev' /), 'A', '#/kg/s', 'Ice mult due to acc droplets by graupel', sampled_on_subcycle=.true.) + call addfld ('NMULTRGO', (/ 'lev' /), 'A', '#/kg/s', 'Ice mult due to acc rain by graupel', sampled_on_subcycle=.true.) + call addfld ('NPSACWGO', (/ 'lev' /), 'A', '#/kg/s', 'Change N collection droplets by graupel', sampled_on_subcycle=.true.) + call addfld ('CLDFGRAU', (/ 'lev' /), 'A', '1', 'Cloud fraction adjusted for graupel', sampled_on_subcycle=.true.) + call addfld ('MELTGTOT', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Melting of graupel', sampled_on_subcycle=.true.) + + end if + + call addfld ('RBFRAC', horiz_only, 'A', 'Fraction', 'Fraction of sky covered by a potential rainbow', sampled_on_subcycle=.true.) + call addfld ('RBFREQ', horiz_only, 'A', 'Frequency', 'Potential rainbow frequency', sampled_on_subcycle=.true.) + call addfld( 'rbSZA', horiz_only, 'I', 'degrees', 'solar zenith angle', sampled_on_subcycle=.true.) + + ! History variables for CAM5 microphysics + call addfld ('MPDT', (/ 'lev' /), 'A', 'W/kg', 'Heating tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDLIQ tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDNLIQ', (/ 'lev' /), 'A', '1/kg/s', 'NUMLIQ tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDNICE', (/ 'lev' /), 'A', '1/kg/s', 'NUMICE tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDW2V', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Vapor tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDW2I', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Ice tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDW2P', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Precip tendency - Morrison microphysics',sampled_on_subcycle=.true.) + call addfld ('MPDI2V', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Vapor tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDI2W', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Water tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('MPDI2P', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Precip tendency - Morrison microphysics', sampled_on_subcycle=.true.) + call addfld ('ICWNC', (/ 'lev' /), 'A', 'm-3', 'Prognostic in-cloud water number conc', sampled_on_subcycle=.true.) + call addfld ('ICINC', (/ 'lev' /), 'A', 'm-3', 'Prognostic in-cloud ice number conc', sampled_on_subcycle=.true.) + call addfld ('EFFLIQ_IND', (/ 'lev' /), 'A','Micron', 'Prognostic droplet effective radius (indirect effect)', sampled_on_subcycle=.true.) + call addfld ('CDNUMC', horiz_only, 'A', '1/m2', 'Vertically-integrated droplet concentration', sampled_on_subcycle=.true.) + call addfld ('MPICLWPI', horiz_only, 'A', 'kg/m2', 'Vertically-integrated & + &in-cloud Initial Liquid WP (Before Micro)', sampled_on_subcycle=.true.) + call addfld ('MPICIWPI', horiz_only, 'A', 'kg/m2', 'Vertically-integrated & + &in-cloud Initial Ice WP (Before Micro)', sampled_on_subcycle=.true.) + + ! This is provided as an example on how to write out subcolumn output + ! NOTE -- only 'I' should be used for sub-column fields as subc-columns could shift from time-step to time-step + if (use_subcol_microp) then + call addfld('FICE_SCOL', (/'psubcols','lev '/), 'I', 'fraction', & + 'Sub-column fractional ice content within cloud', flag_xyfill=.true., fill_value=1.e30_r8, sampled_on_subcycle=.true.) + call addfld('MPDICE_SCOL', (/'psubcols','lev '/), 'I', 'kg/kg/s', & + 'Sub-column CLDICE tendency - Morrison microphysics', flag_xyfill=.true., fill_value=1.e30_r8, sampled_on_subcycle=.true.) + call addfld('MPDLIQ_SCOL', (/'psubcols','lev '/), 'I', 'kg/kg/s', & + 'Sub-column CLDLIQ tendency - Morrison microphysics', flag_xyfill=.true., fill_value=1.e30_r8, sampled_on_subcycle=.true.) + end if + + + ! This is only if the coldpoint temperatures are being adjusted. + ! NOTE: Some fields related to these and output later are added in tropopause.F90. + if (micro_mg_adjust_cpt) then + call addfld ('TROPF_TADJ', (/ 'lev' /), 'A', 'K', 'Temperatures after cold point adjustment', sampled_on_subcycle=.true.) + call addfld ('TROPF_RHADJ', (/ 'lev' /), 'A', 'K', 'Relative Hunidity after cold point adjustment', sampled_on_subcycle=.true.) + call addfld ('TROPF_CDT', horiz_only, 'A', 'K', 'Cold point temperature adjustment', sampled_on_subcycle=.true.) + call addfld ('TROPF_CDZ', horiz_only, 'A', 'm', 'Distance of coldpoint from coldest model level',sampled_on_subcycle=.true.) + end if + + + ! Averaging for cloud particle number and size + call addfld ('AWNC', (/ 'lev' /), 'A', 'm-3', 'Average cloud water number conc', sampled_on_subcycle=.true.) + call addfld ('AWNI', (/ 'lev' /), 'A', 'm-3', 'Average cloud ice number conc', sampled_on_subcycle=.true.) + call addfld ('AREL', (/ 'lev' /), 'A', 'Micron', 'Average droplet effective radius', sampled_on_subcycle=.true.) + call addfld ('AREI', (/ 'lev' /), 'A', 'Micron', 'Average ice effective radius', sampled_on_subcycle=.true.) + ! Frequency arrays for above + call addfld ('FREQL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of liquid', sampled_on_subcycle=.true.) + call addfld ('FREQI', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of ice', sampled_on_subcycle=.true.) + + ! Average cloud top particle size and number (liq, ice) and frequency + call addfld ('ACTREL', horiz_only, 'A', 'Micron', 'Average Cloud Top droplet effective radius', sampled_on_subcycle=.true.) + call addfld ('ACTREI', horiz_only, 'A', 'Micron', 'Average Cloud Top ice effective radius', sampled_on_subcycle=.true.) + call addfld ('ACTNL', horiz_only, 'A', 'm-3', 'Average Cloud Top droplet number', sampled_on_subcycle=.true.) + call addfld ('ACTNI', horiz_only, 'A', 'm-3', 'Average Cloud Top ice number', sampled_on_subcycle=.true.) + + call addfld ('FCTL', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top liquid', sampled_on_subcycle=.true.) + call addfld ('FCTI', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top ice', sampled_on_subcycle=.true.) + + ! New frequency arrays for mixed phase and supercooled liquid (only and mixed) for (a) Cloud Top and (b) everywhere.. + call addfld ('FREQM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of mixed phase', sampled_on_subcycle=.true.) + call addfld ('FREQSL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of only supercooled liquid', sampled_on_subcycle=.true.) + call addfld ('FREQSLM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of super cooled liquid with ice', sampled_on_subcycle=.true.) + call addfld ('FCTM', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top mixed phase', sampled_on_subcycle=.true.) + call addfld ('FCTSL', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top only supercooled liquid', sampled_on_subcycle=.true.) + call addfld ('FCTSLM', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top super cooled liquid with ice', sampled_on_subcycle=.true.) + + call addfld ('LS_FLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s', 'ls stratiform gbm interface rain+snow flux', sampled_on_subcycle=.true.) + call addfld ('LS_FLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s', 'ls stratiform gbm interface snow flux', sampled_on_subcycle=.true.) + + call addfld ('REL', (/ 'lev' /), 'A', 'micron', 'MG REL stratiform cloud effective radius liquid', sampled_on_subcycle=.true.) + call addfld ('REI', (/ 'lev' /), 'A', 'micron', 'MG REI stratiform cloud effective radius ice', sampled_on_subcycle=.true.) + call addfld ('LS_REFFRAIN', (/ 'lev' /), 'A', 'micron', 'ls stratiform rain effective radius', sampled_on_subcycle=.true.) + call addfld ('LS_REFFSNOW', (/ 'lev' /), 'A', 'micron', 'ls stratiform snow effective radius', sampled_on_subcycle=.true.) + call addfld ('CV_REFFLIQ', (/ 'lev' /), 'A', 'micron', 'convective cloud liq effective radius', sampled_on_subcycle=.true.) + call addfld ('CV_REFFICE', (/ 'lev' /), 'A', 'micron', 'convective cloud ice effective radius', sampled_on_subcycle=.true.) + call addfld ('MG_SADICE', (/ 'lev' /), 'A', 'cm2/cm3', 'MG surface area density ice', sampled_on_subcycle=.true.) + call addfld ('MG_SADSNOW', (/ 'lev' /), 'A', 'cm2/cm3', 'MG surface area density snow', sampled_on_subcycle=.true.) + + ! diagnostic precip + call addfld ('QRAIN', (/ 'lev' /), 'A', 'kg/kg', 'Diagnostic grid-mean rain mixing ratio', sampled_on_subcycle=.true.) + call addfld ('QSNOW', (/ 'lev' /), 'A', 'kg/kg', 'Diagnostic grid-mean snow mixing ratio', sampled_on_subcycle=.true.) + call addfld ('NRAIN', (/ 'lev' /), 'A', 'm-3', 'Diagnostic grid-mean rain number conc', sampled_on_subcycle=.true.) + call addfld ('NSNOW', (/ 'lev' /), 'A', 'm-3', 'Diagnostic grid-mean snow number conc', sampled_on_subcycle=.true.) + + ! size of precip + call addfld ('RERCLD', (/ 'lev' /), 'A', 'm', 'Diagnostic effective radius of Liquid Cloud and Rain', sampled_on_subcycle=.true.) + call addfld ('DSNOW', (/ 'lev' /), 'A', 'm', 'Diagnostic grid-mean snow diameter', sampled_on_subcycle=.true.) + + ! diagnostic radar reflectivity, cloud-averaged + call addfld ('REFL', (/ 'lev' /), 'A', 'DBz', '94 GHz radar reflectivity', sampled_on_subcycle=.true.) + call addfld ('AREFL', (/ 'lev' /), 'A', 'DBz', 'Average 94 GHz radar reflectivity', sampled_on_subcycle=.true.) + call addfld ('FREFL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of radar reflectivity', sampled_on_subcycle=.true.) + + call addfld ('CSRFL', (/ 'lev' /), 'A', 'DBz', '94 GHz radar reflectivity (CloudSat thresholds)', sampled_on_subcycle=.true.) + call addfld ('ACSRFL', (/ 'lev' /), 'A', 'DBz', 'Average 94 GHz radar reflectivity (CloudSat thresholds)', sampled_on_subcycle=.true.) + call addfld ('FCSRFL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of radar reflectivity (CloudSat thresholds)', sampled_on_subcycle=.true.) + + call addfld ('AREFLZ', (/ 'lev' /), 'A', 'mm^6/m^3', 'Average 94 GHz radar reflectivity', sampled_on_subcycle=.true.) + + ! 10cm (rain) radar reflectivity + call addfld ('REFL10CM', (/ 'lev' /), 'A', 'DBz', '10cm (Rain) radar reflectivity (Dbz)', sampled_on_subcycle=.true.) + call addfld ('REFLZ10CM', (/ 'lev' /), 'A', 'mm^6/m^3', '10cm (Rain) radar reflectivity (Z units)', sampled_on_subcycle=.true.) + + ! Aerosol information + call addfld ('NCAL', (/ 'lev' /), 'A', '1/m3', 'Number Concentation Activated for Liquid', sampled_on_subcycle=.true.) + call addfld ('NCAI', (/ 'lev' /), 'A', '1/m3', 'Number Concentation Activated for Ice', sampled_on_subcycle=.true.) + + ! Average rain and snow mixing ratio (Q), number (N) and diameter (D), with frequency + call addfld ('AQRAIN', (/ 'lev' /), 'A', 'kg/kg', 'Average rain mixing ratio', sampled_on_subcycle=.true.) + call addfld ('AQSNOW', (/ 'lev' /), 'A', 'kg/kg', 'Average snow mixing ratio', sampled_on_subcycle=.true.) + call addfld ('ANRAIN', (/ 'lev' /), 'A', 'm-3', 'Average rain number conc', sampled_on_subcycle=.true.) + call addfld ('ANSNOW', (/ 'lev' /), 'A', 'm-3', 'Average snow number conc', sampled_on_subcycle=.true.) + call addfld ('ADRAIN', (/ 'lev' /), 'A', 'm', 'Average rain effective Diameter', sampled_on_subcycle=.true.) + call addfld ('ADSNOW', (/ 'lev' /), 'A', 'm', 'Average snow effective Diameter', sampled_on_subcycle=.true.) + call addfld ('FREQR', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of rain', sampled_on_subcycle=.true.) + call addfld ('FREQS', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of snow', sampled_on_subcycle=.true.) + + ! precipitation efficiency & other diagnostic fields + call addfld('PE' , horiz_only, 'A', '1', 'Stratiform Precipitation Efficiency (precip/cmeliq)', sampled_on_subcycle=.true.) + call addfld('APRL' , horiz_only, 'A', 'm/s', 'Average Stratiform Precip Rate over efficiency calculation', sampled_on_subcycle=.true.) + call addfld('PEFRAC', horiz_only, 'A', '1', 'Fraction of timesteps precip efficiency reported', sampled_on_subcycle=.true.) + call addfld('VPRCO' , horiz_only, 'A', 'kg/kg/s', 'Vertical average of autoconversion rate', sampled_on_subcycle=.true.) + call addfld('VPRAO' , horiz_only, 'A', 'kg/kg/s', 'Vertical average of accretion rate', sampled_on_subcycle=.true.) + call addfld('RACAU' , horiz_only, 'A', 'kg/kg/s', 'Accretion/autoconversion ratio from vertical average', sampled_on_subcycle=.true.) + + call addfld('UMR', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted rain fallspeed', sampled_on_subcycle=.true.) + call addfld('UMS', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted snow fallspeed', sampled_on_subcycle=.true.) + + if (micro_mg_version > 2) then + call addfld('UMG', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted graupel/hail fallspeed', sampled_on_subcycle=.true.) + call addfld ('FREQG', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of Graupel', sampled_on_subcycle=.true.) + call addfld ('LS_REFFGRAU', (/ 'lev' /), 'A', 'micron', 'ls stratiform graupel/hail effective radius', sampled_on_subcycle=.true.) + call addfld ('AQGRAU', (/ 'lev' /), 'A', 'kg/kg', 'Average graupel/hail mixing ratio', sampled_on_subcycle=.true.) + call addfld ('ANGRAU', (/ 'lev' /), 'A', 'm-3', 'Average graupel/hail number conc', sampled_on_subcycle=.true.) + end if + + + ! qc limiter (only output in versions 1.5 and later) + call addfld('QCRAT', (/ 'lev' /), 'A', 'fraction', 'Qc Limiter: Fraction of qc tendency applied', sampled_on_subcycle=.true.) + + ! determine the add_default fields + call phys_getopts(history_amwg_out = history_amwg , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = budget_histfile) + + if (history_amwg) then + call add_default ('FICE ', 1, ' ') + call add_default ('AQRAIN ', 1, ' ') + call add_default ('AQSNOW ', 1, ' ') + call add_default ('ANRAIN ', 1, ' ') + call add_default ('ANSNOW ', 1, ' ') + call add_default ('ADRAIN ', 1, ' ') + call add_default ('ADSNOW ', 1, ' ') + call add_default ('AREI ', 1, ' ') + call add_default ('AREL ', 1, ' ') + call add_default ('AWNC ', 1, ' ') + call add_default ('AWNI ', 1, ' ') + call add_default ('CDNUMC ', 1, ' ') + call add_default ('FREQR ', 1, ' ') + call add_default ('FREQS ', 1, ' ') + call add_default ('FREQL ', 1, ' ') + call add_default ('FREQI ', 1, ' ') + do m = 1, ncnst + call cnst_get_ind(cnst_names(m), mm) + call add_default(cnst_name(mm), 1, ' ') + end do + end if + + if ( history_budget ) then + call add_default ('EVAPSNOW ', budget_histfile, ' ') + call add_default ('EVAPPREC ', budget_histfile, ' ') + call add_default ('QVRES ', budget_histfile, ' ') + call add_default ('QISEVAP ', budget_histfile, ' ') + call add_default ('QCSEVAP ', budget_histfile, ' ') + call add_default ('QISEDTEN ', budget_histfile, ' ') + call add_default ('QCSEDTEN ', budget_histfile, ' ') + call add_default ('QIRESO ', budget_histfile, ' ') + call add_default ('QCRESO ', budget_histfile, ' ') + call add_default ('QRSEDTEN ', budget_histfile, ' ') + call add_default ('QSSEDTEN ', budget_histfile, ' ') + call add_default ('PSACWSO ', budget_histfile, ' ') + call add_default ('PRCO ', budget_histfile, ' ') + call add_default ('PRCIO ', budget_histfile, ' ') + call add_default ('PRAO ', budget_histfile, ' ') + call add_default ('PRAIO ', budget_histfile, ' ') + call add_default ('PRACSO ', budget_histfile, ' ') + call add_default ('VAPDEPSO ', budget_histfile, ' ') + call add_default ('MSACWIO ', budget_histfile, ' ') + call add_default ('MPDW2V ', budget_histfile, ' ') + call add_default ('MPDW2P ', budget_histfile, ' ') + call add_default ('MPDW2I ', budget_histfile, ' ') + call add_default ('MPDT ', budget_histfile, ' ') + call add_default ('MPDQ ', budget_histfile, ' ') + call add_default ('MPDLIQ ', budget_histfile, ' ') + call add_default ('MPDICE ', budget_histfile, ' ') + call add_default ('MPDI2W ', budget_histfile, ' ') + call add_default ('MPDI2V ', budget_histfile, ' ') + call add_default ('MPDI2P ', budget_histfile, ' ') + call add_default ('MNUCCTO ', budget_histfile, ' ') + call add_default ('MNUCCRO ', budget_histfile, ' ') + call add_default ('MNUCCRIO ', budget_histfile, ' ') + call add_default ('MNUCCCO ', budget_histfile, ' ') + call add_default ('MELTSDT ', budget_histfile, ' ') + call add_default ('MELTO ', budget_histfile, ' ') + call add_default ('HOMOO ', budget_histfile, ' ') + call add_default ('FRZRDT ', budget_histfile, ' ') + call add_default ('CMEIOUT ', budget_histfile, ' ') + call add_default ('BERGSO ', budget_histfile, ' ') + call add_default ('BERGO ', budget_histfile, ' ') + call add_default ('MELTSTOT ', budget_histfile, ' ') + call add_default ('MNUDEPO ', budget_histfile, ' ') + call add_default ('NNUCCCO ', budget_histfile, ' ') + call add_default ('NNUCCTO ', budget_histfile, ' ') + call add_default ('NNUCCDO ', budget_histfile, ' ') + call add_default ('NNUDEPO ', budget_histfile, ' ') + call add_default ('NHOMO ', budget_histfile, ' ') + call add_default ('NNUCCRO ', budget_histfile, ' ') + call add_default ('NNUCCRIO ', budget_histfile, ' ') + call add_default ('NSACWIO ', budget_histfile, ' ') + call add_default ('NPRAO ', budget_histfile, ' ') + call add_default ('NPSACWSO ', budget_histfile, ' ') + call add_default ('NPRAIO ', budget_histfile, ' ') + call add_default ('NPRACSO ', budget_histfile, ' ') + call add_default ('NPRCO ', budget_histfile, ' ') + call add_default ('NPRCIO ', budget_histfile, ' ') + call add_default ('NCSEDTEN ', budget_histfile, ' ') + call add_default ('NISEDTEN ', budget_histfile, ' ') + call add_default ('NRSEDTEN ', budget_histfile, ' ') + call add_default ('NSSEDTEN ', budget_histfile, ' ') + call add_default ('NMELTO ', budget_histfile, ' ') + call add_default ('NMELTS ', budget_histfile, ' ') + call add_default ('NCAL ', budget_histfile, ' ') + if (micro_mg_version > 2) then + call add_default ('QGSEDTEN ', budget_histfile, ' ') + call add_default ('PSACRO ', budget_histfile, ' ') + call add_default ('PRACGO ', budget_histfile, ' ') + call add_default ('PSACWGO ', budget_histfile, ' ') + call add_default ('PGSACWO ', budget_histfile, ' ') + call add_default ('PGRACSO ', budget_histfile, ' ') + call add_default ('PRDGO ', budget_histfile, ' ') + call add_default ('QMULTGO ', budget_histfile, ' ') + call add_default ('QMULTRGO ', budget_histfile, ' ') + call add_default ('MELTGTOT ', budget_histfile, ' ') + call add_default ('NPRACGO ', budget_histfile, ' ') + call add_default ('NSCNGO ', budget_histfile, ' ') + call add_default ('NGRACSO ', budget_histfile, ' ') + call add_default ('NMULTGO ', budget_histfile, ' ') + call add_default ('NMULTRGO ', budget_histfile, ' ') + call add_default ('NPSACWGO ', budget_histfile, ' ') + call add_default ('NGSEDTEN ', budget_histfile, ' ') + call add_default ('NMELTG ', budget_histfile, ' ') + end if + call add_default(cnst_name(ixcldliq), budget_histfile, ' ') + call add_default(cnst_name(ixcldice), budget_histfile, ' ') + call add_default(apcnst (ixcldliq), budget_histfile, ' ') + call add_default(apcnst (ixcldice), budget_histfile, ' ') + call add_default(bpcnst (ixcldliq), budget_histfile, ' ') + call add_default(bpcnst (ixcldice), budget_histfile, ' ') + call add_default(cnst_name(ixrain), budget_histfile, ' ') + call add_default(cnst_name(ixsnow), budget_histfile, ' ') + call add_default(apcnst (ixrain), budget_histfile, ' ') + call add_default(apcnst (ixsnow), budget_histfile, ' ') + call add_default(bpcnst (ixrain), budget_histfile, ' ') + call add_default(bpcnst (ixsnow), budget_histfile, ' ') + + if (micro_mg_version > 2) then + call add_default(cnst_name(ixgraupel), budget_histfile, ' ') + call add_default(apcnst (ixgraupel), budget_histfile, ' ') + call add_default(bpcnst (ixgraupel), budget_histfile, ' ') + end if + + end if + + ! physics buffer indices + ast_idx = pbuf_get_index('AST') + cld_idx = pbuf_get_index('CLD') + concld_idx = pbuf_get_index('CONCLD') + prec_dp_idx = pbuf_get_index('PREC_DP') + prec_sh_idx = pbuf_get_index('PREC_SH') + + naai_idx = pbuf_get_index('NAAI') + naai_hom_idx = pbuf_get_index('NAAI_HOM') + npccn_idx = pbuf_get_index('NPCCN') + rndst_idx = pbuf_get_index('RNDST') + nacon_idx = pbuf_get_index('NACON') + + prec_str_idx = pbuf_get_index('PREC_STR') + snow_str_idx = pbuf_get_index('SNOW_STR') + prec_sed_idx = pbuf_get_index('PREC_SED') + snow_sed_idx = pbuf_get_index('SNOW_SED') + prec_pcw_idx = pbuf_get_index('PREC_PCW') + snow_pcw_idx = pbuf_get_index('SNOW_PCW') + + cmeliq_idx = pbuf_get_index('CMELIQ') + + ! These fields may have been added, so don't abort if they have not been + qsatfac_idx = pbuf_get_index('QSATFAC', ierr) + qrain_idx = pbuf_get_index('QRAIN', ierr) + qsnow_idx = pbuf_get_index('QSNOW', ierr) + nrain_idx = pbuf_get_index('NRAIN', ierr) + nsnow_idx = pbuf_get_index('NSNOW', ierr) + + ! fields for heterogeneous freezing + frzimm_idx = pbuf_get_index('FRZIMM', ierr) + frzcnt_idx = pbuf_get_index('FRZCNT', ierr) + frzdep_idx = pbuf_get_index('FRZDEP', ierr) + + ! Initialize physics buffer grid fields for accumulating precip and condensation + if (is_first_step()) then + call pbuf_set_field(pbuf2d, cldo_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8) + call pbuf_set_field(pbuf2d, acpr_idx, 0._r8) + call pbuf_set_field(pbuf2d, acgcme_idx, 0._r8) + call pbuf_set_field(pbuf2d, acnum_idx, 0) + call pbuf_set_field(pbuf2d, relvar_idx, 2._r8) + call pbuf_set_field(pbuf2d, accre_enhan_idx, 1._r8) + call pbuf_set_field(pbuf2d, am_evp_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, evprain_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, evpsnow_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, prer_evap_idx, 0._r8) + call pbuf_set_field(pbuf2d, bergso_idx, 0._r8) + call pbuf_set_field(pbuf2d, icswp_idx, 0._r8) + call pbuf_set_field(pbuf2d, cldfsnow_idx, 0._r8) + call pbuf_set_field(pbuf2d, dei_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, des_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, mu_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, lambdac_idx, 0.0_r8) + + if (degrau_idx > 0) call pbuf_set_field(pbuf2d, degrau_idx, 0.0_r8) + if (icgrauwp_idx > 0) call pbuf_set_field(pbuf2d, icgrauwp_idx, 0.0_r8) + if (qrain_idx > 0) call pbuf_set_field(pbuf2d, qrain_idx, 0._r8) + if (qsnow_idx > 0) call pbuf_set_field(pbuf2d, qsnow_idx, 0._r8) + if (nrain_idx > 0) call pbuf_set_field(pbuf2d, nrain_idx, 0._r8) + if (nsnow_idx > 0) call pbuf_set_field(pbuf2d, nsnow_idx, 0._r8) + if (qcsedten_idx > 0) call pbuf_set_field(pbuf2d, qcsedten_idx, 0._r8) + if (qrsedten_idx > 0) call pbuf_set_field(pbuf2d, qrsedten_idx, 0._r8) + if (qisedten_idx > 0) call pbuf_set_field(pbuf2d, qisedten_idx, 0._r8) + if (qssedten_idx > 0) call pbuf_set_field(pbuf2d, qssedten_idx, 0._r8) + if (qgsedten_idx > 0) call pbuf_set_field(pbuf2d, qgsedten_idx, 0._r8) !+tht + if (vtrmc_idx > 0) call pbuf_set_field(pbuf2d, vtrmc_idx, 0._r8) + if (umr_idx > 0) call pbuf_set_field(pbuf2d, umr_idx, 0._r8) + if (vtrmi_idx > 0) call pbuf_set_field(pbuf2d, vtrmi_idx, 0._r8) + if (ums_idx > 0) call pbuf_set_field(pbuf2d, ums_idx, 0._r8) + if (qcsevap_idx > 0) call pbuf_set_field(pbuf2d, qcsevap_idx, 0._r8) + if (qisevap_idx > 0) call pbuf_set_field(pbuf2d, qisevap_idx, 0._r8) + + ! If sub-columns turned on, need to set the sub-column fields as well + if (use_subcol_microp) then + call pbuf_set_field(pbuf2d, cldo_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qlst_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, icswp_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cldfsnow_idx,0._r8, col_type=col_type_subcol) + end if + + end if + +end subroutine micro_pumas_cam_init + +!=============================================================================== + +subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) + + use micro_pumas_utils, only: size_dist_param_basic, size_dist_param_liq + use micro_pumas_utils, only: mg_liq_props, mg_ice_props, avg_diameter + use micro_pumas_utils, only: rhoi, rhosn, rhow, rhows, rhog, qsmall, mincld + + use micro_pumas_ccpp, only: micro_pumas_ccpp_run + + use physics_buffer, only: pbuf_col_type_index + use subcol, only: subcol_field_avg + use tropopause, only: tropopause_find_cam, TROP_ALG_CPP, TROP_ALG_NONE, NOTFOUND + use wv_saturation, only: qsat + use infnan, only: nan, assignment(=) + use cam_abortutils, only: handle_allocate_error + + use stochastic_tau_cam, only: ncd + + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtime + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variables + + type(proc_rates_type) :: proc_rates + + integer :: lchnk, ncol, psetcols, ngrdcol + + integer :: i, k, itim_old, it + + real(r8), parameter :: micron2meter = 1.e6_r8 + real(r8), parameter :: shapeparam = 1.e5_r8 + + real(r8), pointer :: naai(:,:) ! ice nucleation number + real(r8), pointer :: naai_hom(:,:) ! ice nucleation number (homogeneous) + real(r8), pointer :: npccn(:,:) ! liquid activation number tendency + real(r8), pointer :: rndst(:,:,:) + real(r8), pointer :: nacon(:,:,:) + real(r8), pointer :: am_evp_st_grid(:,:) ! Evaporation area of stratiform precipitation. 0<= am_evp_st <=1. + real(r8), pointer :: evprain_st_grid(:,:) ! Evaporation rate of stratiform rain [kg/kg/s] + real(r8), pointer :: evpsnow_st_grid(:,:) ! Evaporation rate of stratiform snow [kg/kg/s] + + real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] + real(r8), pointer :: snow_str(:) ! [Total] Sfc flux of snow from stratiform [ m/s ] + real(r8), pointer :: prec_sed(:) ! Surface flux of total cloud water from sedimentation + real(r8), pointer :: snow_sed(:) ! Surface flux of cloud ice from sedimentation + real(r8), pointer :: prec_pcw(:) ! Sfc flux of precip from microphysics [ m/s ] + real(r8), pointer :: snow_pcw(:) ! Sfc flux of snow from microphysics [ m/s ] + + real(r8), pointer :: ast(:,:) ! Relative humidity cloud fraction + real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. + real(r8), pointer :: alst_mic(:,:) + real(r8), pointer :: aist_mic(:,:) + real(r8), pointer :: cldo(:,:) ! Old cloud fraction + real(r8), pointer :: nevapr(:,:) ! Evaporation of total precipitation (rain + snow) + real(r8), pointer :: prer_evap(:,:) ! precipitation evaporation rate + real(r8), pointer :: relvar(:,:) ! relative variance of cloud water + real(r8), pointer :: accre_enhan(:,:) ! optional accretion enhancement for experimentation + real(r8), pointer :: prain(:,:) ! Total precipitation (rain + snow) + real(r8), pointer :: dei(:,:) ! Ice effective diameter (meters) + real(r8), pointer :: mu(:,:) ! Size distribution shape parameter for radiation + real(r8), pointer :: lambdac(:,:) ! Size distribution slope parameter for radiation + real(r8), pointer :: des(:,:) ! Snow effective diameter (m) + real(r8), pointer :: degrau(:,:) ! Graupel effective diameter (m) + real(r8), pointer :: bergstot(:,:) ! Conversion of cloud water to snow from bergeron + + !These variables need to be extracted from the + !proc_rates DDT in order for the subcolumn averaging + !routine to work properly when writing out diagnostic + !fields. + real(r8) :: evapsnow_sc(state%psetcols,pver-top_lev+1) + real(r8) :: bergstot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qcrestot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: melttot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: mnuccctot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: mnuccttot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: bergtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: homotot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: msacwitot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: psacwstot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: cmeitot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qirestot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: prcitot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: praitot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: pratot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: prctot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qcsedten_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qisedten_sc(state%psetcols,pver-top_lev+1) + real(r8) :: vtrmc_sc(state%psetcols,pver-top_lev+1) + real(r8) :: vtrmi_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qcsevap_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qisevap_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qrsedten_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qssedten_sc(state%psetcols,pver-top_lev+1) + real(r8) :: umr_sc(state%psetcols,pver-top_lev+1) + real(r8) :: ums_sc(state%psetcols,pver-top_lev+1) + real(r8) :: psacrtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: pracgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: psacwgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: pgsacwtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: pgracstot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: prdgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qmultgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: qmultrgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: npracgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: nscngtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: ngracstot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: nmultgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: nmultrgtot_sc(state%psetcols,pver-top_lev+1) + real(r8) :: npsacwgtot_sc(state%psetcols,pver-top_lev+1) + + real(r8) :: rho(state%psetcols,pver) + real(r8) :: cldmax(state%psetcols,pver) + + real(r8) :: rate1cld(state%psetcols,pver) ! array to hold rate1ord_cw2pr_st from microphysics + + real(r8) :: tlat(state%psetcols,pver) + real(r8) :: qvlat(state%psetcols,pver) + real(r8) :: qcten(state%psetcols,pver) + real(r8) :: qiten(state%psetcols,pver) + real(r8) :: ncten(state%psetcols,pver) + real(r8) :: niten(state%psetcols,pver) + + real(r8) :: qrten(state%psetcols,pver) + real(r8) :: qsten(state%psetcols,pver) + real(r8) :: nrten(state%psetcols,pver) + real(r8) :: nsten(state%psetcols,pver) + real(r8) :: qgten(state%psetcols,pver) + real(r8) :: ngten(state%psetcols,pver) + + real(r8) :: prect(state%psetcols) + real(r8) :: preci(state%psetcols) + real(r8) :: am_evp_st(state%psetcols,pver) ! Area over which precip evaporates + real(r8) :: cmeice(state%psetcols,pver) ! Rate of cond-evap of ice within the cloud + real(r8) :: qsout(state%psetcols,pver) ! Snow mixing ratio + real(r8) :: cflx(state%psetcols,pverp) ! grid-box avg liq condensate flux (kg m^-2 s^-1) + real(r8) :: iflx(state%psetcols,pverp) ! grid-box avg ice condensate flux (kg m^-2 s^-1) + real(r8) :: rflx(state%psetcols,pverp) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8) :: sflx(state%psetcols,pverp) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8) :: gflx(state%psetcols,pverp) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8) :: qrout(state%psetcols,pver) ! Rain mixing ratio + + real(r8) :: nrout(state%psetcols,pver) + real(r8) :: nsout(state%psetcols,pver) + real(r8) :: refl(state%psetcols,pver) ! analytic radar reflectivity + real(r8) :: arefl(state%psetcols,pver) ! average reflectivity will zero points outside valid range + real(r8) :: areflz(state%psetcols,pver) ! average reflectivity in z. + real(r8) :: frefl(state%psetcols,pver) + real(r8) :: csrfl(state%psetcols,pver) ! cloudsat reflectivity + real(r8) :: acsrfl(state%psetcols,pver) ! cloudsat average + real(r8) :: fcsrfl(state%psetcols,pver) + real(r8) :: refl10cm(state%psetcols,pver) ! analytic radar reflectivity + real(r8) :: reflz10cm(state%psetcols,pver) ! analytic radar reflectivity Z + real(r8) :: rercld(state%psetcols,pver) ! effective radius calculation for rain + cloud + real(r8) :: ncai(state%psetcols,pver) ! output number conc of ice nuclei available (1/m3) + real(r8) :: ncal(state%psetcols,pver) ! output number conc of CCN (1/m3) + real(r8) :: qrout2(state%psetcols,pver) + real(r8) :: qsout2(state%psetcols,pver) + real(r8) :: nrout2(state%psetcols,pver) + real(r8) :: nsout2(state%psetcols,pver) + real(r8) :: freqs(state%psetcols,pver) + real(r8) :: freqr(state%psetcols,pver) + real(r8) :: nfice(state%psetcols,pver) + real(r8) :: qcrat(state%psetcols,pver) ! qc limiter ratio (1=no limit) + +!Hail/Graupel Output + real(r8) :: freqg(state%psetcols,pver) + real(r8) :: qgout(state%psetcols,pver) + real(r8) :: ngout(state%psetcols,pver) + real(r8) :: dgout(state%psetcols,pver) + real(r8) :: qgout2(state%psetcols,pver) + real(r8) :: ngout2(state%psetcols,pver) + real(r8) :: dgout2(state%psetcols,pver) + + ! Dummy arrays for cases where we throw away the MG version and + ! recalculate sizes on the CAM grid to avoid time/subcolumn averaging + ! issues. + real(r8) :: rel_fn_dum(state%ncol,pver) + real(r8) :: dsout2_dum(state%ncol,pver) + real(r8) :: drout_dum(state%ncol,pver) + real(r8) :: reff_rain_dum(state%ncol,pver) + real(r8) :: reff_snow_dum(state%ncol,pver) + real(r8) :: reff_grau_dum(state%ncol,pver) !not used for now or passed to COSP. + real(r8), target :: nan_array(state%ncol,pver) ! Array for NaN's + + ! Heterogeneous-only version of mnuccdtot. + real(r8) :: mnuccdohet(state%psetcols,pver) + + ! physics buffer fields for COSP simulator + real(r8), pointer :: mgflxprc(:,:) ! MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces (kg/m2/s) + real(r8), pointer :: mgflxsnw(:,:) ! MG grid-box mean flux_large_scale_cloud_snow at interfaces (kg/m2/s) + real(r8), pointer :: mgmrprc(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces (kg/kg) + real(r8), pointer :: mgmrsnw(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces (kg/kg) + real(r8), pointer :: mgreffrain_grid(:,:) ! MG diagnostic rain effective radius (um) + real(r8), pointer :: mgreffsnow_grid(:,:) ! MG diagnostic snow effective radius (um) + real(r8), pointer :: cvreffliq(:,:) ! convective cloud liquid effective radius (um) + real(r8), pointer :: cvreffice(:,:) ! convective cloud ice effective radius (um) + + ! physics buffer fields used with CARMA + real(r8), pointer, dimension(:,:) :: tnd_qsnow ! external tendency on snow mass (kg/kg/s) + real(r8), pointer, dimension(:,:) :: tnd_nsnow ! external tendency on snow number(#/kg/s) + real(r8), pointer, dimension(:,:) :: re_ice ! ice effective radius (m) + + real(r8), pointer :: rate1ord_cw2pr_st(:,:) ! 1st order rate for direct conversion of + ! strat. cloud water to precip (1/s) ! rce 2010/05/01 + real(r8), pointer :: wsedl(:,:) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] + + + real(r8), pointer :: CC_T(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qv(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_ql(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qi(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_nl(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_ni(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qlst(:,:) ! In-liquid stratus microphysical tendency + + ! variables for heterogeneous freezing + real(r8), pointer :: frzimm(:,:) + real(r8), pointer :: frzcnt(:,:) + real(r8), pointer :: frzdep(:,:) + + real(r8), pointer :: qme(:,:) + + ! A local copy of state is used for diagnostic calculations + type(physics_state) :: state_loc + type(physics_ptend) :: ptend_loc + + real(r8) :: icecldf(state%psetcols,pver) ! Ice cloud fraction + real(r8) :: liqcldf(state%psetcols,pver) ! Liquid cloud fraction (combined into cloud) + + real(r8), pointer :: rel(:,:) ! Liquid effective drop radius (microns) + real(r8), pointer :: rei(:,:) ! Ice effective drop size (microns) + real(r8), pointer :: sadice(:,:) ! Ice surface area density (cm2/cm3) + real(r8), pointer :: sadsnow(:,:) ! Snow surface area density (cm2/cm3) + + + real(r8), pointer :: cmeliq(:,:) + + real(r8), pointer :: cld(:,:) ! Total cloud fraction + real(r8), pointer :: concld(:,:) ! Convective cloud fraction + real(r8), pointer :: prec_dp(:) ! Deep Convective precip + real(r8), pointer :: prec_sh(:) ! Shallow Convective precip + + real(r8), pointer :: iciwpst(:,:) ! Stratiform in-cloud ice water path for radiation + real(r8), pointer :: iclwpst(:,:) ! Stratiform in-cloud liquid water path for radiation + real(r8), pointer :: cldfsnow(:,:) ! Cloud fraction for liquid+snow + real(r8), pointer :: icswp(:,:) ! In-cloud snow water path + + real(r8), pointer :: cldfgrau(:,:) ! Cloud fraction for liquid+snow + real(r8), pointer :: icgrauwp(:,:) ! In-cloud snow water path + + real(r8) :: icimrst(state%psetcols,pver) ! In stratus ice mixing ratio + real(r8) :: icwmrst(state%psetcols,pver) ! In stratus water mixing ratio + real(r8) :: icinc(state%psetcols,pver) ! In cloud ice number conc + real(r8) :: icwnc(state%psetcols,pver) ! In cloud water number conc + + real(r8) :: iclwpi(state%psetcols) ! Vertically-integrated in-cloud Liquid WP before microphysics + real(r8) :: iciwpi(state%psetcols) ! Vertically-integrated in-cloud Ice WP before microphysics + + ! Averaging arrays for effective radius and number.... + real(r8) :: efiout_grid(pcols,pver) + real(r8) :: efcout_grid(pcols,pver) + real(r8) :: ncout_grid(pcols,pver) + real(r8) :: niout_grid(pcols,pver) + real(r8) :: freqi_grid(pcols,pver) + real(r8) :: freql_grid(pcols,pver) + +! Averaging arrays for supercooled liquid + real(r8) :: freqm_grid(pcols,pver) + real(r8) :: freqsl_grid(pcols,pver) + real(r8) :: freqslm_grid(pcols,pver) + real(r8) :: fctm_grid(pcols) + real(r8) :: fctsl_grid(pcols) + real(r8) :: fctslm_grid(pcols) + + real(r8) :: cdnumc_grid(pcols) ! Vertically-integrated droplet concentration + real(r8) :: icimrst_grid_out(pcols,pver) ! In stratus ice mixing ratio + real(r8) :: icwmrst_grid_out(pcols,pver) ! In stratus water mixing ratio + + ! Cloud fraction used for precipitation. + real(r8) :: cldmax_grid(pcols,pver) + + ! Average cloud top radius & number + real(r8) :: ctrel_grid(pcols) + real(r8) :: ctrei_grid(pcols) + real(r8) :: ctnl_grid(pcols) + real(r8) :: ctni_grid(pcols) + real(r8) :: fcti_grid(pcols) + real(r8) :: fctl_grid(pcols) + + real(r8) :: ftem_grid(pcols,pver) + + ! Variables for precip efficiency calculation + real(r8) :: minlwp ! LWP threshold + + real(r8), pointer, dimension(:) :: acprecl_grid ! accumulated precip across timesteps + real(r8), pointer, dimension(:) :: acgcme_grid ! accumulated condensation across timesteps + integer, pointer, dimension(:) :: acnum_grid ! counter for # timesteps accumulated + + ! Variables for liquid water path and column condensation + real(r8) :: tgliqwp_grid(pcols) ! column liquid + real(r8) :: tgcmeliq_grid(pcols) ! column condensation rate (units) + + real(r8) :: pe_grid(pcols) ! precip efficiency for output + real(r8) :: pefrac_grid(pcols) ! fraction of time precip efficiency is written out + real(r8) :: tpr_grid(pcols) ! average accumulated precipitation rate in pe calculation + + ! variables for autoconversion and accretion vertical averages + real(r8) :: vprco_grid(pcols) ! vertical average autoconversion + real(r8) :: vprao_grid(pcols) ! vertical average accretion + real(r8) :: racau_grid(pcols) ! ratio of vertical averages + integer :: cnt_grid(pcols) ! counters + + logical :: lq(pcnst) + + real(r8) :: icimrst_grid(pcols,pver) ! stratus ice mixing ratio - on grid + real(r8) :: icwmrst_grid(pcols,pver) ! stratus water mixing ratio - on grid + + real(r8), pointer :: lambdac_grid(:,:) + real(r8), pointer :: mu_grid(:,:) + real(r8), pointer :: rel_grid(:,:) + real(r8), pointer :: rei_grid(:,:) + real(r8), pointer :: sadice_grid(:,:) + real(r8), pointer :: sadsnow_grid(:,:) + real(r8), pointer :: dei_grid(:,:) + real(r8), pointer :: des_grid(:,:) + real(r8), pointer :: iclwpst_grid(:,:) + real(r8), pointer :: degrau_grid(:,:) + + real(r8) :: rho_grid(pcols,pver) + real(r8) :: liqcldf_grid(pcols,pver) + real(r8) :: qsout_grid(pcols,pver) + real(r8) :: ncic_grid(pcols,pver) + real(r8) :: niic_grid(pcols,pver) + real(r8) :: rel_fn_grid(pcols,pver) ! Ice effective drop size at fixed number (indirect effect) (microns) - on grid + real(r8) :: qrout_grid(pcols,pver) + real(r8) :: drout2_grid(pcols,pver) + real(r8) :: dsout2_grid(pcols,pver) + real(r8) :: nsout_grid(pcols,pver) + real(r8) :: nrout_grid(pcols,pver) + real(r8) :: reff_rain_grid(pcols,pver) + real(r8) :: reff_snow_grid(pcols,pver) + real(r8) :: reff_grau_grid(pcols,pver) + real(r8) :: cld_grid(pcols,pver) + real(r8) :: pdel_grid(pcols,pver) + real(r8) :: prco_grid(pcols,pver) + real(r8) :: prao_grid(pcols,pver) + real(r8) :: icecldf_grid(pcols,pver) + real(r8) :: icwnc_grid(pcols,pver) + real(r8) :: icinc_grid(pcols,pver) + real(r8) :: qcreso_grid(pcols,pver) + real(r8) :: melto_grid(pcols,pver) + real(r8) :: mnuccco_grid(pcols,pver) + real(r8) :: mnuccto_grid(pcols,pver) + real(r8) :: bergo_grid(pcols,pver) + real(r8) :: homoo_grid(pcols,pver) + real(r8) :: msacwio_grid(pcols,pver) + real(r8) :: psacwso_grid(pcols,pver) + real(r8) :: cmeiout_grid(pcols,pver) + real(r8) :: qireso_grid(pcols,pver) + real(r8) :: prcio_grid(pcols,pver) + real(r8) :: praio_grid(pcols,pver) + real(r8) :: psacro_grid(pcols,pver) + real(r8) :: pracgo_grid(pcols,pver) + real(r8) :: psacwgo_grid(pcols,pver) + real(r8) :: pgsacwo_grid(pcols,pver) + real(r8) :: pgracso_grid(pcols,pver) + real(r8) :: prdgo_grid(pcols,pver) + real(r8) :: qmultgo_grid(pcols,pver) + real(r8) :: qmultrgo_grid(pcols,pver) + real(r8) :: npracgo_grid(pcols,pver) + real(r8) :: nscngo_grid(pcols,pver) + real(r8) :: ngracso_grid(pcols,pver) + real(r8) :: nmultgo_grid(pcols,pver) + real(r8) :: nmultrgo_grid(pcols,pver) + real(r8) :: npsacwgo_grid(pcols,pver) + real(r8) :: qcsedtenout_grid(pcols,pver) + real(r8) :: qrsedtenout_grid(pcols,pver) + real(r8) :: qisedtenout_grid(pcols,pver) + real(r8) :: qssedtenout_grid(pcols,pver) + real(r8) :: qgsedtenout_grid(pcols,pver)!+tht + real(r8) :: vtrmcout_grid(pcols,pver) + real(r8) :: umrout_grid(pcols,pver) + real(r8) :: vtrmiout_grid(pcols,pver) + real(r8) :: umsout_grid(pcols,pver) + real(r8) :: qcsevapout_grid(pcols,pver) + real(r8) :: qisevapout_grid(pcols,pver) + + real(r8) :: nc_grid(pcols,pver) + real(r8) :: ni_grid(pcols,pver) + real(r8) :: qr_grid(pcols,pver) + real(r8) :: nr_grid(pcols,pver) + real(r8) :: qs_grid(pcols,pver) + real(r8) :: ns_grid(pcols,pver) + real(r8) :: qg_grid(pcols,pver) + real(r8) :: ng_grid(pcols,pver) + + real(r8) :: dgout2_grid(pcols,pver) + + real(r8) :: cp_rh(pcols,pver) + real(r8) :: cp_t(pcols) + real(r8) :: cp_z(pcols) + real(r8) :: cp_dt(pcols) + real(r8) :: cp_dz(pcols) + integer :: troplev(pcols) + real(r8) :: es + real(r8) :: qs + + real(r8) :: state_loc_graup(state%psetcols,pver) + real(r8) :: state_loc_numgraup(state%psetcols,pver) + + real(r8), pointer :: cmeliq_grid(:,:) + + real(r8), pointer :: prec_str_grid(:) + real(r8), pointer :: snow_str_grid(:) + real(r8), pointer :: prec_pcw_grid(:) + real(r8), pointer :: snow_pcw_grid(:) + real(r8), pointer :: prec_sed_grid(:) + real(r8), pointer :: snow_sed_grid(:) + real(r8), pointer :: cldo_grid(:,:) + real(r8), pointer :: nevapr_grid(:,:) + real(r8), pointer :: prain_grid(:,:) + real(r8), pointer :: mgflxprc_grid(:,:) + real(r8), pointer :: mgflxsnw_grid(:,:) + real(r8), pointer :: mgmrprc_grid(:,:) + real(r8), pointer :: mgmrsnw_grid(:,:) + real(r8), pointer :: cvreffliq_grid(:,:) + real(r8), pointer :: cvreffice_grid(:,:) + real(r8), pointer :: rate1ord_cw2pr_st_grid(:,:) + real(r8), pointer :: wsedl_grid(:,:) + real(r8), pointer :: CC_t_grid(:,:) + real(r8), pointer :: CC_qv_grid(:,:) + real(r8), pointer :: CC_ql_grid(:,:) + real(r8), pointer :: CC_qi_grid(:,:) + real(r8), pointer :: CC_nl_grid(:,:) + real(r8), pointer :: CC_ni_grid(:,:) + real(r8), pointer :: CC_qlst_grid(:,:) + real(r8), pointer :: qme_grid(:,:) + real(r8), pointer :: iciwpst_grid(:,:) + real(r8), pointer :: icswp_grid(:,:) + real(r8), pointer :: ast_grid(:,:) + real(r8), pointer :: cldfsnow_grid(:,:) + real(r8), pointer :: bergso_grid(:,:) + + real(r8), pointer :: icgrauwp_grid(:,:) + real(r8), pointer :: cldfgrau_grid(:,:) + + real(r8), pointer :: qrout_grid_ptr(:,:) + real(r8), pointer :: qsout_grid_ptr(:,:) + real(r8), pointer :: nrout_grid_ptr(:,:) + real(r8), pointer :: nsout_grid_ptr(:,:) + real(r8), pointer :: qcsedtenout_grid_ptr(:,:) + real(r8), pointer :: qrsedtenout_grid_ptr(:,:) + real(r8), pointer :: qisedtenout_grid_ptr(:,:) + real(r8), pointer :: qssedtenout_grid_ptr(:,:) + real(r8), pointer :: qgsedtenout_grid_ptr(:,:) !+tht + real(r8), pointer :: vtrmcout_grid_ptr(:,:) + real(r8), pointer :: umrout_grid_ptr(:,:) + real(r8), pointer :: vtrmiout_grid_ptr(:,:) + real(r8), pointer :: umsout_grid_ptr(:,:) + real(r8), pointer :: qcsevapout_grid_ptr(:,:) + real(r8), pointer :: qisevapout_grid_ptr(:,:) + + + logical :: use_subcol_microp + integer :: col_type ! Flag to store whether accessing grid or sub-columns in pbuf_get_field + integer :: ierr + integer :: nlev + integer :: num_dust_bins + + character(512) :: ccpp_errmsg ! CCPP return status (non-blank for error return) + character(128) :: pumas_errstring ! PUMAS return status (non-blank for error return) + + ! For rrtmg optics. specified distribution. + real(r8), parameter :: dcon = 25.e-6_r8 ! Convective size distribution effective radius (meters) + real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter + real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) + +! Rainbows: SZA + real(r8) :: zen_angle(state%psetcols) ! Daytime solar zenith angles (radians) + real(r8) :: rlats(state%psetcols), rlons(state%psetcols) ! chunk latitudes and longitudes (radians) + real(r8) :: sza(state%psetcols) ! solar zenith angles (degrees) + real(r8), parameter :: rad2deg = 180._r8/pi ! radians to degrees conversion factor + real(r8) :: calday !current calendar day + + real(r8) :: precc(state%psetcols) ! convective precip rate + +! Rainbow frequency and fraction for output + + real(r8) :: rbfreq(state%psetcols) + real(r8) :: rbfrac(state%psetcols) + +!Rainbows: parameters + + real(r8), parameter :: rb_rmin =1.e-6_r8 ! Strat Rain threshold (mixing ratio) + real(r8), parameter :: rb_rcmin = 5._r8/(86400._r8*1000._r8) ! Conv Rain Threshold (mm/d--> m/s) + real(r8), parameter :: rb_pmin =85000._r8 ! Minimum pressure for surface layer + real(r8), parameter :: deg2rad = pi/180._r8 ! Conversion factor + integer :: top_idx !Index for top level below rb_pmin + real(r8) :: convmx + real(r8) :: cldmx + real(r8) :: frlow + real(r8) :: cldtot + real(r8) :: rmax + logical :: rval + + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + psetcols = state%psetcols + ngrdcol = state%ngrdcol + itim_old = pbuf_old_tim_idx() + nlev = pver - top_lev + 1 + + nan_array = nan + + ! Allocate the proc_rates DDT + ! IMPORTANT NOTE -- elements in proc_rates are dimensioned to the nlev dimension while + ! all the other arrays in this routine are dimensioned pver. This is required because + ! PUMAS only gets the top_lev:pver array subsection, and the proc_rates arrays + ! need to be the same levels. + call proc_rates%allocate(ncol, nlev, ncd, micro_mg_warm_rain, pumas_errstring) + + call handle_errmsg(pumas_errstring, subname="micro_pumas_cam_tend") + + + call phys_getopts(use_subcol_microp_out=use_subcol_microp) + + ! Set the col_type flag to grid or subcolumn dependent on the value of use_subcol_microp + call pbuf_col_type_index(use_subcol_microp, col_type=col_type) + + !----------------------- + ! These physics buffer fields are read only and not set in this parameterization + ! If these fields do not have subcolumn data, copy the grid to the subcolumn if subcolumns is turned on + ! If subcolumns is not turned on, then these fields will be grid data + + call pbuf_get_field(pbuf, naai_idx, naai, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, naai_hom_idx, naai_hom, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, npccn_idx, npccn, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, rndst_idx, rndst, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, nacon_idx, nacon, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, relvar_idx, relvar, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq, col_type=col_type, copy_if_needed=use_subcol_microp) + + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + + ! Get convective precip for rainbows + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp, col_type=col_type, copy_if_needed=use_subcol_microp) + else + nullify(prec_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh, col_type=col_type, copy_if_needed=use_subcol_microp) + else + nullify(prec_sh) + end if + +! Merge Precipitation rates (multi-process) + if (associated(prec_dp) .and. associated(prec_sh)) then + precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) + else if (associated(prec_dp)) then + precc(:ncol) = prec_dp(:ncol) + else if (associated(prec_sh)) then + precc(:ncol) = prec_sh(:ncol) + else + precc(:ncol) = 0._r8 + end if + + if (.not. do_cldice) then + ! If we are NOT prognosing ice and snow tendencies, then get them from the Pbuf + call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, tnd_nsnow_idx, tnd_nsnow, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, re_ice_idx, re_ice, col_type=col_type, copy_if_needed=use_subcol_microp) + else + ! If we ARE prognosing tendencies, then just point to an array of NaN fields to have + ! something for PUMAS to use in call + tnd_qsnow => nan_array + tnd_nsnow => nan_array + re_ice => nan_array + end if + + if (use_hetfrz_classnuc) then + call pbuf_get_field(pbuf, frzimm_idx, frzimm, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, frzcnt_idx, frzcnt, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, frzdep_idx, frzdep, col_type=col_type, copy_if_needed=use_subcol_microp) + else + ! Needed to satisfy gnu compiler with optional argument - set to an array of Nan fields + frzimm => nan_array + frzcnt => nan_array + frzdep => nan_array + end if + + if (qsatfac_idx > 0) then + call pbuf_get_field(pbuf, qsatfac_idx, qsatfac, col_type=col_type, copy_if_needed=use_subcol_microp) + else + allocate(qsatfac(ncol,pver),stat=ierr) + call handle_allocate_error(ierr, 'micro_pumas_cam_tend', 'qsatfac') + qsatfac = 1._r8 + end if + + ! initialize tendency variables + preci = 0._r8 + prect = 0._r8 + + ! initialize subcolumn variables + if (use_subcol_microp) then + evapsnow_sc = 0.0_r8 + bergstot_sc = 0.0_r8 + qcrestot_sc = 0.0_r8 + melttot_sc = 0.0_r8 + mnuccctot_sc = 0.0_r8 + mnuccttot_sc = 0.0_r8 + bergtot_sc = 0.0_r8 + homotot_sc = 0.0_r8 + msacwitot_sc = 0.0_r8 + psacwstot_sc = 0.0_r8 + cmeitot_sc = 0.0_r8 + qirestot_sc = 0.0_r8 + prcitot_sc = 0.0_r8 + praitot_sc = 0.0_r8 + pratot_sc = 0.0_r8 + prctot_sc = 0.0_r8 + qcsedten_sc = 0.0_r8 + qisedten_sc = 0.0_r8 + vtrmc_sc = 0.0_r8 + vtrmi_sc = 0.0_r8 + qcsevap_sc = 0.0_r8 + qisevap_sc = 0.0_r8 + qrsedten_sc = 0.0_r8 + qssedten_sc = 0.0_r8 + umr_sc = 0.0_r8 + ums_sc = 0.0_r8 + if (micro_mg_version > 2) then + psacrtot_sc = 0.0_r8 + pracgtot_sc = 0.0_r8 + psacwgtot_sc = 0.0_r8 + pgsacwtot_sc = 0.0_r8 + pgracstot_sc = 0.0_r8 + prdgtot_sc = 0.0_r8 + qmultgtot_sc = 0.0_r8 + qmultrgtot_sc = 0.0_r8 + npracgtot_sc = 0.0_r8 + nscngtot_sc = 0.0_r8 + ngracstot_sc = 0.0_r8 + nmultgtot_sc = 0.0_r8 + nmultrgtot_sc = 0.0_r8 + npsacwgtot_sc = 0.0_r8 + end if + end if + + !----------------------- + ! These physics buffer fields are calculated and set in this parameterization + ! If subcolumns is turned on, then these fields will be calculated on a subcolumn grid, otherwise they will be a normal grid + + call pbuf_get_field(pbuf, prec_str_idx, prec_str, col_type=col_type) + call pbuf_get_field(pbuf, snow_str_idx, snow_str, col_type=col_type) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw, col_type=col_type) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw, col_type=col_type) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed, col_type=col_type) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed, col_type=col_type) + call pbuf_get_field(pbuf, nevapr_idx, nevapr, col_type=col_type) + call pbuf_get_field(pbuf, prer_evap_idx, prer_evap, col_type=col_type) + call pbuf_get_field(pbuf, prain_idx, prain, col_type=col_type) + call pbuf_get_field(pbuf, dei_idx, dei, col_type=col_type) + call pbuf_get_field(pbuf, mu_idx, mu, col_type=col_type) + call pbuf_get_field(pbuf, lambdac_idx, lambdac, col_type=col_type) + call pbuf_get_field(pbuf, des_idx, des, col_type=col_type) + call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc, col_type=col_type) + call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw, col_type=col_type) + call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc, col_type=col_type) + call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw, col_type=col_type) + call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq, col_type=col_type) + call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice, col_type=col_type) + call pbuf_get_field(pbuf, iciwpst_idx, iciwpst, col_type=col_type) + call pbuf_get_field(pbuf, iclwpst_idx, iclwpst, col_type=col_type) + call pbuf_get_field(pbuf, icswp_idx, icswp, col_type=col_type) + call pbuf_get_field(pbuf, rel_idx, rel, col_type=col_type) + call pbuf_get_field(pbuf, rei_idx, rei, col_type=col_type) + call pbuf_get_field(pbuf, sadice_idx, sadice, col_type=col_type) + call pbuf_get_field(pbuf, sadsnow_idx, sadsnow, col_type=col_type) + call pbuf_get_field(pbuf, wsedl_idx, wsedl, col_type=col_type) + call pbuf_get_field(pbuf, qme_idx, qme, col_type=col_type) + call pbuf_get_field(pbuf, bergso_idx, bergstot, col_type=col_type) + + ! Assign the pointer values to the non-pointer proc_rates element + proc_rates%bergstot(:ncol,1:nlev) = bergstot(:ncol,top_lev:pver) + + if (degrau_idx > 0) call pbuf_get_field(pbuf, degrau_idx, degrau, col_type=col_type) + if (icgrauwp_idx > 0) call pbuf_get_field(pbuf, icgrauwp_idx, icgrauwp, col_type=col_type) + if (cldfgrau_idx > 0) call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau, col_type=col_type) + + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_t_idx, CC_t, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qv_idx, CC_qv, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_ql_idx, CC_ql, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qi_idx, CC_qi, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_nl_idx, CC_nl, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_ni_idx, CC_ni, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + + if (rate1_cw2pr_st_idx > 0) then + call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st, col_type=col_type) + end if + + if (qrain_idx > 0) call pbuf_get_field(pbuf, qrain_idx, qrout_grid_ptr) + if (qsnow_idx > 0) call pbuf_get_field(pbuf, qsnow_idx, qsout_grid_ptr) + if (nrain_idx > 0) call pbuf_get_field(pbuf, nrain_idx, nrout_grid_ptr) + if (nsnow_idx > 0) call pbuf_get_field(pbuf, nsnow_idx, nsout_grid_ptr) + if (qcsedten_idx > 0) call pbuf_get_field(pbuf, qcsedten_idx, qcsedtenout_grid_ptr) + if (qrsedten_idx > 0) call pbuf_get_field(pbuf, qrsedten_idx, qrsedtenout_grid_ptr) + if (qisedten_idx > 0) call pbuf_get_field(pbuf, qisedten_idx, qisedtenout_grid_ptr) + if (qssedten_idx > 0) call pbuf_get_field(pbuf, qssedten_idx, qssedtenout_grid_ptr) + if (qgsedten_idx > 0) call pbuf_get_field(pbuf, qgsedten_idx, qgsedtenout_grid_ptr) !+tht + if (vtrmc_idx > 0) call pbuf_get_field(pbuf, vtrmc_idx, vtrmcout_grid_ptr) + if (umr_idx > 0) call pbuf_get_field(pbuf, umr_idx, umrout_grid_ptr) + if (vtrmi_idx > 0) call pbuf_get_field(pbuf, vtrmi_idx, vtrmiout_grid_ptr) + if (ums_idx > 0) call pbuf_get_field(pbuf, ums_idx, umsout_grid_ptr) + if (qcsevap_idx > 0) call pbuf_get_field(pbuf, qcsevap_idx, qcsevapout_grid_ptr) + if (qisevap_idx > 0) call pbuf_get_field(pbuf, qisevap_idx, qisevapout_grid_ptr) + + !----------------------- + ! If subcolumns is turned on, all calculated fields which are on subcolumns + ! need to be retrieved on the grid as well for storing averaged values + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_grid) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_grid) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw_grid) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw_grid) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed_grid) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed_grid) + call pbuf_get_field(pbuf, nevapr_idx, nevapr_grid) + call pbuf_get_field(pbuf, prain_idx, prain_grid) + call pbuf_get_field(pbuf, dei_idx, dei_grid) + call pbuf_get_field(pbuf, mu_idx, mu_grid) + call pbuf_get_field(pbuf, lambdac_idx, lambdac_grid) + call pbuf_get_field(pbuf, des_idx, des_grid) + call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc_grid) + call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw_grid) + call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc_grid) + call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw_grid) + call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq_grid) + call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice_grid) + call pbuf_get_field(pbuf, iciwpst_idx, iciwpst_grid) + call pbuf_get_field(pbuf, iclwpst_idx, iclwpst_grid) + call pbuf_get_field(pbuf, icswp_idx, icswp_grid) + call pbuf_get_field(pbuf, rel_idx, rel_grid) + call pbuf_get_field(pbuf, rei_idx, rei_grid) + call pbuf_get_field(pbuf, sadice_idx, sadice_grid) + call pbuf_get_field(pbuf, sadsnow_idx, sadsnow_grid) + call pbuf_get_field(pbuf, wsedl_idx, wsedl_grid) + call pbuf_get_field(pbuf, qme_idx, qme_grid) + call pbuf_get_field(pbuf, bergso_idx, bergso_grid) + if (degrau_idx > 0) call pbuf_get_field(pbuf, degrau_idx, degrau_grid) + if (icgrauwp_idx > 0) call pbuf_get_field(pbuf, icgrauwp_idx, icgrauwp_grid) + if (cldfgrau_idx > 0) call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau_grid) + + call pbuf_get_field(pbuf, cldo_idx, cldo_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_t_idx, CC_t_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qv_idx, CC_qv_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_ql_idx, CC_ql_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qi_idx, CC_qi_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_nl_idx, CC_nl_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_ni_idx, CC_ni_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if (rate1_cw2pr_st_idx > 0) then + call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st_grid) + end if + + else + allocate(bergso_grid(pcols,pver), stat=ierr) + call handle_allocate_error(ierr, 'micro_pumas_cam_tend', 'bergso_grid') + bergso_grid(:,:) = 0._r8 + end if + + !----------------------- + ! These are only on the grid regardless of whether subcolumns are turned on or not + call pbuf_get_field(pbuf, ls_reffrain_idx, mgreffrain_grid) + call pbuf_get_field(pbuf, ls_reffsnow_idx, mgreffsnow_grid) + call pbuf_get_field(pbuf, acpr_idx, acprecl_grid) + call pbuf_get_field(pbuf, acgcme_idx, acgcme_grid) + call pbuf_get_field(pbuf, acnum_idx, acnum_grid) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq_grid) + call pbuf_get_field(pbuf, ast_idx, ast_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, evprain_st_idx, evprain_st_grid) + call pbuf_get_field(pbuf, evpsnow_st_idx, evpsnow_st_grid) + call pbuf_get_field(pbuf, am_evp_st_idx, am_evp_st_grid) + + !----------------------------------------------------------------------- + ! ... Calculate cosine of zenith angle + ! then cast back to angle (radians) + !----------------------------------------------------------------------- + + zen_angle(:) = 0.0_r8 + rlats(:) = 0.0_r8 + rlons(:) = 0.0_r8 + calday = get_curr_calday() + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + call zenith( calday, rlats, rlons, zen_angle, ncol ) + where (zen_angle(:) <= 1.0_r8 .and. zen_angle(:) >= -1.0_r8) + zen_angle(:) = acos( zen_angle(:) ) + elsewhere + zen_angle(:) = 0.0_r8 + end where + + sza(:) = zen_angle(:) * rad2deg + call outfld( 'rbSZA', sza, ncol, lchnk ) + + !------------------------------------------------------------------------------------- + ! Microphysics assumes 'liquid stratus frac = ice stratus frac + ! = max( liquid stratus frac, ice stratus frac )'. + alst_mic => ast + aist_mic => ast + + ! Output initial in-cloud LWP (before microphysics) + + iclwpi = 0._r8 + iciwpi = 0._r8 + + do i = 1, ncol + do k = top_lev, pver + iclwpi(i) = iclwpi(i) + & + min(state%q(i,k,ixcldliq) / max(mincld,ast(i,k)),0.005_r8) & + * state%pdel(i,k) / gravit + iciwpi(i) = iciwpi(i) + & + min(state%q(i,k,ixcldice) / max(mincld,ast(i,k)),0.005_r8) & + * state%pdel(i,k) / gravit + end do + end do + + cldo(:ncol,top_lev:pver)=ast(:ncol,top_lev:pver) + + ! Initialize local state from input. + call physics_state_copy(state, state_loc) + + ! Because of the of limited vertical resolution, there can be a signifcant + ! warm bias at the cold point tropopause, which can create a wet bias in the + ! stratosphere. For the microphysics only, update the cold point temperature, with + ! an estimate of the coldest point between the model layers. + if (micro_mg_adjust_cpt) then + cp_rh(:ncol, :pver) = 0._r8 + cp_dt(:ncol) = 0._r8 + cp_dz(:ncol) = 0._r8 + + !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + troplev(:) = 0 + cp_z(:) = 0._r8 + cp_t(:) = 0._r8 + !REMOVECAM_END + call tropopause_find_cam(state_loc, troplev, primary=TROP_ALG_CPP, backup=TROP_ALG_NONE, & + tropZ=cp_z, tropT=cp_t) + + do i = 1, ncol + + ! Update statistics and output results. + if (troplev(i) .ne. NOTFOUND) then + cp_dt(i) = cp_t(i) - state_loc%t(i,troplev(i)) + cp_dz(i) = cp_z(i) - state_loc%zm(i,troplev(i)) + + ! NOTE: This change in temperature is just for the microphysics + ! and should not be added to any tendencies or used to update + ! any states + state_loc%t(i,troplev(i)) = state_loc%t(i,troplev(i)) + cp_dt(i) + end if + end do + + ! Output all of the statistics related to the cold point + ! tropopause adjustment. Th cold point information itself is + ! output in tropopause.F90. + call outfld("TROPF_TADJ", state_loc%t, pcols, lchnk) + call outfld("TROPF_CDT", cp_dt, pcols, lchnk) + call outfld("TROPF_CDZ", cp_dz, pcols, lchnk) + end if + + ! Initialize ptend for output. + lq = .false. + lq(ixq) = .true. + lq(ixcldliq) = .true. + lq(ixcldice) = .true. + lq(ixnumliq) = .true. + lq(ixnumice) = .true. + lq(ixrain) = .true. + lq(ixsnow) = .true. + lq(ixnumrain) = .true. + lq(ixnumsnow) = .true. + if (micro_mg_version > 2) then + lq(ixgraupel) = .true. + lq(ixnumgraupel) = .true. + end if + + ! the name 'cldwat' triggers special tests on cldliq + ! and cldice in physics_update + call physics_ptend_init(ptend, psetcols, "cldwat", ls=.true., lq=lq) + + if (micro_mg_version > 2) then + state_loc_graup(:ncol,:) = state_loc%q(:ncol,:,ixgraupel) + state_loc_numgraup(:ncol,:) = state_loc%q(:ncol,:,ixnumgraupel) + else + state_loc_graup(:ncol,:) = 0._r8 + state_loc_numgraup(:ncol,:) = 0._r8 + end if + + ! Zero out diagnostic rainbow arrays + rbfreq = 0._r8 + rbfrac = 0._r8 + + ! Zero out values above top_lev before passing into _tend for some pbuf variables that are inputs + naai(:ncol,:top_lev-1) = 0._r8 + npccn(:ncol,:top_lev-1) = 0._r8 + + ! The null value for qsatfac is 1, not zero + qsatfac(:ncol,:top_lev-1) = 1._r8 + + ! Zero out values above top_lev for all output variables + ! Note that elements in proc_rates do not have the extra levels as they are dimensioned to be nlev instead of pver + tlat(:ncol,:top_lev-1)=0._r8 + qvlat(:ncol,:top_lev-1)=0._r8 + qcten(:ncol,:top_lev-1)=0._r8 + qiten(:ncol,:top_lev-1)=0._r8 + ncten(:ncol,:top_lev-1)=0._r8 + niten(:ncol,:top_lev-1)=0._r8 + qrten(:ncol,:top_lev-1)=0._r8 + qsten(:ncol,:top_lev-1)=0._r8 + nrten(:ncol,:top_lev-1)=0._r8 + nsten(:ncol,:top_lev-1)=0._r8 + qgten(:ncol,:top_lev-1)=0._r8 + ngten(:ncol,:top_lev-1)=0._r8 + rel(:ncol,:top_lev-1)=0._r8 + rel_fn_dum(:ncol,:top_lev-1)=0._r8 + rei(:ncol,:top_lev-1)=0._r8 + sadice(:ncol,:top_lev-1)=0._r8 + sadsnow(:ncol,:top_lev-1)=0._r8 + prect(:ncol)=0._r8 + preci(:ncol)=0._r8 + nevapr(:ncol,:top_lev-1)=0._r8 + am_evp_st(:ncol,:top_lev-1)=0._r8 + prain(:ncol,:top_lev-1)=0._r8 + cmeice(:ncol,:top_lev-1)=0._r8 + dei(:ncol,:top_lev-1)=0._r8 + mu(:ncol,:top_lev-1)=0._r8 + lambdac(:ncol,:top_lev-1)=0._r8 + qsout(:ncol,:top_lev-1)=0._r8 + des(:ncol,:top_lev-1)=0._r8 + qgout(:ncol,:top_lev-1)=0._r8 + ngout(:ncol,:top_lev-1)=0._r8 + dgout(:ncol,:top_lev-1)=0._r8 + cflx(:ncol,:top_lev-1)=0._r8 + iflx(:ncol,:top_lev-1)=0._r8 + gflx(:ncol,:top_lev-1)=0._r8 + rflx(:ncol,:top_lev-1)=0._r8 + sflx(:ncol,:top_lev-1)=0._r8 + qrout(:ncol,:top_lev-1)=0._r8 + reff_rain_dum(:ncol,:top_lev-1)=0._r8 + reff_snow_dum(:ncol,:top_lev-1)=0._r8 + reff_grau_dum(:ncol,:top_lev-1)=0._r8 + nrout(:ncol,:top_lev-1)=0._r8 + nsout(:ncol,:top_lev-1)=0._r8 + refl(:ncol,:top_lev-1)=0._r8 + arefl(:ncol,:top_lev-1)=0._r8 + areflz(:ncol,:top_lev-1)=0._r8 + frefl(:ncol,:top_lev-1)=0._r8 + csrfl(:ncol,:top_lev-1)=0._r8 + acsrfl(:ncol,:top_lev-1)=0._r8 + fcsrfl(:ncol,:top_lev-1)=0._r8 + refl10cm(:ncol,:top_lev-1)=-9999._r8 + reflz10cm(:ncol,:top_lev-1)=0._r8 + rercld(:ncol,:top_lev-1)=0._r8 + ncai(:ncol,:top_lev-1)=0._r8 + ncal(:ncol,:top_lev-1)=0._r8 + qrout2(:ncol,:top_lev-1)=0._r8 + qsout2(:ncol,:top_lev-1)=0._r8 + nrout2(:ncol,:top_lev-1)=0._r8 + nsout2(:ncol,:top_lev-1)=0._r8 + qgout2(:ncol,:top_lev-1)=0._r8 + ngout2(:ncol,:top_lev-1)=0._r8 + dgout2(:ncol,:top_lev-1)=0._r8 + freqg(:ncol,:top_lev-1)=0._r8 + freqs(:ncol,:top_lev-1)=0._r8 + freqr(:ncol,:top_lev-1)=0._r8 + nfice(:ncol,:top_lev-1)=0._r8 + qcrat(:ncol,:top_lev-1)=0._r8 + tnd_qsnow(:ncol,:top_lev-1)=0._r8 + tnd_nsnow(:ncol,:top_lev-1)=0._r8 + re_ice(:ncol,:top_lev-1)=0._r8 + prer_evap(:ncol,:top_lev-1)=0._r8 + frzimm(:ncol,:top_lev-1)=0._r8 + frzcnt(:ncol,:top_lev-1)=0._r8 + frzdep(:ncol,:top_lev-1)=0._r8 + + !Determine number of dust size bins: + num_dust_bins = size(rndst, dim=3) + + do it = 1, num_steps + + call micro_pumas_ccpp_run( & + ncol, nlev, nlev+1, num_dust_bins, dtime/num_steps, & + state_loc%t(:ncol,top_lev:), state_loc%q(:ncol,top_lev:,ixq), & + state_loc%q(:ncol,top_lev:,ixcldliq), state_loc%q(:ncol,top_lev:,ixcldice), & + state_loc%q(:ncol,top_lev:,ixnumliq), state_loc%q(:ncol,top_lev:,ixnumice), & + state_loc%q(:ncol,top_lev:,ixrain), state_loc%q(:ncol,top_lev:,ixsnow), & + state_loc%q(:ncol,top_lev:,ixnumrain), state_loc%q(:ncol,top_lev:,ixnumsnow), & + state_loc_graup(:ncol,top_lev:), state_loc_numgraup(:ncol,top_lev:), & + relvar(:ncol,top_lev:), accre_enhan(:ncol,top_lev:), & + state_loc%pmid(:ncol,top_lev:), state_loc%pdel(:ncol,top_lev:), & + state_loc%pint(:ncol,top_lev:), & + ast(:ncol,top_lev:), alst_mic(:ncol,top_lev:), & + aist_mic(:ncol,top_lev:), qsatfac(:ncol,top_lev:), & + naai(:ncol,top_lev:), npccn(:ncol,top_lev:), & + rndst(:ncol,top_lev:,:), nacon(:ncol,top_lev:,:), & + tnd_qsnow(:ncol,top_lev:), tnd_nsnow(:ncol,top_lev:), & + re_ice(:ncol,top_lev:), & + frzimm(:ncol,top_lev:), frzcnt(:ncol,top_lev:), & + frzdep(:ncol,top_lev:), rate1cld(:ncol,top_lev:), & + tlat(:ncol,top_lev:), qvlat(:ncol,top_lev:), & + qcten(:ncol,top_lev:), qiten(:ncol,top_lev:), & + ncten(:ncol,top_lev:), niten(:ncol,top_lev:), & + qrten(:ncol,top_lev:), qsten(:ncol,top_lev:), & + nrten(:ncol,top_lev:), nsten(:ncol,top_lev:), & + qgten(:ncol,top_lev:), ngten(:ncol,top_lev:), & + rel(:ncol,top_lev:), rel_fn_dum(:ncol,top_lev:), & + rei(:ncol,top_lev:), & + sadice(:ncol,top_lev:), sadsnow(:ncol,top_lev:), & + prect(:ncol), preci(:ncol), & + nevapr(:ncol,top_lev:), am_evp_st(:ncol,top_lev:), & + prain(:ncol,top_lev:), & + cmeice(:ncol,top_lev:), dei(:ncol,top_lev:), & + mu(:ncol,top_lev:), lambdac(:ncol,top_lev:), & + qsout(:ncol,top_lev:), des(:ncol,top_lev:), & + qgout(:ncol,top_lev:), ngout(:ncol,top_lev:), & + dgout(:ncol,top_lev:), & + cflx(:ncol,top_lev:), iflx(:ncol,top_lev:), & + gflx(:ncol,top_lev:), & + rflx(:ncol,top_lev:), sflx(:ncol,top_lev:), & + qrout(:ncol,top_lev:), reff_rain_dum(:ncol,top_lev:), & + reff_snow_dum(:ncol,top_lev:), reff_grau_dum(:ncol,top_lev:), & + nrout(:ncol,top_lev:), nsout(:ncol,top_lev:), & + refl(:ncol,top_lev:), arefl(:ncol,top_lev:), & + areflz(:ncol,top_lev:), frefl(:ncol,top_lev:), & + csrfl(:ncol,top_lev:), acsrfl(:ncol,top_lev:), & + fcsrfl(:ncol,top_lev:), refl10cm(:ncol,top_lev:), & + reflz10cm(:ncol,top_lev:), rercld(:ncol,top_lev:), & + ncai(:ncol,top_lev:), ncal(:ncol,top_lev:), & + qrout2(:ncol,top_lev:), qsout2(:ncol,top_lev:), & + nrout2(:ncol,top_lev:), nsout2(:ncol,top_lev:), & + drout_dum(:ncol,top_lev:), dsout2_dum(:ncol,top_lev:), & + qgout2(:ncol,top_lev:), ngout2(:ncol,top_lev:), & + dgout2(:ncol,top_lev:), freqg(:ncol,top_lev:), & + freqs(:ncol,top_lev:), freqr(:ncol,top_lev:), & + nfice(:ncol,top_lev:), qcrat(:ncol,top_lev:), & + prer_evap(:ncol,top_lev:), proc_rates, & + ccpp_errmsg, ierr ) + + call handle_errmsg(ccpp_errmsg, subname="micro_pumas_cam_tend") + + call physics_ptend_init(ptend_loc, psetcols, "micro_pumas", & + ls=.true., lq=lq) + + ! Set local tendency. + ptend_loc%s(:ncol,top_lev:) = tlat(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixq) = qvlat(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixcldliq) = qcten(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixcldice) = qiten(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixnumliq) = ncten(:ncol,top_lev:) + + if (do_cldice) then + ptend_loc%q(:ncol,top_lev:,ixnumice) = niten(:ncol,top_lev:) + else + ! In this case, the tendency should be all 0. + if (any(niten(:ncol,:) /= 0._r8)) then + call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_pumas_tend has ice number tendencies.") + end if + ptend_loc%q(:ncol,:,ixnumice) = 0._r8 + end if + + ptend_loc%q(:ncol,top_lev:,ixrain) = qrten(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixsnow) = qsten(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixnumrain) = nrten(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixnumsnow) = nsten(:ncol,top_lev:) + + if (micro_mg_version > 2) then + ptend_loc%q(:ncol,top_lev:,ixgraupel) = qgten(:ncol,top_lev:) + ptend_loc%q(:ncol,top_lev:,ixnumgraupel) = ngten(:ncol,top_lev:) + end if + + ! Sum into overall ptend + call physics_ptend_sum(ptend_loc, ptend, ncol) + + ! Update local state + call physics_update(state_loc, ptend_loc, dtime/num_steps) + + if (trim(micro_mg_warm_rain) == 'tau') then + proc_rates%amk_c(:ncol,:,:) = proc_rates%amk_c(:ncol,:,:)/num_steps + proc_rates%ank_c(:ncol,:,:) = proc_rates%ank_c(:ncol,:,:)/num_steps + proc_rates%amk_r(:ncol,:,:) = proc_rates%amk_r(:ncol,:,:)/num_steps + proc_rates%ank_r(:ncol,:,:) = proc_rates%ank_r(:ncol,:,:)/num_steps + proc_rates%amk(:ncol,:,:) = proc_rates%amk(:ncol,:,:)/num_steps + proc_rates%ank(:ncol,:,:) = proc_rates%ank(:ncol,:,:)/num_steps + proc_rates%amk_out(:ncol,:,:) = proc_rates%amk_out(:ncol,:,:)/num_steps + end if + + end do + + ! Divide ptend by substeps. + call physics_ptend_scale(ptend, 1._r8/num_steps, ncol) + + ! Check to make sure that the microphysics code is respecting the flags that control + ! whether MG should be prognosing cloud ice and cloud liquid or not. + if (.not. do_cldice) then + if (any(ptend%q(:ncol,top_lev:pver,ixcldice) /= 0.0_r8)) & + call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_pumas_tend has ice mass tendencies.") + if (any(ptend%q(:ncol,top_lev:pver,ixnumice) /= 0.0_r8)) & + call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_pumas_tend has ice number tendencies.") + end if + if (.not. do_cldliq) then + if (any(ptend%q(:ncol,top_lev:pver,ixcldliq) /= 0.0_r8)) & + call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & + " but micro_pumas_tend has liquid mass tendencies.") + if (any(ptend%q(:ncol,top_lev:pver,ixnumliq) /= 0.0_r8)) & + call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & + " but micro_pumas_tend has liquid number tendencies.") + end if + + mnuccdohet = 0._r8 + do k=top_lev,pver + do i=1,ncol + if (naai(i,k) > 0._r8) then + mnuccdohet(i,k) = proc_rates%mnuccdtot(i,k-top_lev+1) - (naai_hom(i,k)/naai(i,k))*proc_rates%mnuccdtot(i,k-top_lev+1) + end if + end do + end do + + mgflxprc(:ncol,top_lev:pverp) = rflx(:ncol,top_lev:pverp) + sflx(:ncol,top_lev:pverp) + mgflxsnw(:ncol,top_lev:pverp) = sflx(:ncol,top_lev:pverp) + + !add condensate fluxes for MG2 (ice and snow already added for MG1) + if (micro_mg_version >= 2) then + mgflxprc(:ncol,top_lev:pverp) = mgflxprc(:ncol,top_lev:pverp)+ iflx(:ncol,top_lev:pverp) + cflx(:ncol,top_lev:pverp) + mgflxsnw(:ncol,top_lev:pverp) = mgflxsnw(:ncol,top_lev:pverp) + iflx(:ncol,top_lev:pverp) + end if + + !add graupel fluxes for MG3 to snow flux + if (micro_mg_version >= 3) then + mgflxprc(:ncol,top_lev:pverp) = mgflxprc(:ncol,top_lev:pverp)+gflx(:ncol,top_lev:pverp) + mgflxsnw(:ncol,top_lev:pverp) = mgflxsnw(:ncol,top_lev:pverp)+gflx(:ncol,top_lev:pverp) + end if + + mgmrprc(:ncol,top_lev:pver) = qrout(:ncol,top_lev:pver) + qsout(:ncol,top_lev:pver) + mgmrsnw(:ncol,top_lev:pver) = qsout(:ncol,top_lev:pver) + + !! calculate effective radius of convective liquid and ice using dcon and deicon (not used by code, not useful for COSP) + !! hard-coded as average of hard-coded values used for deep/shallow convective detrainment (near line 1502/1505) + cvreffliq(:ncol,top_lev:pver) = 9.0_r8 + cvreffice(:ncol,top_lev:pver) = 37.0_r8 + + ! Reassign rate1 if modal aerosols + if (rate1_cw2pr_st_idx > 0) then + rate1ord_cw2pr_st(:ncol,top_lev:pver) = rate1cld(:ncol,top_lev:pver) + end if + + ! Sedimentation velocity for liquid stratus cloud droplet + wsedl(:ncol,top_lev:pver) = proc_rates%vtrmc(:ncol,1:nlev) + + ! Microphysical tendencies for use in the macrophysics at the next time step + CC_T(:ncol,top_lev:pver) = tlat(:ncol,top_lev:pver)/cpair + CC_qv(:ncol,top_lev:pver) = qvlat(:ncol,top_lev:pver) + CC_ql(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver) + CC_qi(:ncol,top_lev:pver) = qiten(:ncol,top_lev:pver) + CC_nl(:ncol,top_lev:pver) = ncten(:ncol,top_lev:pver) + CC_ni(:ncol,top_lev:pver) = niten(:ncol,top_lev:pver) + CC_qlst(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver)/max(0.01_r8,alst_mic(:ncol,top_lev:pver)) + + ! Net micro_pumas_cam condensation rate + qme(:ncol,:top_lev-1) = 0._r8 + qme(:ncol,top_lev:pver) = cmeliq(:ncol,top_lev:pver) + proc_rates%cmeitot(:ncol,1:nlev) + + ! For precip, accumulate only total precip in prec_pcw and snow_pcw variables. + ! Other precip output variables are set to 0 + ! Do not subscript by ncol here, because in physpkg we divide the whole + ! array and need to avoid an FPE due to uninitialized data. + prec_pcw = prect + snow_pcw = preci + prec_sed = 0._r8 + snow_sed = 0._r8 + prec_str = prec_pcw + prec_sed + snow_str = snow_pcw + snow_sed + + icecldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) + liqcldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) + + ! ------------------------------------------------------------ ! + ! Compute in cloud ice and liquid mixing ratios ! + ! Note that 'iclwp, iciwp' are used for radiation computation. ! + ! ------------------------------------------------------------ ! + + icinc = 0._r8 + icwnc = 0._r8 + iciwpst = 0._r8 + iclwpst = 0._r8 + icswp = 0._r8 + cldfsnow = 0._r8 + if (micro_mg_version > 2) then + icgrauwp = 0._r8 + cldfgrau = 0._r8 + end if + + do k = top_lev, pver + do i = 1, ncol + ! Limits for in-cloud mixing ratios consistent with MG microphysics + ! in-cloud mixing ratio maximum limit of 0.005 kg/kg + icimrst(i,k) = min( state_loc%q(i,k,ixcldice) / max(mincld,icecldf(i,k)),0.005_r8 ) + icwmrst(i,k) = min( state_loc%q(i,k,ixcldliq) / max(mincld,liqcldf(i,k)),0.005_r8 ) + icinc(i,k) = state_loc%q(i,k,ixnumice) / max(mincld,icecldf(i,k)) * & + state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) + icwnc(i,k) = state_loc%q(i,k,ixnumliq) / max(mincld,liqcldf(i,k)) * & + state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) + ! Calculate micro_pumas_cam cloud water paths in each layer + ! Note: uses stratiform cloud fraction! + iciwpst(i,k) = min(state_loc%q(i,k,ixcldice)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit + iclwpst(i,k) = min(state_loc%q(i,k,ixcldliq)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit + + ! ------------------------------ ! + ! Adjust cloud fraction for snow ! + ! ------------------------------ ! + cldfsnow(i,k) = cld(i,k) + ! If cloud and only ice ( no convective cloud or ice ), then set to 0. + if( ( cldfsnow(i,k) .gt. 1.e-4_r8 ) .and. & + ( concld(i,k) .lt. 1.e-4_r8 ) .and. & + ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then + cldfsnow(i,k) = 0._r8 + end if + ! If no cloud and snow, then set to 0.25 + if( ( cldfsnow(i,k) .le. 1.e-4_r8 ) .and. ( qsout(i,k) .gt. 1.e-6_r8 ) ) then + cldfsnow(i,k) = 0.25_r8 + end if + ! Calculate in-cloud snow water path + icswp(i,k) = qsout(i,k) / max( mincld, cldfsnow(i,k) ) * state_loc%pdel(i,k) / gravit + + ! --------------------------------- ! + ! Adjust cloud fraction for graupel ! + ! --------------------------------- ! + if (micro_mg_version > 2) then + cldfgrau(i,k) = cld(i,k) + ! If cloud and only ice ( no convective cloud or ice ), then set to 0. + if( ( cldfgrau(i,k) .gt. 1.e-4_r8 ) .and. & + ( concld(i,k) .lt. 1.e-4_r8 ) .and. & + ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then + cldfgrau(i,k) = 0._r8 + end if + ! If no cloud and graupel, then set to 0.25 + if( ( cldfgrau(i,k) .le. 1.e-4_r8 ) .and. ( qgout(i,k) .gt. 1.e-9_r8 ) ) then + cldfgrau(i,k) = 0.25_r8 + end if + + ! Calculate in-cloud snow water path + icgrauwp(i,k) = qgout(i,k) / max( 1.e-2_r8, cldfgrau(i,k) ) * state_loc%pdel(i,k) / gravit + end if + + end do + end do + + ! Calculate cloud fraction for prognostic precip sizes. + ! Cloud fraction for purposes of precipitation is maximum cloud + ! fraction out of all the layers that the precipitation may be + ! falling down from. + cldmax(:ncol,top_lev:) = max(mincld, ast(:ncol,top_lev:)) + do k = top_lev+1, pver + where (state_loc%q(:ncol,k-1,ixrain) >= qsmall .or. & + state_loc%q(:ncol,k-1,ixsnow) >= qsmall) + cldmax(:ncol,k) = max(cldmax(:ncol,k-1), cldmax(:ncol,k)) + end where + end do + + !Copy pbuf field from proc_rates back to pbuf pointer + bergstot(:ncol,top_lev:) = proc_rates%bergstot(:ncol,1:nlev) + bergstot(:ncol,1:top_lev-1) = 0._r8 + + ! ------------------------------------------------------ ! + ! ------------------------------------------------------ ! + ! All code from here to the end is on grid columns only ! + ! ------------------------------------------------------ ! + ! ------------------------------------------------------ ! + + ! Average the fields which are needed later in this paramterization to be on the grid + if (use_subcol_microp) then + call subcol_field_avg(prec_str, ngrdcol, lchnk, prec_str_grid) + call subcol_field_avg(iclwpst, ngrdcol, lchnk, iclwpst_grid) + call subcol_field_avg(cvreffliq, ngrdcol, lchnk, cvreffliq_grid) + call subcol_field_avg(cvreffice, ngrdcol, lchnk, cvreffice_grid) + call subcol_field_avg(mgflxprc, ngrdcol, lchnk, mgflxprc_grid) + call subcol_field_avg(mgflxsnw, ngrdcol, lchnk, mgflxsnw_grid) + call subcol_field_avg(qme, ngrdcol, lchnk, qme_grid) + call subcol_field_avg(nevapr, ngrdcol, lchnk, nevapr_grid) + call subcol_field_avg(prain, ngrdcol, lchnk, prain_grid) + + evapsnow_sc(:ncol,:) = proc_rates%evapsnow(:ncol,1:nlev) + call subcol_field_avg(evapsnow_sc, ngrdcol, lchnk, evpsnow_st_grid(:,top_lev:)) + bergstot_sc(:ncol,:) = proc_rates%bergstot(:ncol,1:nlev) + call subcol_field_avg(bergstot_sc, ngrdcol, lchnk, bergso_grid(:,top_lev:)) + + call subcol_field_avg(am_evp_st, ngrdcol, lchnk, am_evp_st_grid) + + ! Average fields which are not in pbuf + call subcol_field_avg(qrout, ngrdcol, lchnk, qrout_grid) + call subcol_field_avg(qsout, ngrdcol, lchnk, qsout_grid) + call subcol_field_avg(nsout, ngrdcol, lchnk, nsout_grid) + call subcol_field_avg(nrout, ngrdcol, lchnk, nrout_grid) + call subcol_field_avg(cld, ngrdcol, lchnk, cld_grid) + + qcrestot_sc(:ncol,:) = proc_rates%qcrestot(:ncol,1:nlev) + call subcol_field_avg(qcrestot_sc, ngrdcol, lchnk, qcreso_grid(:,top_lev:)) + melttot_sc(:ncol,:) = proc_rates%melttot(:ncol,1:nlev) + call subcol_field_avg(melttot_sc, ngrdcol, lchnk, melto_grid(:,top_lev:)) + mnuccctot_sc(:ncol,:) = proc_rates%mnuccctot(:ncol,1:nlev) + call subcol_field_avg(mnuccctot_sc, ngrdcol, lchnk, mnuccco_grid(:,top_lev:)) + mnuccttot_sc(:ncol,:) = proc_rates%mnuccttot(:ncol,1:nlev) + call subcol_field_avg(mnuccttot_sc, ngrdcol, lchnk, mnuccto_grid(:,top_lev:)) + bergtot_sc(:ncol,:) = proc_rates%bergtot(:ncol,1:nlev) + call subcol_field_avg(bergtot_sc, ngrdcol, lchnk, bergo_grid(:,top_lev:)) + homotot_sc(:ncol,:) = proc_rates%homotot(:ncol,1:nlev) + call subcol_field_avg(homotot_sc, ngrdcol, lchnk, homoo_grid(:,top_lev:)) + msacwitot_sc(:ncol,:) = proc_rates%msacwitot(:ncol,1:nlev) + call subcol_field_avg(msacwitot_sc, ngrdcol, lchnk, msacwio_grid(:,top_lev:)) + psacwstot_sc(:ncol,:) = proc_rates%psacwstot(:ncol,1:nlev) + call subcol_field_avg(psacwstot_sc, ngrdcol, lchnk, psacwso_grid(:,top_lev:)) + cmeitot_sc(:ncol,:) = proc_rates%cmeitot(:ncol,1:nlev) + call subcol_field_avg(cmeitot_sc, ngrdcol, lchnk, cmeiout_grid(:,top_lev:)) + qirestot_sc(:ncol,:) = proc_rates%qirestot(:ncol,1:nlev) + call subcol_field_avg(qirestot_sc, ngrdcol, lchnk, qireso_grid(:,top_lev:)) + prcitot_sc(:ncol,:) = proc_rates%prcitot(:ncol,1:nlev) + call subcol_field_avg(prcitot_sc, ngrdcol, lchnk, prcio_grid(:,top_lev:)) + praitot_sc(:ncol,:) = proc_rates%praitot(:ncol,1:nlev) + call subcol_field_avg(praitot_sc, ngrdcol, lchnk, praio_grid(:,top_lev:)) + + call subcol_field_avg(icwmrst, ngrdcol, lchnk, icwmrst_grid) + call subcol_field_avg(icimrst, ngrdcol, lchnk, icimrst_grid) + call subcol_field_avg(liqcldf, ngrdcol, lchnk, liqcldf_grid) + call subcol_field_avg(icecldf, ngrdcol, lchnk, icecldf_grid) + call subcol_field_avg(icwnc, ngrdcol, lchnk, icwnc_grid) + call subcol_field_avg(icinc, ngrdcol, lchnk, icinc_grid) + call subcol_field_avg(state_loc%pdel, ngrdcol, lchnk, pdel_grid) + + pratot_sc(:ncol,:) = proc_rates%pratot(:ncol,1:nlev) + call subcol_field_avg(pratot_sc, ngrdcol, lchnk, prao_grid(:,top_lev:)) + prctot_sc(:ncol,:) = proc_rates%prctot(:ncol,1:nlev) + call subcol_field_avg(prctot_sc, ngrdcol, lchnk, prco_grid(:,top_lev:)) + + call subcol_field_avg(state_loc%q(:,:,ixnumliq), ngrdcol, lchnk, nc_grid(:,top_lev:)) + call subcol_field_avg(state_loc%q(:,:,ixnumice), ngrdcol, lchnk, ni_grid(:,top_lev:)) + + qcsedten_sc(:ncol,:) = proc_rates%qcsedten(:ncol,1:nlev) + call subcol_field_avg(qcsedten_sc, ngrdcol, lchnk, qcsedtenout_grid(:,top_lev:)) + qisedten_sc(:ncol,:) = proc_rates%qisedten(:ncol,1:nlev) + call subcol_field_avg(qisedten_sc, ngrdcol, lchnk, qisedtenout_grid(:,top_lev:)) + vtrmc_sc(:ncol,:) = proc_rates%vtrmc(:ncol,1:nlev) + call subcol_field_avg(vtrmc_sc, ngrdcol, lchnk, vtrmcout_grid(:,top_lev:)) + vtrmi_sc(:ncol,:) = proc_rates%vtrmi(:ncol,1:nlev) + call subcol_field_avg(vtrmi_sc, ngrdcol, lchnk, vtrmiout_grid(:,top_lev:)) + qcsevap_sc(:ncol,:) = proc_rates%qcsevap(:ncol,1:nlev) + call subcol_field_avg(qcsevap_sc, ngrdcol, lchnk, qcsevapout_grid(:,top_lev:)) + qisevap_sc(:ncol,:) = proc_rates%qisevap(:ncol,1:nlev) + call subcol_field_avg(qisevap_sc, ngrdcol, lchnk, qisevapout_grid(:,top_lev:)) + + call subcol_field_avg(cldmax, ngrdcol, lchnk, cldmax_grid) + + call subcol_field_avg(state_loc%q(:,:,ixrain), ngrdcol, lchnk, qr_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumrain), ngrdcol, lchnk, nr_grid) + call subcol_field_avg(state_loc%q(:,:,ixsnow), ngrdcol, lchnk, qs_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumsnow), ngrdcol, lchnk, ns_grid) + + qrsedten_sc(:ncol,:) = proc_rates%qrsedten(:ncol,1:nlev) + call subcol_field_avg(qrsedten_sc, ngrdcol, lchnk, qrsedtenout_grid(:,top_lev:)) + qssedten_sc(:ncol,:) = proc_rates%qssedten(:ncol,1:nlev) + call subcol_field_avg(qssedten_sc, ngrdcol, lchnk, qssedtenout_grid(:,top_lev:)) + umr_sc(:ncol,:) = proc_rates%umr(:ncol,1:nlev) + call subcol_field_avg(umr_sc, ngrdcol, lchnk, umrout_grid(:,top_lev:)) + ums_sc(:ncol,:) = proc_rates%ums(:ncol,1:nlev) + call subcol_field_avg(ums_sc, ngrdcol, lchnk, umsout_grid(:,top_lev:)) + + if (micro_mg_version > 2) then + call subcol_field_avg(state_loc%q(:,:,ixgraupel), ngrdcol, lchnk, qg_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumgraupel), ngrdcol, lchnk, ng_grid) + + psacrtot_sc(:ncol,:) = proc_rates%psacrtot(:ncol,1:nlev) + call subcol_field_avg(psacrtot_sc, ngrdcol, lchnk, psacro_grid(:,top_lev:)) + pracgtot_sc(:ncol,:) = proc_rates%pracgtot(:ncol,1:nlev) + call subcol_field_avg(pracgtot_sc, ngrdcol, lchnk, pracgo_grid(:,top_lev:)) + psacwgtot_sc(:ncol,:) = proc_rates%psacwgtot(:ncol,1:nlev) + call subcol_field_avg(psacwgtot_sc, ngrdcol, lchnk, psacwgo_grid(:,top_lev:)) + pgsacwtot_sc(:ncol,:) = proc_rates%pgsacwtot(:ncol,1:nlev) + call subcol_field_avg(pgsacwtot_sc, ngrdcol, lchnk, pgsacwo_grid(:,top_lev:)) + pgracstot_sc(:ncol,:) = proc_rates%pgracstot(:ncol,1:nlev) + call subcol_field_avg(pgracstot_sc, ngrdcol, lchnk, pgracso_grid(:,top_lev:)) + prdgtot_sc(:ncol,:) = proc_rates%prdgtot(:ncol,1:nlev) + call subcol_field_avg(prdgtot_sc, ngrdcol, lchnk, prdgo_grid(:,top_lev:)) + qmultgtot_sc(:ncol,:) = proc_rates%qmultgtot(:ncol,1:nlev) + call subcol_field_avg(qmultgtot_sc, ngrdcol, lchnk, qmultgo_grid(:,top_lev:)) + qmultrgtot_sc(:ncol,:) = proc_rates%qmultrgtot(:ncol,1:nlev) + call subcol_field_avg(qmultrgtot_sc, ngrdcol, lchnk, qmultrgo_grid(:,top_lev:)) + npracgtot_sc(:ncol,:) = proc_rates%npracgtot(:ncol,1:nlev) + call subcol_field_avg(npracgtot_sc, ngrdcol, lchnk, npracgo_grid(:,top_lev:)) + nscngtot_sc(:ncol,:) = proc_rates%nscngtot(:ncol,1:nlev) + call subcol_field_avg(nscngtot_sc, ngrdcol, lchnk, nscngo_grid(:,top_lev:)) + ngracstot_sc(:ncol,:) = proc_rates%ngracstot(:ncol,1:nlev) + call subcol_field_avg(ngracstot_sc, ngrdcol, lchnk, ngracso_grid(:,top_lev:)) + nmultgtot_sc(:ncol,:) = proc_rates%nmultgtot(:ncol,1:nlev) + call subcol_field_avg(nmultgtot_sc, ngrdcol, lchnk, nmultgo_grid(:,top_lev:)) + nmultrgtot_sc(:ncol,:) = proc_rates%nmultrgtot(:ncol,1:nlev) + call subcol_field_avg(nmultrgtot_sc, ngrdcol, lchnk, nmultrgo_grid(:,top_lev:)) + npsacwgtot_sc(:ncol,:) = proc_rates%npsacwgtot(:ncol,1:nlev) + call subcol_field_avg(npsacwgtot_sc, ngrdcol, lchnk, npsacwgo_grid(:,top_lev:)) + end if + + else + qcreso_grid(:ncol,:top_lev-1) = 0._r8 + melto_grid(:ncol,:top_lev-1) = 0._r8 + mnuccco_grid(:ncol,:top_lev-1) = 0._r8 + mnuccto_grid(:ncol,:top_lev-1) = 0._r8 + bergo_grid(:ncol,:top_lev-1) = 0._r8 + homoo_grid(:ncol,:top_lev-1) = 0._r8 + msacwio_grid(:ncol,:top_lev-1) = 0._r8 + psacwso_grid(:ncol,:top_lev-1) = 0._r8 + cmeiout_grid(:ncol,:top_lev-1) = 0._r8 + qireso_grid(:ncol,:top_lev-1) = 0._r8 + prcio_grid(:ncol,:top_lev-1) = 0._r8 + praio_grid(:ncol,:top_lev-1) = 0._r8 + prao_grid(:ncol,:top_lev-1) = 0._r8 + prco_grid(:ncol,:top_lev-1) = 0._r8 + qcsedtenout_grid(:ncol,:top_lev-1) = 0._r8 + qisedtenout_grid(:ncol,:top_lev-1) = 0._r8 + vtrmcout_grid(:ncol,:top_lev-1) = 0._r8 + vtrmiout_grid(:ncol,:top_lev-1) = 0._r8 + qcsevapout_grid(:ncol,:top_lev-1) = 0._r8 + qisevapout_grid(:ncol,:top_lev-1) = 0._r8 + qrsedtenout_grid(:ncol,:top_lev-1) = 0._r8 + qssedtenout_grid(:ncol,:top_lev-1) = 0._r8 + qgsedtenout_grid(:ncol,:top_lev-1) = 0._r8 !+tht + umrout_grid(:ncol,:top_lev-1) = 0._r8 + umsout_grid(:ncol,:top_lev-1) = 0._r8 + psacro_grid(:ncol,:top_lev-1) = 0._r8 + pracgo_grid(:ncol,:top_lev-1) = 0._r8 + psacwgo_grid(:ncol,:top_lev-1) = 0._r8 + pgsacwo_grid(:ncol,:top_lev-1) = 0._r8 + pgracso_grid(:ncol,:top_lev-1) = 0._r8 + prdgo_grid(:ncol,:top_lev-1) = 0._r8 + qmultgo_grid(:ncol,:top_lev-1) = 0._r8 + qmultrgo_grid(:ncol,:top_lev-1) = 0._r8 + npracgo_grid(:ncol,:top_lev-1) = 0._r8 + nscngo_grid(:ncol,:top_lev-1) = 0._r8 + ngracso_grid(:ncol,:top_lev-1) = 0._r8 + nmultgo_grid(:ncol,:top_lev-1) = 0._r8 + nmultrgo_grid(:ncol,:top_lev-1) = 0._r8 + npsacwgo_grid(:ncol,:top_lev-1) = 0._r8 + bergso_grid(:ncol,:top_lev-1) = 0._r8 + + ! These pbuf fields need to be assigned. There is no corresponding subcol_field_avg + ! as they are reset before being used, so it would be a needless calculation + lambdac_grid => lambdac + mu_grid => mu + rel_grid => rel + rei_grid => rei + sadice_grid => sadice + sadsnow_grid => sadsnow + dei_grid => dei + des_grid => des + degrau_grid => degrau + + ! fields already on grids, so just assign + prec_str_grid => prec_str + iclwpst_grid => iclwpst + cvreffliq_grid => cvreffliq + cvreffice_grid => cvreffice + mgflxprc_grid => mgflxprc + mgflxsnw_grid => mgflxsnw + qme_grid => qme + nevapr_grid => nevapr + prain_grid => prain + + bergso_grid(:ncol,top_lev:) = proc_rates%bergstot + am_evp_st_grid = am_evp_st + + evpsnow_st_grid(:ncol,top_lev:) = proc_rates%evapsnow + qrout_grid = qrout + qsout_grid = qsout + nsout_grid = nsout + nrout_grid = nrout + cld_grid = cld + qcreso_grid(:ncol,top_lev:) = proc_rates%qcrestot + melto_grid(:ncol,top_lev:) = proc_rates%melttot + mnuccco_grid(:ncol,top_lev:) = proc_rates%mnuccctot + mnuccto_grid(:ncol,top_lev:) = proc_rates%mnuccttot + bergo_grid(:ncol,top_lev:) = proc_rates%bergtot + homoo_grid(:ncol,top_lev:) = proc_rates%homotot + msacwio_grid(:ncol,top_lev:) = proc_rates%msacwitot + psacwso_grid(:ncol,top_lev:) = proc_rates%psacwstot + cmeiout_grid(:ncol,top_lev:) = proc_rates%cmeitot + qireso_grid(:ncol,top_lev:) = proc_rates%qirestot + prcio_grid(:ncol,top_lev:) = proc_rates%prcitot + praio_grid(:ncol,top_lev:) = proc_rates%praitot + icwmrst_grid = icwmrst + icimrst_grid = icimrst + liqcldf_grid = liqcldf + icecldf_grid = icecldf + icwnc_grid = icwnc + icinc_grid = icinc + pdel_grid = state_loc%pdel + prao_grid(:ncol,top_lev:) = proc_rates%pratot + prco_grid(:ncol,top_lev:) = proc_rates%prctot + + nc_grid = state_loc%q(:,:,ixnumliq) + ni_grid = state_loc%q(:,:,ixnumice) + + qcsedtenout_grid(:ncol,top_lev:) = proc_rates%qcsedten + qisedtenout_grid(:ncol,top_lev:) = proc_rates%qisedten + vtrmcout_grid(:ncol,top_lev:) = proc_rates%vtrmc + vtrmiout_grid(:ncol,top_lev:) = proc_rates%vtrmi + qcsevapout_grid(:ncol,top_lev:) = proc_rates%qcsevap + qisevapout_grid(:ncol,top_lev:) = proc_rates%qisevap + + cldmax_grid = cldmax + + qr_grid = state_loc%q(:,:,ixrain) + nr_grid = state_loc%q(:,:,ixnumrain) + qs_grid = state_loc%q(:,:,ixsnow) + ns_grid = state_loc%q(:,:,ixnumsnow) + qrsedtenout_grid(:ncol,top_lev:) = proc_rates%qrsedten + qssedtenout_grid(:ncol,top_lev:) = proc_rates%qssedten + qgsedtenout_grid(:ncol,top_lev:) = proc_rates%qgsedten !+tht + umrout_grid(:ncol,top_lev:) = proc_rates%umr + umsout_grid(:ncol,top_lev:) = proc_rates%ums + +! Zero out terms for budgets if not mg3.... + psacwgo_grid = 0._r8 + pgsacwo_grid = 0._r8 + qmultgo_grid = 0._r8 + + if (micro_mg_version > 2) then + qg_grid = state_loc%q(:,:,ixgraupel) + ng_grid = state_loc%q(:,:,ixnumgraupel) + psacro_grid(:ncol,top_lev:) = proc_rates%psacrtot + pracgo_grid(:ncol,top_lev:) = proc_rates%pracgtot + psacwgo_grid(:ncol,top_lev:) = proc_rates%psacwgtot + pgsacwo_grid(:ncol,top_lev:) = proc_rates%pgsacwtot + pgracso_grid(:ncol,top_lev:) = proc_rates%pgracstot + prdgo_grid(:ncol,top_lev:) = proc_rates%prdgtot + qmultgo_grid(:ncol,top_lev:) = proc_rates%qmultgtot + qmultrgo_grid(:ncol,top_lev:) = proc_rates%qmultrgtot + npracgo_grid(:ncol,top_lev:) = proc_rates%npracgtot + nscngo_grid(:ncol,top_lev:) = proc_rates%nscngtot + ngracso_grid(:ncol,top_lev:) = proc_rates%ngracstot + nmultgo_grid(:ncol,top_lev:) = proc_rates%nmultgtot + nmultrgo_grid(:ncol,top_lev:) = proc_rates%nmultrgtot + npsacwgo_grid(:ncol,top_lev:) = proc_rates%npsacwgtot + end if + + + end if + + ! If on subcolumns, average the rest of the pbuf fields which were modified on subcolumns but are not used further in + ! this parameterization (no need to assign in the non-subcolumn case -- the else step) + if (use_subcol_microp) then + call subcol_field_avg(snow_str, ngrdcol, lchnk, snow_str_grid) + call subcol_field_avg(prec_pcw, ngrdcol, lchnk, prec_pcw_grid) + call subcol_field_avg(snow_pcw, ngrdcol, lchnk, snow_pcw_grid) + call subcol_field_avg(prec_sed, ngrdcol, lchnk, prec_sed_grid) + call subcol_field_avg(snow_sed, ngrdcol, lchnk, snow_sed_grid) + call subcol_field_avg(cldo, ngrdcol, lchnk, cldo_grid) + call subcol_field_avg(mgmrprc, ngrdcol, lchnk, mgmrprc_grid) + call subcol_field_avg(mgmrsnw, ngrdcol, lchnk, mgmrsnw_grid) + call subcol_field_avg(wsedl, ngrdcol, lchnk, wsedl_grid) + call subcol_field_avg(cc_t, ngrdcol, lchnk, cc_t_grid) + call subcol_field_avg(cc_qv, ngrdcol, lchnk, cc_qv_grid) + call subcol_field_avg(cc_ql, ngrdcol, lchnk, cc_ql_grid) + call subcol_field_avg(cc_qi, ngrdcol, lchnk, cc_qi_grid) + call subcol_field_avg(cc_nl, ngrdcol, lchnk, cc_nl_grid) + call subcol_field_avg(cc_ni, ngrdcol, lchnk, cc_ni_grid) + call subcol_field_avg(cc_qlst, ngrdcol, lchnk, cc_qlst_grid) + call subcol_field_avg(iciwpst, ngrdcol, lchnk, iciwpst_grid) + call subcol_field_avg(icswp, ngrdcol, lchnk, icswp_grid) + call subcol_field_avg(cldfsnow, ngrdcol, lchnk, cldfsnow_grid) + + if (micro_mg_version > 2) then + call subcol_field_avg(icgrauwp, ngrdcol, lchnk, icgrauwp_grid) + call subcol_field_avg(cldfgrau, ngrdcol, lchnk, cldfsnow_grid) + end if + + if (rate1_cw2pr_st_idx > 0) then + call subcol_field_avg(rate1ord_cw2pr_st, ngrdcol, lchnk, rate1ord_cw2pr_st_grid) + end if + + end if + + ! ------------------------------------- ! + ! Size distribution calculation ! + ! ------------------------------------- ! + + ! Calculate rho (on subcolumns if turned on) for size distribution + ! parameter calculations and average it if needed + ! + ! State instead of state_loc to preserve answers for MG1 (and in any + ! case, it is unlikely to make much difference). + rho(:ncol,top_lev:) = state%pmid(:ncol,top_lev:) / & + (rair*state%t(:ncol,top_lev:)) + if (use_subcol_microp) then + call subcol_field_avg(rho, ngrdcol, lchnk, rho_grid) + else + rho_grid = rho + end if + + ! Effective radius for cloud liquid, fixed number. + mu_grid = 0._r8 + lambdac_grid = 0._r8 + rel_fn_grid = 10._r8 + + ncic_grid = 1.e8_r8 + + do k = top_lev, pver + !$acc data copyin (mg_liq_props,icwmrst_grid(:ngrdcol,k),rho_grid(:ngrdcol,k)) & + !$acc copy (ncic_grid(:ngrdcol,k)) & + !$acc copyout (mu_grid(:ngrdcol,k),lambdac_grid(:ngrdcol,k)) + call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,k), & + ncic_grid(:ngrdcol,k), rho_grid(:ngrdcol,k), & + mu_grid(:ngrdcol,k), lambdac_grid(:ngrdcol,k), ngrdcol) + !$acc end data + end do + + where (icwmrst_grid(:ngrdcol,top_lev:) > qsmall) + rel_fn_grid(:ngrdcol,top_lev:) = & + (mu_grid(:ngrdcol,top_lev:) + 3._r8)/ & + lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 + end where + + ! Effective radius for cloud liquid, and size parameters + ! mu_grid and lambdac_grid. + mu_grid = 0._r8 + lambdac_grid = 0._r8 + rel_grid = 10._r8 + + ! Calculate ncic on the grid + ncic_grid(:ngrdcol,top_lev:) = nc_grid(:ngrdcol,top_lev:) / & + max(mincld,liqcldf_grid(:ngrdcol,top_lev:)) + + do k = top_lev, pver + !$acc data copyin (mg_liq_props,icwmrst_grid(:ngrdcol,k), rho_grid(:ngrdcol,k)) & + !$acc copy (ncic_grid(:ngrdcol,k)) & + !$acc copyout (mu_grid(:ngrdcol,k),lambdac_grid(:ngrdcol,k)) + call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,k), & + ncic_grid(:ngrdcol,k), rho_grid(:ngrdcol,k), & + mu_grid(:ngrdcol,k), lambdac_grid(:ngrdcol,k), ngrdcol) + !$acc end data + end do + + where (icwmrst_grid(:ngrdcol,top_lev:) >= qsmall) + rel_grid(:ngrdcol,top_lev:) = & + (mu_grid(:ngrdcol,top_lev:) + 3._r8) / & + lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 + elsewhere + ! Deal with the fact that size_dist_param_liq sets mu_grid to -100 + ! wherever there is no cloud. + mu_grid(:ngrdcol,top_lev:) = 0._r8 + end where + + ! Rain/Snow effective diameter. + drout2_grid = 0._r8 + reff_rain_grid = 0._r8 + des_grid = 0._r8 + dsout2_grid = 0._r8 + reff_snow_grid = 0._r8 + reff_grau_grid = 0._r8 + + ! Prognostic precipitation + + where (qr_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + drout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qr_grid(:ngrdcol,top_lev:), & + nr_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhow) + + reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & + shapeparam * micron2meter + end where + + where (qs_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qs_grid(:ngrdcol,top_lev:), & + ns_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhosn) + + des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) *& + 3._r8 * rhosn/rhows + + reff_snow_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) * & + shapeparam * micron2meter + end where + + +! Graupel/Hail size distribution Placeholder + if (micro_mg_version > 2) then + degrau_grid = 0._r8 + where (qg_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + dgout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qg_grid(:ngrdcol,top_lev:), & + ng_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhog) + + reff_grau_grid(:ngrdcol,top_lev:) = dgout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + degrau_grid(:ngrdcol,top_lev:) = dgout2_grid(:ngrdcol,top_lev:) *& + 3._r8 * rhog/rhows + end where + end if + + ! Effective radius and diameter for cloud ice. + rei_grid = 25._r8 + + niic_grid(:ngrdcol,top_lev:) = ni_grid(:ngrdcol,top_lev:) / & + max(mincld,icecldf_grid(:ngrdcol,top_lev:)) + + do k = top_lev, pver + !$acc data copyin (mg_ice_props, icimrst_grid(:ngrdcol,k)) & + !$acc copy (niic_grid(:ngrdcol,k)) & + !$acc copyout (rei_grid(:ngrdcol,k)) + call size_dist_param_basic(mg_ice_props,icimrst_grid(:ngrdcol,k), & + niic_grid(:ngrdcol,k),rei_grid(:ngrdcol,k),ngrdcol) + !$acc end data + end do + + where (icimrst_grid(:ngrdcol,top_lev:) >= qsmall) + rei_grid(:ngrdcol,top_lev:) = 1.5_r8/rei_grid(:ngrdcol,top_lev:) & + * 1.e6_r8 + elsewhere + rei_grid(:ngrdcol,top_lev:) = 25._r8 + end where + + dei_grid = rei_grid * rhoi/rhows * 2._r8 + + ! Limiters for low cloud fraction. + do k = top_lev, pver + do i = 1, ngrdcol + ! Convert snow effective diameter to microns + des_grid(i,k) = des_grid(i,k) * 1.e6_r8 + if ( ast_grid(i,k) < 1.e-4_r8 ) then + mu_grid(i,k) = mucon + lambdac_grid(i,k) = (mucon + 1._r8)/dcon + dei_grid(i,k) = deicon + end if + end do + end do + + mgreffrain_grid(:ngrdcol,top_lev:pver) = reff_rain_grid(:ngrdcol,top_lev:pver) + mgreffsnow_grid(:ngrdcol,top_lev:pver) = reff_snow_grid(:ngrdcol,top_lev:pver) + + ! ------------------------------------- ! + ! Precipitation efficiency Calculation ! + ! ------------------------------------- ! + + !----------------------------------------------------------------------- + ! Liquid water path + + ! Compute liquid water paths, and column condensation + tgliqwp_grid(:ngrdcol) = 0._r8 + tgcmeliq_grid(:ngrdcol) = 0._r8 + do k = top_lev, pver + do i = 1, ngrdcol + tgliqwp_grid(i) = tgliqwp_grid(i) + iclwpst_grid(i,k)*cld_grid(i,k) + + if (cmeliq_grid(i,k) > 1.e-12_r8) then + !convert cmeliq to right units: kgh2o/kgair/s * kgair/m2 / kgh2o/m3 = m/s + tgcmeliq_grid(i) = tgcmeliq_grid(i) + cmeliq_grid(i,k) * & + (pdel_grid(i,k) / gravit) / rhoh2o + end if + end do + end do + + ! note: 1e-6 kgho2/kgair/s * 1000. pa / (9.81 m/s2) / 1000 kgh2o/m3 = 1e-7 m/s + ! this is 1ppmv of h2o in 10hpa + ! alternatively: 0.1 mm/day * 1.e-4 m/mm * 1/86400 day/s = 1.e-9 + + !----------------------------------------------------------------------- + ! precipitation efficiency calculation (accumulate cme and precip) + + minlwp = 0.01_r8 !minimum lwp threshold (kg/m3) + + ! zero out precip efficiency and total averaged precip + pe_grid(:ngrdcol) = 0._r8 + tpr_grid(:ngrdcol) = 0._r8 + pefrac_grid(:ngrdcol) = 0._r8 + + ! accumulate precip and condensation + do i = 1, ngrdcol + + acgcme_grid(i) = acgcme_grid(i) + tgcmeliq_grid(i) + acprecl_grid(i) = acprecl_grid(i) + prec_str_grid(i) + acnum_grid(i) = acnum_grid(i) + 1 + + ! if LWP is zero, then 'end of cloud': calculate precip efficiency + if (tgliqwp_grid(i) < minlwp) then + if (acprecl_grid(i) > 5.e-8_r8) then + tpr_grid(i) = max(acprecl_grid(i)/acnum_grid(i), 1.e-15_r8) + if (acgcme_grid(i) > 1.e-10_r8) then + pe_grid(i) = min(max(acprecl_grid(i)/acgcme_grid(i), 1.e-15_r8), 1.e5_r8) + pefrac_grid(i) = 1._r8 + end if + end if + + ! reset counters +! if (pe_grid(i) /= 0._r8 .and. (pe_grid(i) < 1.e-8_r8 .or. pe_grid(i) > 1.e3_r8)) then +! write (iulog,*) 'PE_grid:ANOMALY pe_grid, acprecl_grid, acgcme_grid, tpr_grid, acnum_grid ', & +! pe_grid(i),acprecl_grid(i), acgcme_grid(i), tpr_grid(i), acnum_grid(i) +! endif + + acprecl_grid(i) = 0._r8 + acgcme_grid(i) = 0._r8 + acnum_grid(i) = 0 + end if ! end LWP zero conditional + + ! if never find any rain....(after 10^3 timesteps...) + if (acnum_grid(i) > 1000) then + acnum_grid(i) = 0 + acprecl_grid(i) = 0._r8 + acgcme_grid(i) = 0._r8 + end if + + end do + + !----------------------------------------------------------------------- + ! vertical average of non-zero accretion, autoconversion and ratio. + ! vars: vprco_grid(i),vprao_grid(i),racau_grid(i),cnt_grid + + vprao_grid = 0._r8 + cnt_grid = 0 + do k = top_lev, pver + vprao_grid(:ngrdcol) = vprao_grid(:ngrdcol) + prao_grid(:ngrdcol,k) + where (prao_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 + end do + + where (cnt_grid > 0) vprao_grid = vprao_grid/cnt_grid + + vprco_grid = 0._r8 + cnt_grid = 0 + do k = top_lev, pver + vprco_grid(:ngrdcol) = vprco_grid(:ngrdcol) + prco_grid(:ngrdcol,k) + where (prco_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 + end do + + where (cnt_grid > 0) + vprco_grid = vprco_grid/cnt_grid + racau_grid = vprao_grid/vprco_grid + elsewhere + racau_grid = 0._r8 + end where + + racau_grid = min(racau_grid, 1.e10_r8) + +!----------------------------------------------------------------------- +! Diagnostic Rainbow Calculation. Seriously. +!----------------------------------------------------------------------- + + do i = 1, ngrdcol + + top_idx = pver + convmx = 0._r8 + frlow = 0._r8 + cldmx = 0._r8 + cldtot = maxval(ast(i,top_lev:)) + +! Find levels in surface layer + do k = top_lev, pver + if (state%pmid(i,k) > rb_pmin) then + top_idx = min(k,top_idx) + end if + end do + +!For all fractional precip calculated below, use maximum in surface layer. +!For convective precip, base on convective cloud area + convmx = maxval(concld(i,top_idx:)) +!For stratiform precip, base on precip fraction + cldmx= maxval(freqr(i,top_idx:)) +! Combine and use maximum of strat or conv fraction + frlow= max(cldmx,convmx) + +!max precip + rmax=maxval(qrout_grid(i,top_idx:)) + +! Stratiform precip mixing ratio OR some convective precip +! (rval = true if any sig precip) + + rval = ((precc(i) > rb_rcmin) .or. (rmax > rb_rmin)) + +!Now can find conditions for a rainbow: +! Maximum cloud cover (CLDTOT) < 0.5 +! 48 < SZA < 90 +! freqr (below rb_pmin) > 0.25 +! Some rain (liquid > 1.e-6 kg/kg, convective precip > 1.e-7 m/s + + if ((cldtot < 0.5_r8) .and. (sza(i) > 48._r8) .and. (sza(i) < 90._r8) .and. rval) then + +!Rainbow 'probability' (area) derived from solid angle theory +!as the fraction of the hemisphere for a spherical cap with angle phi=sza-48. +! This is only valid between 48 < sza < 90 (controlled for above). + + rbfrac(i) = max(0._r8,(1._r8-COS((sza(i)-48._r8)*deg2rad))/2._r8) * frlow + rbfreq(i) = 1.0_r8 + end if + + end do ! end column loop for rainbows + + call outfld('RBFRAC', rbfrac, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('RBFREQ', rbfreq, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + + + ! --------------------- ! + ! History Output Fields ! + ! --------------------- ! + + ! Column droplet concentration + cdnumc_grid(:ngrdcol) = sum(nc_grid(:ngrdcol,top_lev:pver) * & + pdel_grid(:ngrdcol,top_lev:pver)/gravit, dim=2) + + ! Averaging for new output fields + efcout_grid = 0._r8 + efiout_grid = 0._r8 + ncout_grid = 0._r8 + niout_grid = 0._r8 + freql_grid = 0._r8 + freqi_grid = 0._r8 + icwmrst_grid_out = 0._r8 + icimrst_grid_out = 0._r8 + freqm_grid = 0._r8 + freqsl_grid = 0._r8 + freqslm_grid = 0._r8 + + do k = top_lev, pver + do i = 1, ngrdcol + if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 5.e-5_r8 ) then + efcout_grid(i,k) = rel_grid(i,k) * liqcldf_grid(i,k) + ncout_grid(i,k) = icwnc_grid(i,k) * liqcldf_grid(i,k) + freql_grid(i,k) = liqcldf_grid(i,k) + icwmrst_grid_out(i,k) = icwmrst_grid(i,k) + end if + if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-6_r8 ) then + efiout_grid(i,k) = rei_grid(i,k) * icecldf_grid(i,k) + niout_grid(i,k) = icinc_grid(i,k) * icecldf_grid(i,k) + freqi_grid(i,k) = icecldf_grid(i,k) + icimrst_grid_out(i,k) = icimrst_grid(i,k) + end if + + ! Supercooled liquid + if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) > 0.01_r8 ) then + freqm_grid(i,k)=min(liqcldf_grid(i,k),icecldf_grid(i,k)) + end if + if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) < 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + freqsl_grid(i,k)=liqcldf_grid(i,k) + end if + if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) > 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + freqslm_grid(i,k)=liqcldf_grid(i,k) + end if + + end do + end do + + ! Cloud top effective radius and number. + fcti_grid = 0._r8 + fctl_grid = 0._r8 + ctrel_grid = 0._r8 + ctrei_grid = 0._r8 + ctnl_grid = 0._r8 + ctni_grid = 0._r8 + fctm_grid = 0._r8 + fctsl_grid = 0._r8 + fctslm_grid= 0._r8 + + do i = 1, ngrdcol + do k = top_lev, pver + if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 1.e-7_r8 ) then + ctrel_grid(i) = rel_grid(i,k) * liqcldf_grid(i,k) + ctnl_grid(i) = icwnc_grid(i,k) * liqcldf_grid(i,k) + fctl_grid(i) = liqcldf_grid(i,k) + + ! Cloud Top Mixed phase, supercooled liquid only and supercooled liquid mixed + if (freqi_grid(i,k) > 0.01_r8) then + fctm_grid(i)=min(liqcldf_grid(i,k),icecldf_grid(i,k)) + end if + if (freqi_grid(i,k) < 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + fctsl_grid(i)=liqcldf_grid(i,k) + end if + if (freqi_grid(i,k) > 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + fctslm_grid(i)=liqcldf_grid(i,k) + end if + + exit + end if + + if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-7_r8 ) then + ctrei_grid(i) = rei_grid(i,k) * icecldf_grid(i,k) + ctni_grid(i) = icinc_grid(i,k) * icecldf_grid(i,k) + fcti_grid(i) = icecldf_grid(i,k) + exit + end if + end do + end do + + ! Evaporation of stratiform precipitation fields for UNICON + evprain_st_grid(:ngrdcol,:pver) = nevapr_grid(:ngrdcol,:pver) - evpsnow_st_grid(:ngrdcol,:pver) + do k = top_lev, pver + do i = 1, ngrdcol + evprain_st_grid(i,k) = max(evprain_st_grid(i,k), 0._r8) + evpsnow_st_grid(i,k) = max(evpsnow_st_grid(i,k), 0._r8) + end do + end do + + ! Assign the values to the pbuf pointers if they exist in pbuf + if (qrain_idx > 0) qrout_grid_ptr = qrout_grid + if (qsnow_idx > 0) qsout_grid_ptr = qsout_grid + if (nrain_idx > 0) nrout_grid_ptr = nrout_grid + if (nsnow_idx > 0) nsout_grid_ptr = nsout_grid + if (qcsedten_idx > 0) qcsedtenout_grid_ptr = qcsedtenout_grid + if (qrsedten_idx > 0) qrsedtenout_grid_ptr = qrsedtenout_grid + if (qisedten_idx > 0) qisedtenout_grid_ptr = qisedtenout_grid + if (qssedten_idx > 0) qssedtenout_grid_ptr = qssedtenout_grid + if (qgsedten_idx > 0) qgsedtenout_grid_ptr = qgsedtenout_grid !+tht + if (vtrmc_idx > 0) vtrmcout_grid_ptr = vtrmcout_grid + if (umr_idx > 0) umrout_grid_ptr = umrout_grid + if (vtrmi_idx > 0) vtrmiout_grid_ptr = vtrmiout_grid + if (ums_idx > 0) umsout_grid_ptr = umsout_grid + if (qcsevap_idx > 0 ) qcsevapout_grid_ptr = qcsevapout_grid + if (qisevap_idx > 0 ) qisevapout_grid_ptr = qisevapout_grid + + ! --------------------------------------------- ! + ! General outfield calls for microphysics ! + ! --------------------------------------------- ! + + ! Output a handle of variables which are calculated on the fly + + ftem_grid = 0._r8 + + ftem_grid(:ngrdcol,top_lev:pver) = qcreso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDW2V', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = melto_grid(:ngrdcol,top_lev:pver) - mnuccco_grid(:ngrdcol,top_lev:pver)& + - mnuccto_grid(:ngrdcol,top_lev:pver) - bergo_grid(:ngrdcol,top_lev:pver) - homoo_grid(:ngrdcol,top_lev:pver)& + - msacwio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDW2I', ftem_grid, pcols, lchnk) + + if (micro_mg_version > 2) then + ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& + - psacwso_grid(:ngrdcol,top_lev:pver) - bergso_grid(:ngrdcol,top_lev:pver)& + - psacwgo_grid(:ngrdcol,top_lev:pver) - pgsacwo_grid(:ngrdcol,top_lev:pver) + else + ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& + - psacwso_grid(:ngrdcol,top_lev:pver) - bergso_grid(:ngrdcol,top_lev:pver) + endif + + call outfld( 'MPDW2P', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = cmeiout_grid(:ngrdcol,top_lev:pver) + qireso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2V', ftem_grid, pcols, lchnk) + + if (micro_mg_version > 2) then + ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & + + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& + + msacwio_grid(:ngrdcol,top_lev:pver)& + - qmultgo_grid(:ngrdcol,top_lev:pver) + else + ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & + + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& + + msacwio_grid(:ngrdcol,top_lev:pver) + endif + + call outfld( 'MPDI2W', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = -prcio_grid(:ngrdcol,top_lev:pver) - praio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2P', ftem_grid, pcols, lchnk) + + ! Output fields which have not been averaged already, averaging if use_subcol_microp is true + if (trim(micro_mg_warm_rain) == 'tau' .or. trim(micro_mg_warm_rain) == 'emulated') then + call outfld('scale_qc', proc_rates%scale_qc, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('scale_nc', proc_rates%scale_nc, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('scale_qr', proc_rates%scale_qr, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('scale_nr', proc_rates%scale_nr, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('amk_c', proc_rates%amk_c, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ank_c', proc_rates%ank_c, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('amk_r', proc_rates%amk_r, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ank_r', proc_rates%ank_r, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('amk', proc_rates%amk, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ank', proc_rates%ank, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('amk_out', proc_rates%amk_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ank_out', proc_rates%ank_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QC_TAU_out', proc_rates%qc_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NC_TAU_out', proc_rates%nc_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QR_TAU_out', proc_rates%qr_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NR_TAU_out', proc_rates%nr_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('qctend_TAU', proc_rates%qctend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nctend_TAU', proc_rates%nctend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('qrtend_TAU', proc_rates%qrtend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nrtend_TAU', proc_rates%nrtend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('gmnnn_lmnnn_TAU', proc_rates%gmnnn_lmnnn_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ML_fixer', proc_rates%ML_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('qc_fixer', proc_rates%qc_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nc_fixer', proc_rates%nc_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('qr_fixer', proc_rates%qr_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nr_fixer', proc_rates%nr_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QC_TAU_in', proc_rates%qc_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NC_TAU_in', proc_rates%nc_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QR_TAU_in', proc_rates%qr_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NR_TAU_in', proc_rates%nr_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) + end if + + if (trim(micro_mg_warm_rain) == 'sb2001') then + call outfld('qctend_SB2001', proc_rates%qctend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nctend_SB2001', proc_rates%nctend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('qrtend_SB2001', proc_rates%qrtend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nrtend_SB2001', proc_rates%nrtend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) + end if + if (trim(micro_mg_warm_rain) == 'kk2000') then + call outfld('qctend_KK2000', proc_rates%qctend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nctend_KK2000', proc_rates%nctend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('qrtend_KK2000', proc_rates%qrtend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('nrtend_KK2000', proc_rates%nrtend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) + end if + call outfld('LAMC', proc_rates%lamc_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('LAMR', proc_rates%lamr_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('PGAM', proc_rates%pgam_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('N0R', proc_rates%n0r_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) + + call outfld('MPICLWPI', iclwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPICIWPI', iciwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('REFL', refl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AREFL', arefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AREFLZ', areflz, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREFL', frefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('CSRFL', csrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ACSRFL', acsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FCSRFL', fcsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('REFL10CM', refl10cm, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('REFLZ10CM', reflz10cm, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('RERCLD', rercld, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NCAL', ncal, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NCAI', ncai, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQRAIN', qrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQSNOW', qsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANRAIN', nrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANSNOW', nsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQR', freqr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQS', freqs, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDT', tlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDQ', qvlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDLIQ', qcten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDICE', qiten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDNLIQ', ncten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDNICE', niten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('EVAPSNOW', proc_rates%evapsnow, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QCSEVAP', proc_rates%qcsevap, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QISEVAP', proc_rates%qisevap, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QVRES', proc_rates%qvres, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VTRMC', proc_rates%vtrmc, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VTRMI', proc_rates%vtrmi, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QCSEDTEN', proc_rates%qcsedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QISEDTEN', proc_rates%qisedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QRSEDTEN', proc_rates%qrsedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QSSEDTEN', proc_rates%qssedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCRIO', proc_rates%mnuccritot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUDEPO', proc_rates%mnudeptot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MELTSTOT', proc_rates%meltstot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCDO', proc_rates%mnuccdtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCDOhet', mnuccdohet, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCRO', proc_rates%mnuccrtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('PRACSO', proc_rates%pracstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VAPDEPSO', proc_rates%vapdepstot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MELTSDT', proc_rates%meltsdttot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FRZRDT', proc_rates%frzrdttot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FICE', nfice, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('CLDFSNOW', cldfsnow, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NNUCCCO', proc_rates%nnuccctot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NNUCCTO', proc_rates%nnuccttot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NNUCCDO', proc_rates%nnuccdtot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NNUDEPO', proc_rates%nnudeptot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NHOMO', proc_rates%nhomotot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NNUCCRO', proc_rates%nnuccrtot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NNUCCRIO', proc_rates%nnuccritot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NSACWIO', proc_rates%nsacwitot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NPRAO', proc_rates%npratot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NPSACWSO', proc_rates%npsacwstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NPRAIO', proc_rates%npraitot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NPRACSO', proc_rates%npracstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NPRCO', proc_rates%nprctot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NPRCIO', proc_rates%nprcitot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NCSEDTEN', proc_rates%ncsedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NISEDTEN', proc_rates%nisedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NRSEDTEN', proc_rates%nrsedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NSSEDTEN', proc_rates%nssedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NMELTO', proc_rates%nmelttot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld ('NMELTS', proc_rates%nmeltstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) + + call outfld('UMR', proc_rates%umr, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('UMS', proc_rates%ums, ncol, lchnk, avg_subcol_field=use_subcol_microp) + + call outfld('QCRAT', qcrat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + + if (micro_mg_version > 2) then + call outfld('UMG', proc_rates%umg, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QGSEDTEN', proc_rates%qgsedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQG', freqg, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQGRAU', qgout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANGRAU', ngout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('CLDFGRAU', cldfgrau, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MELTGTOT', proc_rates%meltgtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NMELTG', proc_rates%nmeltgtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NGSEDTEN', proc_rates%ngsedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) + + end if + + ! Example subcolumn outfld call + if (use_subcol_microp) then + call outfld('FICE_SCOL', nfice, psubcols*pcols, lchnk) + call outfld('MPDLIQ_SCOL', ptend%q(:,:,ixcldliq), psubcols*pcols, lchnk) + call outfld('MPDICE_SCOL', qiten, psubcols*pcols, lchnk) + end if + + ! Output fields which are already on the grid + call outfld('QRAIN', qrout_grid, pcols, lchnk) + call outfld('QSNOW', qsout_grid, pcols, lchnk) + call outfld('NRAIN', nrout_grid, pcols, lchnk) + call outfld('NSNOW', nsout_grid, pcols, lchnk) + call outfld('CV_REFFLIQ', cvreffliq_grid, pcols, lchnk) + call outfld('CV_REFFICE', cvreffice_grid, pcols, lchnk) + call outfld('LS_FLXPRC', mgflxprc_grid, pcols, lchnk) + call outfld('LS_FLXSNW', mgflxsnw_grid, pcols, lchnk) + call outfld('CME', qme_grid, pcols, lchnk) + call outfld('PRODPREC', prain_grid, pcols, lchnk) + call outfld('EVAPPREC', nevapr_grid, pcols, lchnk) + call outfld('QCRESO', qcreso_grid, pcols, lchnk) + call outfld('LS_REFFRAIN', mgreffrain_grid, pcols, lchnk) + call outfld('LS_REFFSNOW', mgreffsnow_grid, pcols, lchnk) + call outfld('DSNOW', des_grid, pcols, lchnk) + call outfld('ADRAIN', drout2_grid, pcols, lchnk) + call outfld('ADSNOW', dsout2_grid, pcols, lchnk) + call outfld('PE', pe_grid, pcols, lchnk) + call outfld('PEFRAC', pefrac_grid, pcols, lchnk) + call outfld('APRL', tpr_grid, pcols, lchnk) + call outfld('VPRAO', vprao_grid, pcols, lchnk) + call outfld('VPRCO', vprco_grid, pcols, lchnk) + call outfld('RACAU', racau_grid, pcols, lchnk) + call outfld('AREL', efcout_grid, pcols, lchnk) + call outfld('AREI', efiout_grid, pcols, lchnk) + call outfld('AWNC' , ncout_grid, pcols, lchnk) + call outfld('AWNI' , niout_grid, pcols, lchnk) + call outfld('FREQL', freql_grid, pcols, lchnk) + call outfld('FREQI', freqi_grid, pcols, lchnk) + call outfld('ACTREL', ctrel_grid, pcols, lchnk) + call outfld('ACTREI', ctrei_grid, pcols, lchnk) + call outfld('ACTNL', ctnl_grid, pcols, lchnk) + call outfld('ACTNI', ctni_grid, pcols, lchnk) + call outfld('FCTL', fctl_grid, pcols, lchnk) + call outfld('FCTI', fcti_grid, pcols, lchnk) + call outfld('ICINC', icinc_grid, pcols, lchnk) + call outfld('ICWNC', icwnc_grid, pcols, lchnk) + call outfld('EFFLIQ_IND', rel_fn_grid, pcols, lchnk) + call outfld('CDNUMC', cdnumc_grid, pcols, lchnk) + call outfld('REL', rel_grid, pcols, lchnk) + call outfld('REI', rei_grid, pcols, lchnk) + call outfld('MG_SADICE', sadice_grid, pcols, lchnk) + call outfld('MG_SADSNOW', sadsnow_grid, pcols, lchnk) + call outfld('ICIMRST', icimrst_grid_out, pcols, lchnk) + call outfld('ICWMRST', icwmrst_grid_out, pcols, lchnk) + call outfld('CMEIOUT', cmeiout_grid, pcols, lchnk) + call outfld('PRAO', prao_grid, pcols, lchnk) + call outfld('PRCO', prco_grid, pcols, lchnk) + call outfld('MNUCCCO', mnuccco_grid, pcols, lchnk) + call outfld('MNUCCTO', mnuccto_grid, pcols, lchnk) + call outfld('MSACWIO', msacwio_grid, pcols, lchnk) + call outfld('PSACWSO', psacwso_grid, pcols, lchnk) + call outfld('BERGSO', bergso_grid, pcols, lchnk) + call outfld('BERGO', bergo_grid, pcols, lchnk) + call outfld('MELTO', melto_grid, pcols, lchnk) + call outfld('HOMOO', homoo_grid, pcols, lchnk) + call outfld('PRCIO', prcio_grid, pcols, lchnk) + call outfld('PRAIO', praio_grid, pcols, lchnk) + call outfld('QIRESO', qireso_grid, pcols, lchnk) + call outfld('FREQM', freqm_grid, pcols, lchnk) + call outfld('FREQSL', freqsl_grid, pcols, lchnk) + call outfld('FREQSLM', freqslm_grid, pcols, lchnk) + call outfld('FCTM', fctm_grid, pcols, lchnk) + call outfld('FCTSL', fctsl_grid, pcols, lchnk) + call outfld('FCTSLM', fctslm_grid, pcols, lchnk) + + if (micro_mg_version > 2) then + call outfld('PRACGO', pracgo_grid, pcols, lchnk) + call outfld('PSACRO', psacro_grid, pcols, lchnk) + call outfld('PSACWGO', psacwgo_grid, pcols, lchnk) + call outfld('PGSACWO', pgsacwo_grid, pcols, lchnk) + call outfld('PGRACSO', pgracso_grid, pcols, lchnk) + call outfld('PRDGO', prdgo_grid, pcols, lchnk) + call outfld('QMULTGO', qmultgo_grid, pcols, lchnk) + call outfld('QMULTRGO', qmultrgo_grid, pcols, lchnk) + call outfld('LS_REFFGRAU', reff_grau_grid, pcols, lchnk) + call outfld ('NPRACGO', npracgo_grid, pcols, lchnk) + call outfld ('NSCNGO', nscngo_grid, pcols, lchnk) + call outfld ('NGRACSO', ngracso_grid, pcols, lchnk) + call outfld ('NMULTGO', nmultgo_grid, pcols, lchnk) + call outfld ('NMULTRGO', nmultrgo_grid, pcols, lchnk) + call outfld ('NPSACWGO', npsacwgo_grid, pcols, lchnk) + end if + + if (micro_mg_adjust_cpt) then + cp_rh(:ncol, :pver) = 0._r8 + + do i = 1, ncol + + ! Calculate the RH including any T change that we make. + do k = top_lev, pver + call qsat(state_loc%t(i,k), state_loc%pmid(i,k), es, qs) + cp_rh(i,k) = state_loc%q(i, k, ixq) / qs * 100._r8 + end do + end do + + call outfld("TROPF_RHADJ", cp_rh, pcols, lchnk) + end if + + ! deallocate the temporary pbuf grid variable which was allocated if subcolumns are not used + if (.not. use_subcol_microp) then + deallocate(bergso_grid) + end if + + ! deallocate the proc_rates DDT + call proc_rates%deallocate(micro_mg_warm_rain) + + ! ptend_loc is deallocated in physics_update above + call physics_state_dealloc(state_loc) + + if (qsatfac_idx <= 0) then + deallocate(qsatfac) + end if + +end subroutine micro_pumas_cam_tend + +subroutine massless_droplet_destroyer(ztodt, state, ptend) + + ! This subroutine eradicates cloud droplets in grid boxes with no cloud + ! mass. This code is now expanded to remove massless rain drops, ice + ! crystals, and snow flakes. + ! + ! Note: qsmall, which is a small, positive number, is used as the + ! threshold here instead of qmin, which is 0. Some numbers that are + ! supposed to have a value of 0, but don't because of numerical + ! roundoff (especially after hole filling) will have small, positive + ! values. Using qsmall as the threshold here instead of qmin allows + ! for unreasonable massless drop concentrations to be removed in + ! those scenarios. + + use micro_pumas_utils, only: qsmall + use ref_pres, only: top_lev => trop_cloud_top_lev + + implicit none + + ! Input Variables + real(r8), intent(in) :: ztodt ! model time increment + type(physics_state), intent(in) :: state ! state for columns + + ! Input/Output Variables + type(physics_ptend), intent(inout) :: ptend ! ptend for columns + + ! Local Variables + integer :: icol, k + + !----- Begin Code ----- + + ! Don't do anything if this option isn't enabled. + if ( .not. micro_do_massless_droplet_destroyer ) return + + col_loop: do icol=1, state%ncol + vert_loop: do k = top_lev, pver + ! If updated qc (after microphysics) is zero, then ensure updated nc is also zero!! + if ( state%q(icol,k,ixcldliq) + ztodt * ptend%q(icol,k,ixcldliq) < qsmall ) then + ptend%lq(ixnumliq) = .true. ! This is probably already true, but it doesn't + ! hurt to set it. + ptend%q(icol,k,ixnumliq) = -(state%q(icol,k,ixnumliq) / ztodt) + end if + if ( ixnumrain > 0 ) then + ! If updated qr (after microphysics) is zero, then ensure updated nr is also zero!! + if ( state%q(icol,k,ixrain) + ztodt * ptend%q(icol,k,ixrain) < qsmall ) then + ptend%lq(ixnumrain) = .true. ! This is probably already true, but it doesn't + ! hurt to set it. + ptend%q(icol,k,ixnumrain) = -(state%q(icol,k,ixnumrain) / ztodt) + end if + endif ! ixnumrain > 0 + ! If updated qi (after microphysics) is zero, then ensure updated ni is also zero!! + if ( state%q(icol,k,ixcldice) + ztodt * ptend%q(icol,k,ixcldice) < qsmall ) then + ptend%lq(ixnumice) = .true. ! This is probably already true, but it doesn't + ! hurt to set it. + ptend%q(icol,k,ixnumice) = -(state%q(icol,k,ixnumice) / ztodt) + end if + if ( ixnumsnow > 0 ) then + ! If updated qs (after microphysics) is zero, then ensure updated ns is also zero!! + if ( state%q(icol,k,ixsnow) + ztodt * ptend%q(icol,k,ixsnow) < qsmall ) then + ptend%lq(ixnumsnow) = .true. ! This is probably already true, but it doesn't + ! hurt to set it. + ptend%q(icol,k,ixnumsnow) = -(state%q(icol,k,ixnumsnow) / ztodt) + end if + endif ! ixnumsnow > 0 + end do vert_loop + end do col_loop + + return +end subroutine massless_droplet_destroyer + +end module micro_pumas_cam diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 new file mode 100644 index 0000000000..0a926f095f --- /dev/null +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -0,0 +1,2948 @@ +!------------------------------------------------------------------------------- +!physics data types module +!------------------------------------------------------------------------------- +module physics_types + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver + use constituents, only: pcnst, qmin, cnst_name, cnst_get_ind + use geopotential, only: geopotential_t + use physconst, only: cpliq, cpwv !+tht + use physconst, only: zvir, gravit, cpair, rair + use air_composition, only: cpairv, rairv + use phys_grid, only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use phys_control, only: waccmx_is + use shr_const_mod, only: shr_const_rwv + use spmd_utils, only: masterproc !+tht + + implicit none + private ! Make default type private to the module + +! Public types: + + public physics_state + public physics_tend + public physics_ptend + +! Public interfaces + + public physics_update + public physics_state_check ! Check state object for invalid data. + public physics_ptend_reset + public physics_ptend_init + public physics_state_set_grid + public physics_dme_adjust ! adjust dry mass and energy for change in water + public physics_state_copy ! copy a physics_state object + public physics_ptend_copy ! copy a physics_ptend object + public physics_ptend_sum ! accumulate physics_ptend objects + public physics_ptend_scale ! Multiply physics_ptend objects by a constant factor. + public physics_tend_init ! initialize a physics_tend object + + public set_state_pdry ! calculate dry air masses in state variable + public set_wet_to_dry + public set_dry_to_wet + public physics_type_alloc + + public physics_state_alloc ! allocate individual components within state + public physics_state_dealloc ! deallocate individual components within state + public physics_tend_alloc ! allocate individual components within tend + public physics_tend_dealloc ! deallocate individual components within tend + public physics_ptend_alloc ! allocate individual components within tend + public physics_ptend_dealloc ! deallocate individual components within tend + + public physics_cnst_limit ! apply limiters to constituents (waccmx) +!------------------------------------------------------------------------------- + integer, parameter, public :: phys_te_idx = 1 + integer, parameter, public :: dyn_te_idx = 2 + + integer, parameter, public :: num_hflx = 4 + + integer, parameter, public :: ihrain = 1 ! index for enthalpy flux associated with liquid precipitation + integer, parameter, public :: ihsnow = 2 ! index for enthalpy flux associated with frozen precipiation + integer, parameter, public :: ifrain = 3 ! index for flux of liquid precipitation + integer, parameter, public :: ifsnow = 4 ! index for flux of frozen precipitation + + type physics_state + integer :: & + lchnk, &! chunk index + ngrdcol, &! -- Grid -- number of active columns (on the grid) + psetcols=0, &! -- -- max number of columns set - if subcols = pcols*psubcols, else = pcols + ncol=0 ! -- -- sum of nsubcol for all ngrdcols - number of active columns + real(r8), dimension(:), allocatable :: & + lat, &! latitude (radians) + lon, &! longitude (radians) + ps, &! surface pressure + psdry, &! dry surface pressure + phis, &! surface geopotential + ulat, &! unique latitudes (radians) + ulon ! unique longitudes (radians) + real(r8), dimension(:,:),allocatable :: & + t, &! temperature (K) + u, &! zonal wind (m/s) + v, &! meridional wind (m/s) + s, &! dry static energy + omega, &! vertical pressure velocity (Pa/s) + pmid, &! midpoint pressure (Pa) + pmiddry, &! midpoint pressure dry (Pa) + pdel, &! layer thickness (Pa) + pdeldry, &! layer thickness dry (Pa) + rpdel, &! reciprocal of layer thickness (Pa) + rpdeldry,&! recipricol layer thickness dry (Pa) + lnpmid, &! ln(pmid) + lnpmiddry,&! log midpoint pressure dry (Pa) + exner, &! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp) + zm ! geopotential height above surface at midpoints (m) + + real(r8), dimension(:,:,:),allocatable :: & + q ! constituent mixing ratio (kg/kg moist or dry air depending on type) + + real(r8), dimension(:,:),allocatable :: & + pint, &! interface pressure (Pa) + pintdry, &! interface pressure dry (Pa) + lnpint, &! ln(pint) + lnpintdry,&! log interface pressure dry (Pa) + zi ! geopotential height above surface at interfaces (m) + + real(r8), dimension(:,:),allocatable :: & + ! Second dimension is (phys_te_idx) CAM physics total energy and + ! (dyn_te_idx) dycore total energy computed in physics + te_ini, &! vertically integrated total (kinetic + static) energy of initial state + te_cur ! vertically integrated total (kinetic + static) energy of current state + real(r8), dimension(: ),allocatable :: & + tw_ini, &! vertically integrated total water of initial state + tw_cur ! vertically integrated total water of new state + ! + ! Array for enthalpy flux calculations + ! + real(r8), dimension(:,:),allocatable :: & + hflx_ac ! enthalpy flux variables after coupler + real(r8), dimension(:,:),allocatable :: & + hflx_bc ! enthalpy flux variables before coupler + real(r8), dimension(:,:),allocatable :: & + temp_ini, &! Temperature of initial state (used for energy computations) + z_ini ! Height of initial state (used for energy computations) + integer :: count ! count of values with significant energy or water imbalances + integer, dimension(:),allocatable :: & + latmapback, &! map from column to unique lat for that column + lonmapback, &! map from column to unique lon for that column + cid ! unique column id + integer :: ulatcnt, &! number of unique lats in chunk + uloncnt ! number of unique lons in chunk + + end type physics_state + +!------------------------------------------------------------------------------- + type physics_tend + + integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols + + real(r8), dimension(:,:),allocatable :: dtdt, dudt, dvdt ,s_dme, qt_dme !+tht s_dme, qt_dme + real(r8), dimension(:), allocatable :: flx_net + real(r8), dimension(:), allocatable :: & + te_tnd, &! cumulative boundary flux of total energy + te_sen, &! cumulative sensible heat flux + ! te_lat, &! cumulative latent heat flux + tw_tnd ! cumulative boundary flux of total water + end type physics_tend + +!------------------------------------------------------------------------------- +! This is for tendencies returned from individual parameterizations + type physics_ptend + + integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols + + character*24 :: name ! name of parameterization which produced tendencies. + + logical :: & + ls = .false., &! true if dsdt is returned + lu = .false., &! true if dudt is returned + lv = .false. ! true if dvdt is returned + + logical,dimension(pcnst) :: lq = .false. ! true if dqdt() is returned + + integer :: & + top_level, &! top level index for which nonzero tendencies have been set + bot_level ! bottom level index for which nonzero tendencies have been set + + real(r8), dimension(:,:),allocatable :: & + s, &! heating rate (J/kg/s) + u, &! u momentum tendency (m/s/s) + v ! v momentum tendency (m/s/s) + real(r8), dimension(:,:,:),allocatable :: & + q ! consituent tendencies (kg/kg/s) + +! boundary fluxes + real(r8), dimension(:),allocatable ::& + hflux_srf, &! net heat flux at surface (W/m2) + hflux_top, &! net heat flux at top of model (W/m2) + taux_srf, &! net zonal stress at surface (Pa) + taux_top, &! net zonal stress at top of model (Pa) + tauy_srf, &! net meridional stress at surface (Pa) + tauy_top ! net meridional stress at top of model (Pa) + real(r8), dimension(:,:),allocatable ::& + cflx_srf, &! constituent flux at surface (kg/m2/s) + cflx_top ! constituent flux top of model (kg/m2/s) + + end type physics_ptend + +!+tht (should perhaps be put in namelist) + logical :: levels_are_moist=.true. + ! 5 possibilities (-> = currently reccommended): + ! 1) conserve_dycore=.false., conserve_physics=.false. (no conservation = current CAM) + ! 2) conserve_dycore=.true., bndry_flx_surface=.true. (full conservation, bad climatology) + ! -> 3) conserve_dycore=.true., bndry_flx_local=.true. (requires fixer to match correct surface fluxes) + ! 4) conserve_physics=.true., bndry_flx_local=.true. (as 3., plus fixer for atmo energy) + ! 5) conserve_physics=.true., bndry_flx_surface=.true. (no advantage wrt option 2) + ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its + ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. + logical, parameter :: conserve_dycore =.true. & + ,bndry_flx_surface=.true. + !,bndry_flx_surface=.true. + logical, parameter :: conserve_physics =(.not.conserve_dycore).and..true. & + ,bndry_flx_local = .not.bndry_flx_surface +!-tht + +!=============================================================================== +contains +!=============================================================================== + subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcols) + implicit none + type(physics_state), pointer :: phys_state(:) + type(physics_tend), pointer :: phys_tend(:) + integer, intent(in) :: begchunk, endchunk + integer, intent(in) :: psetcols + + integer :: ierr=0, lchnk + + allocate(phys_state(begchunk:endchunk), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'physics_types: phys_state allocation error = ',ierr + call endrun('physics_types: failed to allocate physics_state array') + end if + + do lchnk=begchunk,endchunk + call physics_state_alloc(phys_state(lchnk),lchnk,pcols) + end do + + allocate(phys_tend(begchunk:endchunk), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'physics_types: phys_tend allocation error = ',ierr + call endrun('physics_types: failed to allocate physics_tend array') + end if + + do lchnk=begchunk,endchunk + call physics_tend_alloc(phys_tend(lchnk),phys_state(lchnk)%psetcols) + end do + + end subroutine physics_type_alloc +!=============================================================================== + subroutine physics_update(state, ptend, dt, tend ) ! tht +!----------------------------------------------------------------------- +! Update the state and or tendency structure with the parameterization tendencies +!----------------------------------------------------------------------- + use scamMod, only: scm_crm_mode, single_column + use phys_control, only: phys_getopts + use cam_thermo, only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X) + use cam_thermo, only: get_conserved_energy,inv_conserved_energy !+tht + use air_composition, only: dry_air_species_num + use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx + use air_composition, only: compute_enthalpy_flux + use qneg_module , only: qneg3 + +!------------------------------Arguments-------------------------------- + type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies + + type(physics_state), intent(inout) :: state ! Physics state variables + + real(r8), intent(in) :: dt ! time step + + type(physics_tend ), intent(inout), optional :: tend ! Physics tendencies over timestep + ! tend is usually only needed by calls from physpkg. +! +!---------------------------Local storage------------------------------- + integer :: k,m ! column,level,constituent indices + integer :: ixcldice, ixcldliq ! indices for CLDICE and CLDLIQ + integer :: ixnumice, ixnumliq + integer :: ixnumsnow, ixnumrain + integer :: ncol ! number of columns + integer :: ixh, ixh2 ! constituent indices for H, H2 + logical :: derive_new_geopotential ! derive new geopotential fields? + + real(r8) :: te(state%psetcols,pver),t_tmp(state%psetcols,pver),pdel(state%psetcols,pver) !+tht + + real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer + + real(r8),allocatable :: cpairv_loc(:,:) + real(r8),allocatable :: rairv_loc(:,:) + + ! PERGRO limits cldliq/ice for macro/microphysics: + character(len=24), parameter :: pergro_cldlim_names(4) = & + (/ "stratiform", "cldwat ", "micro_mg ", "macro_park" /) + + ! cldliq/ice limits that are always on. + character(len=24), parameter :: cldlim_names(2) = & + (/ "convect_deep", "zm_conv_tend" /) + + ! Whether to do validation of state on each call. + logical :: state_debug_checks + + !----------------------------------------------------------------------- + + ! The column radiation model does not update the state + if(single_column.and.scm_crm_mode) return + + + !----------------------------------------------------------------------- + ! If no fields are set, then return + if (.not. (any(ptend%lq(:)) .or. ptend%ls .or. ptend%lu .or. ptend%lv)) then + ptend%name = "none" + ptend%psetcols = 0 + return + end if + + !----------------------------------------------------------------------- + ! Check that the state/tend/ptend are all dimensioned with the same number of columns + if (state%psetcols /= ptend%psetcols) then + call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) & + //': state and ptend must have the same number of psetcols.') + end if + + if (present(tend)) then + if (state%psetcols /= tend%psetcols) then + call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) & + //': state and tend must have the same number of psetcols.') + end if + end if + + + !----------------------------------------------------------------------- + call phys_getopts(state_debug_checks_out=state_debug_checks) + + ncol = state%ncol + + ! Update u,v fields + if(ptend%lu) then + do k = ptend%top_level, ptend%bot_level + state%u (:ncol,k) = state%u (:ncol,k) + ptend%u(:ncol,k) * dt + if (present(tend)) & + tend%dudt(:ncol,k) = tend%dudt(:ncol,k) + ptend%u(:ncol,k) + end do + end if + + if(ptend%lv) then + do k = ptend%top_level, ptend%bot_level + state%v (:ncol,k) = state%v (:ncol,k) + ptend%v(:ncol,k) * dt + if (present(tend)) & + tend%dvdt(:ncol,k) = tend%dvdt(:ncol,k) + ptend%v(:ncol,k) + end do + end if + + ! Update constituents, all schemes use time split q: no tendency kept + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + ! Check for number concentration of cloud liquid and cloud ice (if not present + ! the indices will be set to -1) + call cnst_get_ind('NUMICE', ixnumice, abort=.false.) + call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) + call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) + call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) + + do m = 1, pcnst + if(ptend%lq(m)) then + do k = ptend%top_level, ptend%bot_level + state%q(:ncol,k,m) = state%q(:ncol,k,m) + ptend%q(:ncol,k,m) * dt + end do + + ! now test for mixing ratios which are too small + ! don't call qneg3 for number concentration variables + if (m /= ixnumice .and. m /= ixnumliq .and. & + m /= ixnumrain .and. m /= ixnumsnow ) then + call qneg3(trim(ptend%name), state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m)) + else + do k = ptend%top_level, ptend%bot_level + ! checks for number concentration + state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m)) + state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m)) + end do + end if + + end if + + end do + + !------------------------------------------------------------------------ + ! This is a temporary fix for the large H, H2 in WACCM-X + ! Well, it was supposed to be temporary, but it has been here + ! for a while now. + !------------------------------------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call cnst_get_ind('H', ixh) + do k = ptend%top_level, ptend%bot_level + state%q(:ncol,k,ixh) = min(state%q(:ncol,k,ixh), 0.01_r8) + end do + + call cnst_get_ind('H2', ixh2) + do k = ptend%top_level, ptend%bot_level + state%q(:ncol,k,ixh2) = min(state%q(:ncol,k,ixh2), 6.e-5_r8) + end do + endif + + ! Special tests for cloud liquid and ice: + ! Enforce a minimum non-zero value. + if (ixcldliq > 1) then + if(ptend%lq(ixcldliq)) then +#ifdef PERGRO + if ( any(ptend%name == pergro_cldlim_names) ) & + call state_cnst_min_nz(1.e-12_r8, ixcldliq, ixnumliq) +#endif + if ( any(ptend%name == cldlim_names) ) & + call state_cnst_min_nz(1.e-36_r8, ixcldliq, ixnumliq) + end if + end if + + if (ixcldice > 1) then + if(ptend%lq(ixcldice)) then +#ifdef PERGRO + if ( any(ptend%name == pergro_cldlim_names) ) & + call state_cnst_min_nz(1.e-12_r8, ixcldice, ixnumice) +#endif + if ( any(ptend%name == cldlim_names) ) & + call state_cnst_min_nz(1.e-36_r8, ixcldice, ixnumice) + end if + end if + + !------------------------------------------------------------------------ + ! Get indices for molecular weights and call WACCM-X cam_thermo_update + !------------------------------------------------------------------------ + if (dry_air_species_num>0) then + call cam_thermo_dry_air_update(state%q, state%t, state%lchnk, state%ncol) + endif + + !----------------------------------------------------------------------- + ! cpairv_loc and rairv_loc need to be allocated to a size which matches state and ptend + ! If psetcols == pcols, the cpairv is the correct size and just copy + ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair + allocate(cpairv_loc(state%psetcols,pver)) + if (state%psetcols == pcols) then + cpairv_loc(:,:) = cpairv(:,:,state%lchnk) + else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then + cpairv_loc(:,:) = cpair + else + call endrun('physics_update: cpairv is not allowed to vary when subcolumns are turned on') + end if + allocate(rairv_loc(state%psetcols,pver)) + if (state%psetcols == pcols) then + rairv_loc(:,:) = rairv(:,:,state%lchnk) + else if (state%psetcols > pcols .and. all(rairv(:,:,:) == rair)) then + rairv_loc(:,:) = rair + else + call endrun('physics_update: rairv_loc is not allowed to vary when subcolumns are turned on') + end if + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv_loc(:,:) - 1._r8 + else + zvirv(:,:) = zvir + endif + + !------------------------------------------------------------------------------------------------------------- + ! Update temperature from dry static energy (moved from above for WACCM-X so updating after cpairv_loc update) + !------------------------------------------------------------------------------------------------------------- + if(ptend%ls) then +!+tht + if(compute_enthalpy_flux) then + !use conserved energy + call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & + , cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & + , pdel(:ncol,:), te(:ncol,:)) + te(:ncol,ptend%top_level:ptend%bot_level)=te(:ncol,ptend%top_level:ptend%bot_level) & + +ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt + call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & + , te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & + , pdel(:ncol,:), t_tmp(:ncol,:)) + if (present(tend)) & + tend%dtdt(:ncol,ptend%top_level:ptend%bot_level)=tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & + (T_tmp(:ncol,ptend%top_level:ptend%bot_level) & + -state%t(:ncol,ptend%top_level:ptend%bot_level))/dt + state%T(:ncol,ptend%top_level:ptend%bot_level)=T_tmp(:ncol,ptend%top_level:ptend%bot_level) + else + do k = ptend%top_level, ptend%bot_level + state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) + if (present(tend)) & + tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) + end do + endif +!-tht + end if + + ! Derive new geopotential fields if heating or water tendency not 0. + derive_new_geopotential = .false. + if(ptend%ls) then + ! Heating tendency not 0 + derive_new_geopotential = .true. + else + ! Check all water species and if there are nonzero tendencies + const_water_loop: do m = dry_air_species_num + 1, thermodynamic_active_species_num + if(ptend%lq(thermodynamic_active_species_idx(m))) then + ! does water species have tendency? + derive_new_geopotential = .true. + exit const_water_loop + endif + enddo const_water_loop + endif + + if (derive_new_geopotential) then + call geopotential_t ( & + state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & + state%t , state%q(:,:,:), rairv_loc(:,:), gravit , zvirv , & + state%zi , state%zm , ncol ) + ! update dry static energy for use in next process + do k = ptend%top_level, ptend%bot_level + state%s(:ncol,k) = state%t(:ncol,k)*cpairv_loc(:ncol,k) & + + gravit*state%zm(:ncol,k) + state%phis(:ncol) + end do + end if + + if (state_debug_checks) call physics_state_check(state, ptend%name) + + deallocate(cpairv_loc, rairv_loc) + + ! Deallocate ptend + call physics_ptend_dealloc(ptend) + + ptend%name = "none" + ptend%lq(:) = .false. + ptend%ls = .false. + ptend%lu = .false. + ptend%lv = .false. + ptend%psetcols = 0 + + contains + + subroutine state_cnst_min_nz(lim, qix, numix) + ! Small utility function for setting minimum nonzero + ! constituent concentrations. + + ! Lower limit and constituent index + real(r8), intent(in) :: lim + integer, intent(in) :: qix + ! Number concentration that goes with qix. + ! Ignored if <= 0 (and therefore constituent is not present). + integer, intent(in) :: numix + + if (numix > 0) then + ! Where q is too small, zero mass and number + ! concentration. + where (state%q(:ncol,:,qix) < lim) + state%q(:ncol,:,qix) = 0._r8 + state%q(:ncol,:,numix) = 0._r8 + end where + else + ! If no number index, just do mass. + where (state%q(:ncol,:,qix) < lim) + state%q(:ncol,:,qix) = 0._r8 + end where + end if + + end subroutine state_cnst_min_nz + + + end subroutine physics_update + +!=============================================================================== + + subroutine physics_state_check(state, name) +!----------------------------------------------------------------------- +! Check a physics_state object for invalid data (e.g NaNs, negative +! temperatures). +!----------------------------------------------------------------------- + use shr_infnan_mod, only: assignment(=), & + shr_infnan_posinf, shr_infnan_neginf + use shr_assert_mod, only: shr_assert_in_domain + use constituents, only: pcnst + +!------------------------------Arguments-------------------------------- + ! State to check. + type(physics_state), intent(in) :: state + ! Name of the package responsible for this state. + character(len=*), intent(in), optional :: name + +!---------------------------Local storage------------------------------- + ! Shortened name for ncol. + integer :: ncol + ! Double precision positive/negative infinity. + real(r8) :: posinf_r8, neginf_r8 + ! Canned message. + character(len=64) :: msg + ! Constituent index + integer :: m + +!----------------------------------------------------------------------- + + ncol = state%ncol + + posinf_r8 = shr_infnan_posinf + neginf_r8 = shr_infnan_neginf + + ! It may be reasonable to check some of the integer components of the + ! state as well, but this is not yet implemented. + + ! Check for NaN first to avoid any IEEE exceptions. + + if (present(name)) then + msg = "NaN produced in physics_state by package "// & + trim(name)//"." + else + msg = "NaN found in physics_state." + end if + + ! 1-D variables + call shr_assert_in_domain(state%ps(:ncol), is_nan=.false., & + varname="state%ps", msg=msg) + call shr_assert_in_domain(state%psdry(:ncol), is_nan=.false., & + varname="state%psdry", msg=msg) + call shr_assert_in_domain(state%phis(:ncol), is_nan=.false., & + varname="state%phis", msg=msg) + call shr_assert_in_domain(state%te_ini(:ncol,:), is_nan=.false., & + varname="state%te_ini", msg=msg) + call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., & + varname="state%te_cur", msg=msg) + !xxx make allocation dependent on if energy budget history is turned on + call shr_assert_in_domain(state%hflx_ac(:ncol,num_hflx), is_nan=.false., & + varname="state%hflx_ac", msg=msg) + call shr_assert_in_domain(state%hflx_bc(:ncol,num_hflx), is_nan=.false., & + varname="state%hflx_bc", msg=msg) + call shr_assert_in_domain(state%tw_ini(:ncol ), is_nan=.false., & + varname="state%tw_ini", msg=msg) + call shr_assert_in_domain(state%tw_cur(:ncol ), is_nan=.false., & + varname="state%tw_cur", msg=msg) + call shr_assert_in_domain(state%temp_ini(:ncol,:), is_nan=.false., & + varname="state%temp_ini", msg=msg) + call shr_assert_in_domain(state%z_ini(:ncol,:), is_nan=.false., & + varname="state%z_ini", msg=msg) + + ! 2-D variables (at midpoints) + call shr_assert_in_domain(state%t(:ncol,:), is_nan=.false., & + varname="state%t", msg=msg) + call shr_assert_in_domain(state%u(:ncol,:), is_nan=.false., & + varname="state%u", msg=msg) + call shr_assert_in_domain(state%v(:ncol,:), is_nan=.false., & + varname="state%v", msg=msg) + call shr_assert_in_domain(state%s(:ncol,:), is_nan=.false., & + varname="state%s", msg=msg) + call shr_assert_in_domain(state%omega(:ncol,:), is_nan=.false., & + varname="state%omega", msg=msg) + call shr_assert_in_domain(state%pmid(:ncol,:), is_nan=.false., & + varname="state%pmid", msg=msg) + call shr_assert_in_domain(state%pmiddry(:ncol,:), is_nan=.false., & + varname="state%pmiddry", msg=msg) + call shr_assert_in_domain(state%pdel(:ncol,:), is_nan=.false., & + varname="state%pdel", msg=msg) + call shr_assert_in_domain(state%pdeldry(:ncol,:), is_nan=.false., & + varname="state%pdeldry", msg=msg) + call shr_assert_in_domain(state%rpdel(:ncol,:), is_nan=.false., & + varname="state%rpdel", msg=msg) + call shr_assert_in_domain(state%rpdeldry(:ncol,:), is_nan=.false., & + varname="state%rpdeldry", msg=msg) + call shr_assert_in_domain(state%lnpmid(:ncol,:), is_nan=.false., & + varname="state%lnpmid", msg=msg) + call shr_assert_in_domain(state%lnpmiddry(:ncol,:), is_nan=.false., & + varname="state%lnpmiddry", msg=msg) + call shr_assert_in_domain(state%exner(:ncol,:), is_nan=.false., & + varname="state%exner", msg=msg) + call shr_assert_in_domain(state%zm(:ncol,:), is_nan=.false., & + varname="state%zm", msg=msg) + + ! 2-D variables (at interfaces) + call shr_assert_in_domain(state%pint(:ncol,:), is_nan=.false., & + varname="state%pint", msg=msg) + call shr_assert_in_domain(state%pintdry(:ncol,:), is_nan=.false., & + varname="state%pintdry", msg=msg) + call shr_assert_in_domain(state%lnpint(:ncol,:), is_nan=.false., & + varname="state%lnpint", msg=msg) + call shr_assert_in_domain(state%lnpintdry(:ncol,:), is_nan=.false., & + varname="state%lnpintdry", msg=msg) + call shr_assert_in_domain(state%zi(:ncol,:), is_nan=.false., & + varname="state%zi", msg=msg) + + ! 3-D variables + call shr_assert_in_domain(state%q(:ncol,:,:), is_nan=.false., & + varname="state%q", msg=msg) + + ! Now run other checks (i.e. values are finite and within a range that + ! is physically meaningful). + + if (present(name)) then + msg = "Invalid value produced in physics_state by package "// & + trim(name)//"." + else + msg = "Invalid value found in physics_state." + end if + + ! 1-D variables + call shr_assert_in_domain(state%ps(:ncol), lt=posinf_r8, gt=0._r8, & + varname="state%ps", msg=msg) + call shr_assert_in_domain(state%psdry(:ncol), lt=posinf_r8, gt=0._r8, & + varname="state%psdry", msg=msg) + call shr_assert_in_domain(state%phis(:ncol), lt=posinf_r8, gt=neginf_r8, & + varname="state%phis", msg=msg) + call shr_assert_in_domain(state%te_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%te_ini", msg=msg) + call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%te_cur", msg=msg) + call shr_assert_in_domain(state%hflx_ac(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & + varname="state%hflx_ac", msg=msg) + call shr_assert_in_domain(state%hflx_bc(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & + varname="state%hflx_bc", msg=msg) + call shr_assert_in_domain(state%tw_ini(:ncol ), lt=posinf_r8, gt=neginf_r8, & + varname="state%tw_ini", msg=msg) + call shr_assert_in_domain(state%tw_cur(:ncol ), lt=posinf_r8, gt=neginf_r8, & + varname="state%tw_cur", msg=msg) + call shr_assert_in_domain(state%temp_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%temp_ini", msg=msg) + call shr_assert_in_domain(state%z_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%z_ini", msg=msg) + + ! 2-D variables (at midpoints) + call shr_assert_in_domain(state%t(:ncol,:), lt=posinf_r8, gt=0._r8, & + varname="state%t", msg=msg) + call shr_assert_in_domain(state%u(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%u", msg=msg) + call shr_assert_in_domain(state%v(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%v", msg=msg) + call shr_assert_in_domain(state%s(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%s", msg=msg) + call shr_assert_in_domain(state%omega(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%omega", msg=msg) + call shr_assert_in_domain(state%pmid(:ncol,:), lt=posinf_r8, gt=0._r8, & + varname="state%pmid", msg=msg) + call shr_assert_in_domain(state%pmiddry(:ncol,:), lt=posinf_r8, gt=0._r8, & + varname="state%pmiddry", msg=msg) + call shr_assert_in_domain(state%pdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%pdel", msg=msg) + call shr_assert_in_domain(state%pdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%pdeldry", msg=msg) + call shr_assert_in_domain(state%rpdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%rpdel", msg=msg) + call shr_assert_in_domain(state%rpdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%rpdeldry", msg=msg) + call shr_assert_in_domain(state%lnpmid(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%lnpmid", msg=msg) + call shr_assert_in_domain(state%lnpmiddry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%lnpmiddry", msg=msg) + call shr_assert_in_domain(state%exner(:ncol,:), lt=posinf_r8, gt=0._r8, & + varname="state%exner", msg=msg) + call shr_assert_in_domain(state%zm(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%zm", msg=msg) + + ! 2-D variables (at interfaces) + call shr_assert_in_domain(state%pint(:ncol,:), lt=posinf_r8, gt=0._r8, & + varname="state%pint", msg=msg) + call shr_assert_in_domain(state%pintdry(:ncol,:), lt=posinf_r8, gt=0._r8, & + varname="state%pintdry", msg=msg) + call shr_assert_in_domain(state%lnpint(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%lnpint", msg=msg) + call shr_assert_in_domain(state%lnpintdry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%lnpintdry", msg=msg) + call shr_assert_in_domain(state%zi(:ncol,:), lt=posinf_r8, gt=neginf_r8, & + varname="state%zi", msg=msg) + + ! 3-D variables + do m = 1,pcnst + call shr_assert_in_domain(state%q(:ncol,:,m), lt=posinf_r8, gt=neginf_r8, & + varname="state%q ("//trim(cnst_name(m))//")", msg=msg) + end do + + end subroutine physics_state_check + +!=============================================================================== + + subroutine physics_ptend_sum(ptend, ptend_sum, ncol) +!----------------------------------------------------------------------- +! Add ptend fields to ptend_sum for ptend logical flags = .true. +! Where ptend logical flags = .false, don't change ptend_sum +!----------------------------------------------------------------------- + +!------------------------------Arguments-------------------------------- + type(physics_ptend), intent(in) :: ptend ! New parameterization tendencies + type(physics_ptend), intent(inout) :: ptend_sum ! Sum of incoming ptend_sum and ptend + integer, intent(in) :: ncol ! number of columns + +!---------------------------Local storage------------------------------- + integer :: i,k,m ! column,level,constituent indices + integer :: psetcols ! maximum number of columns + integer :: ierr = 0 + +!----------------------------------------------------------------------- + if (ptend%psetcols /= ptend_sum%psetcols) then + call endrun('physics_ptend_sum error: ptend and ptend_sum must have the same value for psetcols') + end if + + if (ncol > ptend_sum%psetcols) then + call endrun('physics_ptend_sum error: ncol must be less than or equal to psetcols') + end if + + psetcols = ptend_sum%psetcols + + ptend_sum%top_level = ptend%top_level + ptend_sum%bot_level = ptend%bot_level + +! Update u,v fields + if(ptend%lu) then + if (.not. allocated(ptend_sum%u)) then + allocate(ptend_sum%u(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%u') + ptend_sum%u=0.0_r8 + + allocate(ptend_sum%taux_srf(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_srf') + ptend_sum%taux_srf=0.0_r8 + + allocate(ptend_sum%taux_top(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_top') + ptend_sum%taux_top=0.0_r8 + end if + ptend_sum%lu = .true. + + do k = ptend%top_level, ptend%bot_level + do i = 1, ncol + ptend_sum%u(i,k) = ptend_sum%u(i,k) + ptend%u(i,k) + end do + end do + do i = 1, ncol + ptend_sum%taux_srf(i) = ptend_sum%taux_srf(i) + ptend%taux_srf(i) + ptend_sum%taux_top(i) = ptend_sum%taux_top(i) + ptend%taux_top(i) + end do + end if + + if(ptend%lv) then + if (.not. allocated(ptend_sum%v)) then + allocate(ptend_sum%v(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%v') + ptend_sum%v=0.0_r8 + + allocate(ptend_sum%tauy_srf(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_srf') + ptend_sum%tauy_srf=0.0_r8 + + allocate(ptend_sum%tauy_top(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_top') + ptend_sum%tauy_top=0.0_r8 + end if + ptend_sum%lv = .true. + + do k = ptend%top_level, ptend%bot_level + do i = 1, ncol + ptend_sum%v(i,k) = ptend_sum%v(i,k) + ptend%v(i,k) + end do + end do + do i = 1, ncol + ptend_sum%tauy_srf(i) = ptend_sum%tauy_srf(i) + ptend%tauy_srf(i) + ptend_sum%tauy_top(i) = ptend_sum%tauy_top(i) + ptend%tauy_top(i) + end do + end if + + + if(ptend%ls) then + if (.not. allocated(ptend_sum%s)) then + allocate(ptend_sum%s(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%s') + ptend_sum%s=0.0_r8 + + allocate(ptend_sum%hflux_srf(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_srf') + ptend_sum%hflux_srf=0.0_r8 + + allocate(ptend_sum%hflux_top(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_top') + ptend_sum%hflux_top=0.0_r8 + end if + ptend_sum%ls = .true. + + do k = ptend%top_level, ptend%bot_level + do i = 1, ncol + ptend_sum%s(i,k) = ptend_sum%s(i,k) + ptend%s(i,k) + end do + end do + do i = 1, ncol + ptend_sum%hflux_srf(i) = ptend_sum%hflux_srf(i) + ptend%hflux_srf(i) + ptend_sum%hflux_top(i) = ptend_sum%hflux_top(i) + ptend%hflux_top(i) + end do + end if + + if (any(ptend%lq(:))) then + + if (.not. allocated(ptend_sum%q)) then + allocate(ptend_sum%q(psetcols,pver,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%q') + ptend_sum%q=0.0_r8 + + allocate(ptend_sum%cflx_srf(psetcols,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_srf') + ptend_sum%cflx_srf=0.0_r8 + + allocate(ptend_sum%cflx_top(psetcols,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_top') + ptend_sum%cflx_top=0.0_r8 + end if + + do m = 1, pcnst + if(ptend%lq(m)) then + ptend_sum%lq(m) = .true. + do k = ptend%top_level, ptend%bot_level + do i = 1,ncol + ptend_sum%q(i,k,m) = ptend_sum%q(i,k,m) + ptend%q(i,k,m) + end do + end do + do i = 1,ncol + ptend_sum%cflx_srf(i,m) = ptend_sum%cflx_srf(i,m) + ptend%cflx_srf(i,m) + ptend_sum%cflx_top(i,m) = ptend_sum%cflx_top(i,m) + ptend%cflx_top(i,m) + end do + end if + end do + + end if + + end subroutine physics_ptend_sum + +!=============================================================================== + + subroutine physics_ptend_scale(ptend, fac, ncol) +!----------------------------------------------------------------------- +! Scale ptend fields for ptend logical flags = .true. +! Where ptend logical flags = .false, don't change ptend. +! +! Assumes that input ptend is valid (e.g. that +! ptend%lu .eqv. allocated(ptend%u)), and therefore +! does not check allocation status of individual arrays. +!----------------------------------------------------------------------- + +!------------------------------Arguments-------------------------------- + type(physics_ptend), intent(inout) :: ptend ! Incoming ptend + real(r8), intent(in) :: fac ! Factor to multiply ptend by. + integer, intent(in) :: ncol ! number of columns + +!---------------------------Local storage------------------------------- + integer :: m ! constituent index + +!----------------------------------------------------------------------- + +! Update u,v fields + if (ptend%lu) & + call multiply_tendency(ptend%u, & + ptend%taux_srf, ptend%taux_top) + + if (ptend%lv) & + call multiply_tendency(ptend%v, & + ptend%tauy_srf, ptend%tauy_top) + +! Heat + if (ptend%ls) & + call multiply_tendency(ptend%s, & + ptend%hflux_srf, ptend%hflux_top) + +! Update constituents + do m = 1, pcnst + if (ptend%lq(m)) & + call multiply_tendency(ptend%q(:,:,m), & + ptend%cflx_srf(:,m), ptend%cflx_top(:,m)) + end do + + + contains + + subroutine multiply_tendency(tend_arr, flx_srf, flx_top) + real(r8), intent(inout) :: tend_arr(:,:) ! Tendency array (pcols, plev) + real(r8), intent(inout) :: flx_srf(:) ! Surface flux (or stress) + real(r8), intent(inout) :: flx_top(:) ! Top-of-model flux (or stress) + + integer :: k + + do k = ptend%top_level, ptend%bot_level + tend_arr(:ncol,k) = tend_arr(:ncol,k) * fac + end do + flx_srf(:ncol) = flx_srf(:ncol) * fac + flx_top(:ncol) = flx_top(:ncol) * fac + + end subroutine multiply_tendency + + end subroutine physics_ptend_scale + +!=============================================================================== + +subroutine physics_ptend_copy(ptend, ptend_cp) + + !----------------------------------------------------------------------- + ! Copy a physics_ptend object. Allocate ptend_cp internally before copy. + !----------------------------------------------------------------------- + + type(physics_ptend), intent(in) :: ptend ! ptend source + type(physics_ptend), intent(out) :: ptend_cp ! copy of ptend + + !----------------------------------------------------------------------- + + ptend_cp%name = ptend%name + + ptend_cp%ls = ptend%ls + ptend_cp%lu = ptend%lu + ptend_cp%lv = ptend%lv + ptend_cp%lq = ptend%lq + + call physics_ptend_alloc(ptend_cp, ptend%psetcols) + + ptend_cp%top_level = ptend%top_level + ptend_cp%bot_level = ptend%bot_level + + if (ptend_cp%ls) then + ptend_cp%s = ptend%s + ptend_cp%hflux_srf = ptend%hflux_srf + ptend_cp%hflux_top = ptend%hflux_top + end if + + if (ptend_cp%lu) then + ptend_cp%u = ptend%u + ptend_cp%taux_srf = ptend%taux_srf + ptend_cp%taux_top = ptend%taux_top + end if + + if (ptend_cp%lv) then + ptend_cp%v = ptend%v + ptend_cp%tauy_srf = ptend%tauy_srf + ptend_cp%tauy_top = ptend%tauy_top + end if + + if (any(ptend_cp%lq(:))) then + ptend_cp%q = ptend%q + ptend_cp%cflx_srf = ptend%cflx_srf + ptend_cp%cflx_top = ptend%cflx_top + end if + +end subroutine physics_ptend_copy + +!=============================================================================== + + subroutine physics_ptend_reset(ptend) +!----------------------------------------------------------------------- +! Reset the parameterization tendency structure to "empty" +!----------------------------------------------------------------------- + +!------------------------------Arguments-------------------------------- + type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies +!----------------------------------------------------------------------- + + if(ptend%ls) then + ptend%s = 0._r8 + ptend%hflux_srf = 0._r8 + ptend%hflux_top = 0._r8 + endif + if(ptend%lu) then + ptend%u = 0._r8 + ptend%taux_srf = 0._r8 + ptend%taux_top = 0._r8 + endif + if(ptend%lv) then + ptend%v = 0._r8 + ptend%tauy_srf = 0._r8 + ptend%tauy_top = 0._r8 + endif + if(any (ptend%lq(:))) then + ptend%q = 0._r8 + ptend%cflx_srf = 0._r8 + ptend%cflx_top = 0._r8 + end if + + ptend%top_level = 1 + ptend%bot_level = pver + + return + end subroutine physics_ptend_reset + +!=============================================================================== + subroutine physics_ptend_init(ptend, psetcols, name, ls, lu, lv, lq) +!----------------------------------------------------------------------- +! Allocate the fields in the structure which are specified. +! Initialize the parameterization tendency structure to "empty" +!----------------------------------------------------------------------- + +!------------------------------Arguments-------------------------------- + type(physics_ptend), intent(out) :: ptend ! Parameterization tendencies + integer, intent(in) :: psetcols ! maximum number of columns + character(len=*) :: name ! optional name of parameterization which produced tendencies. + logical, optional :: ls ! if true, then fields to support dsdt are allocated + logical, optional :: lu ! if true, then fields to support dudt are allocated + logical, optional :: lv ! if true, then fields to support dvdt are allocated + logical, dimension(pcnst),optional :: lq ! if true, then fields to support dqdt are allocated + +!----------------------------------------------------------------------- + + if (allocated(ptend%s)) then + call endrun(' physics_ptend_init: ptend should not be allocated before calling this routine') + end if + + ptend%name = name + ptend%psetcols = psetcols + + ! If no fields being stored, initialize all values to appropriate nulls and return + if (.not. present(ls) .and. .not. present(lu) .and. .not. present(lv) .and. .not. present(lq) ) then + ptend%ls = .false. + ptend%lu = .false. + ptend%lv = .false. + ptend%lq(:) = .false. + ptend%top_level = 1 + ptend%bot_level = pver + return + end if + + if (present(ls)) then + ptend%ls = ls + else + ptend%ls = .false. + end if + + if (present(lu)) then + ptend%lu = lu + else + ptend%lu = .false. + end if + + if (present(lv)) then + ptend%lv = lv + else + ptend%lv = .false. + end if + + if (present(lq)) then + ptend%lq(:) = lq(:) + else + ptend%lq(:) = .false. + end if + + call physics_ptend_alloc(ptend, psetcols) + + call physics_ptend_reset(ptend) + + return + end subroutine physics_ptend_init + +!=============================================================================== + + subroutine physics_state_set_grid(lchnk, phys_state) +!----------------------------------------------------------------------- +! Set the grid components of the physics_state object +!----------------------------------------------------------------------- + + integer, intent(in) :: lchnk + type(physics_state), intent(inout) :: phys_state + + ! local variables + integer :: i, ncol + real(r8) :: rlon(pcols) + real(r8) :: rlat(pcols) + + !----------------------------------------------------------------------- + ! get_ncols_p requires a state which does not have sub-columns + if (phys_state%psetcols .ne. pcols) then + call endrun('physics_state_set_grid: cannot pass in a state which has sub-columns') + end if + + ncol = get_ncols_p(lchnk) + + if(ncol<=0) then + write(iulog,*) lchnk, ncol + call endrun('physics_state_set_grid') + end if + + call get_rlon_all_p(lchnk, ncol, rlon) + call get_rlat_all_p(lchnk, ncol, rlat) + phys_state%ncol = ncol + phys_state%lchnk = lchnk + do i=1,ncol + phys_state%lat(i) = rlat(i) + phys_state%lon(i) = rlon(i) + end do + call init_geo_unique(phys_state,ncol) + + end subroutine physics_state_set_grid + + + subroutine init_geo_unique(phys_state,ncol) + integer, intent(in) :: ncol + type(physics_state), intent(inout) :: phys_state + logical :: match + integer :: i, j, ulatcnt, uloncnt + + phys_state%ulat=-999._r8 + phys_state%ulon=-999._r8 + phys_state%latmapback=0 + phys_state%lonmapback=0 + match=.false. + ulatcnt=0 + uloncnt=0 + match=.false. + do i=1,ncol + do j=1,ulatcnt + if(phys_state%lat(i) .eq. phys_state%ulat(j)) then + match=.true. + phys_state%latmapback(i)=j + end if + end do + if(.not. match) then + ulatcnt=ulatcnt+1 + phys_state%ulat(ulatcnt)=phys_state%lat(i) + phys_state%latmapback(i)=ulatcnt + end if + + match=.false. + do j=1,uloncnt + if(phys_state%lon(i) .eq. phys_state%ulon(j)) then + match=.true. + phys_state%lonmapback(i)=j + end if + end do + if(.not. match) then + uloncnt=uloncnt+1 + phys_state%ulon(uloncnt)=phys_state%lon(i) + phys_state%lonmapback(i)=uloncnt + end if + match=.false. + + end do + phys_state%uloncnt=uloncnt + phys_state%ulatcnt=ulatcnt + + call get_gcol_all_p(phys_state%lchnk,pcols,phys_state%cid) + + + end subroutine init_geo_unique + +!=============================================================================== + subroutine physics_cnst_limit(state) + type(physics_state), intent(inout) :: state + + integer :: i,k, ncol + + real(r8) :: mmrSum_O_O2_H ! Sum of mass mixing ratios for O, O2, and H + real(r8), parameter :: mmrMin=1.e-20_r8 ! lower limit of o2, o, and h mixing ratios + real(r8), parameter :: N2mmrMin=1.e-6_r8 ! lower limit of N2 mass mixing ratio + real(r8), parameter :: H2lim=6.e-5_r8 ! H2 limiter: 10x global H2 MMR (Roble, 1995) + integer :: ixo, ixo2, ixh, ixh2 + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call cnst_get_ind('O', ixo) + call cnst_get_ind('O2', ixo2) + call cnst_get_ind('H', ixh) + call cnst_get_ind('H2', ixh2) + + ncol = state%ncol + + !------------------------------------------------------------ + ! Ensure N2 = 1-(O2 + O + H) mmr is greater than 0 + ! Check for unusually large H2 values and set to lower value. + !------------------------------------------------------------ + + do k=1,pver + do i=1,ncol + + if (state%q(i,k,ixo) < mmrMin) state%q(i,k,ixo) = mmrMin + if (state%q(i,k,ixo2) < mmrMin) state%q(i,k,ixo2) = mmrMin + + mmrSum_O_O2_H = state%q(i,k,ixo)+state%q(i,k,ixo2)+state%q(i,k,ixh) + + if ((1._r8-mmrMin-mmrSum_O_O2_H) < 0._r8) then + + state%q(i,k,ixo) = state%q(i,k,ixo) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H + + state%q(i,k,ixo2) = state%q(i,k,ixo2) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H + + state%q(i,k,ixh) = state%q(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H + + endif + + if(state%q(i,k,ixh2) > H2lim) then + state%q(i,k,ixh2) = H2lim + endif + + end do + end do + + end if + end subroutine physics_cnst_limit + +!=============================================================================== +!+tht: gatekeeper module to control options for dme adjustment + subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt & + , dme_energy_adjust , step & + , ntrnprd, ntsnprd & + , tevap, tprec & + , mflx, eflx & + , eflx_out & + , mflx_out & + , ent_tnd, pdel_rf & + , dycore_is_hydrostatic) + +!use phys_control, only: phys_getopts +! 25.06.14 Added new formulation of Thomas Toniazzo (Bjerknes Centre / NORCE) +! obligate args + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in ) :: dt +! optional args + logical , optional, intent(in ) :: dme_energy_adjust + character(len=*),optional,intent(in)::step !which call in physpkg + real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer + real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer + real(r8), intent(in) , optional :: tevap (pcols) ! temperature of surface evaporation + real(r8), intent(in) , optional :: tprec (pcols) ! temperature of surface precipitation + real(r8), intent(in) , optional :: mflx (pcols) ! mass flux for use in check_energy + real(r8), intent(in) , optional :: eflx (pcols) ! energy flux for use in check_energy + real(r8), intent(out), optional :: ent_tnd (pcols) ! column-integrated enthalpy tendency + real(r8), intent(out), optional :: pdel_rf (pcols,pver)! ratio old pdel / new pdel + logical , intent(in) , optional :: dycore_is_hydrostatic + + real(r8), intent(out), optional :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out), optional :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) +! local work space + integer :: ncol,icol + !real(r8) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8) :: tevp (pcols) ! temperature for surface evaporation + real(r8) :: tprc (pcols) ! temperature for precipitation at surface + real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" + real(r8) :: mdq (pcols,pver) ! total water tendency + logical :: hydrostatic =.true. + real(r8), parameter :: rtiny = 1e-04_r8 ! a small number (relative to total q change) + + + if(present(dycore_is_hydrostatic)) hydrostatic =dycore_is_hydrostatic + + if (present(dme_energy_adjust)) then + if (dme_energy_adjust) then + + if(present(tevap))then + tevp=tevap + else + tevp(:ncol)=state%t(:ncol,pver) + endif + if(present(tprec))then + tprc=tprec + else + tprc(:ncol)=state%t(:ncol,pver) + endif + + if (present(ntrnprd).and.present(ntsnprd)) then ! use physics (ZM+MG) precip production rates + if (present(eflx).and.present(mflx)) then ! also correct to match prescribed surface enthalpy flux + call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & + , htx_cond, mdq, step & + , ntrnprd=ntrnprd, ntsnprd=ntsnprd & + , mflx=mflx, eflx=eflx & + , eflx_out=eflx_out, mflx_out=mflx_out) + else + call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & + , htx_cond, mdq, step & + , ntrnprd=ntrnprd, ntsnprd=ntsnprd & + , eflx_out=eflx_out , mflx_out=mflx_out) + endif + else + call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & + , htx_cond, mdq, step & + , eflx_out=eflx_out, mflx_out=mflx_out) + endif + call physics_dme_adjust_THT(state, tend, dt & + , qini, liqini, iceini, htx_cond, mdq, step & + , ent_tnd=ent_tnd , pdel_rf=pdel_rf & + , hydrostatic=hydrostatic) + else + if (present(ent_tnd)) ent_tnd (:)=0._r8 + call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) + end if + + else + if (present(ent_tnd)) ent_tnd (:)=0._r8 + call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) + end if + + end subroutine physics_dme_adjust +!-tht +!+tht dme_energy_adjust code: +!----------------------------------------------------------------------- + subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq & + , step , eflx_out , mflx_out & + , ntrnprd, ntsnprd & + , mflx, eflx) + + use air_composition, only: dry_air_species_num & + ,thermodynamic_active_species_idx & + ,thermodynamic_active_species_liq_idx & + ,thermodynamic_active_species_ice_idx & + ,thermodynamic_active_species_num & + ,thermodynamic_active_species_liq_num & + ,thermodynamic_active_species_ice_num & + ,cpairv, cp_or_cv_dycore + use constituents, only: cnst_get_type_byind, cnst_get_ind + use physconst, only: cpair, cpwv, cpliq, cpice, tmelt + use air_composition, only: t00a, h00a + use hycoef, only: hyai, hybi, ps0, hyam, hybm + use cam_thermo, only: inv_conserved_energy, get_conserved_energy & + ,cam_thermo_water_update + use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure + + !----------------------------------------------------------------------- + ! + ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to + ! atmospheric moisture change + ! + ! Method + ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) + ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, + ! CONDEPS, and a matching heat exchange betweeen air and condensated + ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). + ! Choice 2. is taken with dme_ ohf_adjust=.true. For CONDEPS then the following + ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS + ! cpcond is a parameter representing the heat capacity of the condensate phase. + ! The heating rates and enthalpy boundary fluxes are not applied here, + ! they are intended to be passed to dme_adjust. + ! + ! Author: Thomas Toniazzo (17.07.21) + ! + !----------------------------------------------------------------------- + + implicit none + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in ) :: tevp (pcols) ! temperature of evaporation at bottom of atmo + real(r8), intent(in ) :: tprc (pcols) ! temperature of precipitation at bottom of atmo + real(r8), intent(in ) :: dt ! model physics timestep + real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust + real(r8), intent(out ) :: mdq (pcols,pver) ! total water increment for dme_adjust + character(len=*),optional,intent(in)::step !which call in physpkg + real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer + real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer + real(r8), intent(in) , optional :: eflx (pcols) ! input : boundary enthalpy flux + real(r8), intent(in) , optional :: mflx (pcols) ! input : boundary mass flux + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k,m, ixq ! Longitude, level indices + integer :: ierr ! error flag + + real(r8) :: fdq (pcols) ! mass adjustment factor + + real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values + + real(r8) :: dcvap(pcols) ! total column vapour change + real(r8) :: dcliq(pcols) ! total column liquid change + real(r8) :: dcice(pcols) ! total column ice change + real(r8) :: dcwat(pcols) ! total column water change + real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) + + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + + real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) + real(r8) :: tot_water_chg(pcols) ! work array: total water change + integer :: m_cnst + + real(r8) :: ps_old(pcols) ! old surface pressure + + real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) + real(r8) :: dvap (pcols,pver) ! wv mass adjustment + real(r8) :: dliq (pcols,pver) ! liq mass adjustment + real(r8) :: dice (pcols,pver) ! ice mass adjustment + real(r8) :: dprat (pcols) ! Dp'/Dp'' (=1 in lagrangean adj) + + real(r8) :: mdqr (pcols,pver) ! residual mass change (work array) + real(r8) :: dcqm (pcols) ! fraction of total/absolute mass change + + real(r8) :: te (pcols,pver) ! conserved energy in layer + real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm (pcols,pver) ! (phi-phis)/g + real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) + real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes + real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes + real(r8) :: condmox_ref(pcols,pver) ! local specific x-momentum of "condensates" (mass source) + real(r8) :: condmox (pcols,pver) ! specific x-momentum of moist reservoir with which q is exchanged + real(r8) :: condmoy_ref(pcols,pver) ! local specific y-momentum of "condensates" (mass source) + real(r8) :: condmoy (pcols,pver) ! specific y-momentum of moist reservoir with which q is exchanged + + real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp + + real(r8) :: uf(pcols), vf(pcols) ! work arrays + + real(r8) :: pint_old(pcols,pver+1)! work array + !real(r8) :: tbot(pcols) ! work array + real(r8) :: dummy(pcols,pver) ! work array + + integer :: is_invalid(pcols) + logical , parameter :: conserve = conserve_dycore .or. conserve_physics + real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) + +! set to T to use distribute implied heating over column section to the surface + logical, parameter :: l_nolocdcpttend=.true. + + logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_bflx: cannot pass in a state which has sub-columns') + end if + + lchnk = state%lchnk + ncol = state%ncol + + ! store old pressure + ps_old (:ncol) = state%ps(:ncol) + pint_old(:ncol,:) = state%pint(:ncol,:) + + zm(:ncol,:)=state%zm(:ncol,:) + + ! get local specific enthalpy, excluding latent heats + if (conserve_dycore) then + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cp_or_cv_dycore(:ncol,:,lchnk) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,te(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & + ,vcoord=vc_dycore ,refstate='liq' & + ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + else + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cpairv(:ncol,:,lchnk) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,te(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & + ,refstate='liq' & + ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + endif + + call cnst_get_ind('Q', ixq) + ! change in water + dcvap(:ncol)=0._r8 + dcliq(:ncol)=0._r8 + dcice(:ncol)=0._r8 + dcwat(:ncol)=0._r8 + ! heat associated with cp change + do k = 1, pver + ! mass increments Dp'/Dp + tot_water(:ncol,1) = qini(:ncol,k)+liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O + tot_water(:ncol,2) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) + end do + mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) + + dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) + dliq(:ncol,k) = -liqini(:ncol,k) + do m_cnst=1,thermodynamic_active_species_liq_num + m = thermodynamic_active_species_liq_idx(m_cnst) + dliq(:ncol,k) = dliq(:ncol,k)+state%q(:ncol,k,m) + end do + dice(:ncol,k) = -iceini(:ncol,k) + do m_cnst=1,thermodynamic_active_species_ice_num + m = thermodynamic_active_species_ice_idx(m_cnst) + dice(:ncol,k) = dice(:ncol,k)+state%q(:ncol,k,m) + end do + + dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state%pdel(:ncol,k)/gravit + dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state%pdel(:ncol,k)/gravit + dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state%pdel(:ncol,k)/gravit + dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state%pdel(:ncol,k)/gravit + + end do + + is_invalid(:ncol)=0 + if (present(mflx)) then + if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then + k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) + if (masterproc.and.logorrhoic) & ! for testing + print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) + endif + where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) + is_invalid(:ncol)=1 + endwhere + if (maxval(is_invalid(:ncol)).gt.0) then + k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) + if (abs(eflx(k)).gt.rtiny) then + if (masterproc.and.logorrhoic) & ! for testing + print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) + endif + endif + endif + + ! local specific enthalpy + if (conserve) then + do k = 1, pver + condeps_ref(:ncol,k) = te(:ncol,k) +emce(:ncol,k) + enddo + else + condeps_ref(:ncol,:) = 0._r8 + endif + + ! exchange specific enthalpies, incremental + if (conserve .and. present(ntrnprd) .and. present(ntsnprd)) then ! we can partition between source and destination + dcwatr (:ncol) = 0._r8 + do k=1,pver + mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change + if (conserve_physics.or..not.l_nolocdcpttend) then + condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) + else if (conserve_dycore) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice + condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq (:ncol,k) + condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) + endif + if (bndry_flx_surface) then + condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) + condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state%phis(:ncol)+(cpliq*t00a+h00a)) + else if (bndry_flx_local) then + if (conserve_dycore) then + condepsf(:ncol,k) =-(cpliq*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) + condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(state%t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state%phis(:ncol)+(cpliq*t00a+h00a)) + else if (conserve_physics) then + condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) + condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) + endif + endif + ! residual column water change: integrates to surface evaporation + dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + enddo + else + mdqr (:ncol,:)=mdq (:ncol,:) + dcwatr (:ncol) =dcwat(:ncol) + condepsf(:ncol,:)=0._r8 + condepss(:ncol,:)=0._r8 + do k=1,pver + if (conserve_physics.or..not.l_nolocdcpttend) then + condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) + else if (conserve_dycore ) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice + condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq(:ncol,k) + condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) + endif + if (bndry_flx_surface) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice + condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state%phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) + condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) + else if (bndry_flx_local) then + condepsf(:ncol,k) = condepss(:ncol,k) + if (conserve_dycore .and.l_nolocdcpttend) & + condepsf(:ncol,k) = condepsf(:ncol,k)+((cpliq-cpair)*t00a+h00a)*mdq(:ncol,k) + endif + enddo + endif + + + if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match + ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR + eflx_out(:ncol ) = eflx(:ncol)*dt + do k = 1, pver + where(is_invalid(:ncol).eq.0) + eflx_out(:ncol) = eflx_out(:ncol) - state%pdel(:ncol,k)/gravit*condepsf(:ncol,k) + elsewhere + eflx_out(:ncol) = 0._r8 + endwhere + enddo + dcqm(:ncol)=0._r8 + do k=1,pver + where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) + dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + endwhere + enddo + where(abs(dcwatr(:ncol)).gt.rtiny) + dcqm(:ncol)=dcwatr(:ncol)/dcqm(:ncol) + elsewhere + dcqm(:ncol)=0._r8 + endwhere + do k=1,pver + where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) + condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) + endwhere + where(is_invalid(:ncol).eq.1) + condepsf(:ncol,k) = 0._r8 + endwhere + enddo + endif + + ! boundary flux of energy due to mass sources (diagnostic) + mflx_out(:ncol ) = 0._r8 + do k = 1, pver + where( is_invalid(:ncol).eq.0) + ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) + mflx_out(:ncol) = mflx_out(:ncol) + state%pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt + endwhere + enddo + + ! boundary flux of energy due to mass sources (diagnostic) + eflx_out(:ncol ) = 0._r8 + do k = 1, pver + where( is_invalid(:ncol).eq.0) + ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) + eflx_out(:ncol) = eflx_out(:ncol) + state%pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt + endwhere + enddo + + ! make local specific enthalpy incremental + if (conserve) then + do k = 1, pver + condeps_ref(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) + enddo + endif + + ! new surface pressure + state%ps(:ncol) = state%pint(:ncol,1) + do k = 1, pver + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + end do + + ! heat exchange with condensates + htx_cond(:ncol,:) = 0._r8 + do k = 1, pver + do i=1,ncol + if(l_nolocdcpttend)then + ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below + if(k.eq.1) then + condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & + *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) + else + condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & + *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & + +condepsf(i,k-1) + endif + else + condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) + endif + htx_cond(i,k) = condepsf(i,k) & + ! diff. between LOCAL enthalpy and reference enthalpy is applied locally + +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) + enddo + + pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + + ! compute new total pressure variables + state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) + + end do + + ! original pressure + state%ps (:ncol) = ps_old (:ncol) + state%pint(:ncol,:) = pint_old(:ncol,:) + + end subroutine physics_dme_bflx + +!----------------------------------------------------------------------- + + subroutine physics_dme_adjust_THT(state, tend, dt & +,qini,liqini,iceini & + , htx_cond , mdq, step & + , ent_tnd, pdel_rf & + , hydrostatic ) + + use air_composition, only: dry_air_species_num,thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx & + ,cpairv, cp_or_cv_dycore + use constituents, only: cnst_get_type_byind, cnst_get_ind, cnst_type + use hycoef, only: hyai, hybi, ps0, hyam, hybm + use cam_thermo, only: inv_conserved_energy, get_conserved_energy & + ,cam_thermo_water_update + use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure, vc_physics + use qneg_module, only: qneg3 + use dycore, only: dycore_is ! might be rm'd when code is cleaned up + use cam_history, only: outfld + + !----------------------------------------------------------------------- + ! + ! Purpose: Adjust the dry mass in each layer back to the value of physics input state + ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. + ! + ! Method + ! Revised adjustment towards consistency with local energy conservation. + ! Hydrostatic pressure work, de = alpha * dp, where alpha is the specific volume + ! pressure adjustment, is added locally as an source of enthalpy. An enthalpy of + ! mass (water) exchange with the surface is also defined, which should be passed + ! to the surface model components (ocean/land/ice etc). + ! If moist thermodynamics where handled correctly in CAM, the two terms would + ! match, guaranteeing local energy conservation. + ! With the present CAM formulation (constant dry heat capacity, constant latent + ! heat of condensation valid for 0 degree C), consistency demands one of these + ! choices: + ! 1. no pressure work and no boundary enthalpy flux (CESM) + ! 2. correct local pressure work and boundary enthalpy flux equal to (S dp/g) + ! where S=local *dry* static energy of air + ! The boundary enthalpy flux is at present not passed to other model components, + ! so it is treated as internal CAM non-conservation and folded into fix_energy. + ! + ! Author: Thomas Toniazzo (17.07.21) + ! + !----------------------------------------------------------------------- + + + implicit none + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: dt ! model physics timestep + real(r8), intent(in) :: htx_cond(pcols,pver)! exchange heating with q's leaving/entering column + real(r8), intent(in) :: mdq (pcols,pver) ! mass adjustment + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + character(len=*),optional,intent(in)::step !which call in physpkg + real(r8), intent(out), optional :: ent_tnd (pcols) ! diagnostic: column-integrated enthalpy tendency + real(r8), intent(out), optional :: pdel_rf (pcols,pver)! diagnostic: ratio old pdel / new pdel + logical , intent(in) , optional :: hydrostatic ! flag to set energy function to hydrostatic + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k,m ! Longitude, level indices + integer :: ierr ! error flag + + real(r8) :: fdq (pcols) ! mass adjustment factor + + real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values + + real(r8) :: te (pcols,pver) ! conserved energy in layer + real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm (pcols,pver) ! (phi-phis)/g + + real(r8) :: cpm (pcols,pver) ! moist air heat capacity + real(r8) :: ttsc (pcols,pver) ! moist air heat capacity + integer :: vcoord + + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + + real(r8) :: tot_water (pcols ) ! total water (initial, present) + real(r8) :: tot_water_chg(pcols) ! total water change + integer :: m_cnst + + real(r8) :: ps_old(pcols) ! old surface pressure + + real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) + + real(r8) :: pdot (pcols) ! total (lagrangian) pressure adjustment + real(r8) :: pdzp (pcols) ! pressure work term in press adjustment + real(r8) :: edot (pcols) ! advective pressure adjustment + + real(r8) :: uf(pcols), vf(pcols) ! work arrays + + real(r8) :: tp(pcols,pver) ! work array for T/Tv + real(r8) :: latent(pcols,pver) ! work array for Lq + + integer :: ixnumice, ixnumliq + integer :: ixnumsnow, ixnumrain + + call cnst_get_ind('NUMICE', ixnumice, abort=.false.) + call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) + call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) + call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') + end if + +!-------------------- initialise adjustment loop ------------------------------------ + lchnk = state%lchnk + ncol = state%ncol + + ! old surface pressure + ps_old (:ncol) = state%ps(:ncol) + state%ps(:ncol) = state%pint(:ncol,1) + + zm(:ncol,:)=state%zm(:ncol,:) + + if (conserve_dycore) then + vcoord=vc_dycore + cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) + else + vcoord=vc_physics + cpm(:ncol,:)=cpairv(:ncol,:,lchnk) + endif + + do k = 1, pver + tp(:ncol,k) = state%t(:ncol,k) + enddo + + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cpm(:ncol,:) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,state%s(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:),rairv=rairv(:ncol,:,lchnk) & + ,vcoord=vcoord ,refstate='liq' & + ,flatent=latent(:ncol,:),temce=emce(:ncol,:)) + + do k = 1, pver + ! Dp'/Dp + tot_water(:ncol) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + enddo + ! new surface pressure + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + ! make all tracers wet + do m=1,pcnst + if (cnst_type(m).eq.'dry') & + state%q(:ncol,k,m) = state%q(:ncol,k,m)*(1._r8-tot_water(:ncol)) + enddo + enddo + + ! lagrangian & advective pressure change at top interface + pdot (:ncol) = 0._r8 + pdzp (:ncol) = 0._r8 + edot (:ncol) = 0._r8 + + ! store old enthalpy integral + if (present(ent_tnd)) then + ent_tnd(:ncol)=0._r8 + do k=1,pver + ent_tnd(:ncol) = ent_tnd(:ncol) - state%pdel(:ncol,k)*state%s(:ncol,k) + enddo + endif + +!------------------- start adjustment loop ------------------------------------------ + do k = 1, pver + + ! new Dp (=:Dp") + pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + + fdq(:ncol) = pdel_new(:ncol,k)/state%pdel(:ncol,k) ! this is Dp"/Dp + + ! wind adjustment increments + uf (:ncol) = 0. + vf (:ncol) = 0. + + ! u,vtmp set to pre-physics u,v from the updated values and the tendencies + utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) + vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) + + ! adjust specific enthalpy + te (:ncol,k) = 0._r8 + + ! lagrangian pressure change *zi at upper interfac + pdzp(:ncol) = pdot(:ncol)*gravit*state%zi(:ncol,k) + ! lagrangian pressure change at next interface + if(hydrostatic)pdot(:ncol) = pdot(:ncol) + state%pdel(:ncol,k)*mdq(:ncol,k) + ! layer increment = work (~alpha*dp) + pdzp(:ncol) = (pdot(:ncol)*gravit*state%zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) + + ! enthalpy change due to mass loss and to hydrost. pressure work in full adjustment + te(:ncol,k) = te(:ncol,k) & + + state%s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") + + emce(:ncol,k)*mdq(:ncol,k)/fdq(:ncol) & ! (phi-phis)*dq*(Dp/Dp") + - pdzp(:ncol) & ! del(g*zm*dp) + + htx_cond(:ncol,k) ! EFLX + ! momentum + uf(:ncol) = uf(:ncol) +state%u(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) + vf(:ncol) = vf(:ncol) +state%v(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) + + ! adjust constituents to conserve mass in each layer + do m = 1, pcnst + ! store unadjusted q for use in next k + state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) + end do + ! adjust L-dependent part of local total enthalpy accordingly + latent(:ncol,k) = latent(:ncol,k)/fdq(:ncol) + + ! adjusted u,v tendencies + tend%dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt + tend%dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt + ! store unadjusted u,v for use in next k + utmp(:ncol) = state%u(:ncol,k) + vtmp(:ncol) = state%v(:ncol,k) + ! write adjusted u,v + state%u(:ncol,k) = uf(:ncol) + state%v(:ncol,k) = vf(:ncol) + + ! compute new total pressure variables + state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) + state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) + ! also update pmid for geopotential + state%pmid (:ncol,k ) = .5_r8*(state%pint(:ncol,k)+state%pint(:ncol,k+1)) + state%lnpmid(:ncol,k ) = log(state%pmid(:ncol,k )) + + if(present(pdel_rf)) pdel_rf(:ncol,k)=state%pdel(:ncol,k)/pdel_new(:ncol,k) + state%pdel (:ncol,k ) = pdel_new(:ncol,k) + state%rpdel (:ncol,k ) = 1._r8/state%pdel(:ncol,k) + + end do +!------------------- end adjustment loop -------------------------------------------- + + ! make dry tracers dry again + do k = 1, pver + tot_water(:ncol) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + enddo + do m=1,pcnst + if (cnst_type(m).eq.'dry') & + state%q(:ncol,k,m) = state%q(:ncol,k,m)/(1._r8-tot_water(:ncol)) + enddo + enddo + + !call QNEG3 (cf physics_update) + do m = 1, pcnst + if (m /= ixnumice .and. m /= ixnumliq .and. & + m /= ixnumrain .and. m /= ixnumsnow ) then + call qneg3('dme_adjust', state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m)) + else + do k = 1,pver + state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m)) + state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m)) + end do + end if + enddo + + if (conserve_dycore) then + call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore, & + to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + ttsc(:ncol,:)=cpm(:ncol,:)/cp_or_cv_dycore(:ncol,:,lchnk) + cpm (:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) + endif + call inv_conserved_energy(levels_are_moist & + ,1 ,pver & + ,te(:ncol,:) & + ,cpm(:ncol,:) & + ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,tp(:ncol,:) & + ,flatent=latent(:ncol,:)*0._r8 & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,vcoord=vcoord ,refstate='liq' & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:)) + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 + else + zvirv(:,:) = zvir + endif + + ! diagnostics: dme T tendency + ttsc(:ncol,:) =(tp(:ncol,:) - state%t(:ncol,:))/dt ! & + ! for tests: correct for effect of cp update on other physics ttend + ! -tend%dtdt(:ncol,:)*(ttsc(:ncol,:)-1._r8) + call outfld('PTTEND_DME', ttsc, pcols, lchnk) + + ! update ttend and T (cf physics_update) + tend%dtdt(:ncol,:) = tend%dtdt(:ncol,:) & + +(tp(:ncol,:) - state%t(:ncol,:))/dt + state%t (:ncol,:) = tp(:ncol,:) + + ! diagnose total internal enthalpy change + if (present(ent_tnd)) then + do k=1,pver + ent_tnd(:ncol) = ent_tnd(:ncol) + state%pdel(:ncol,k)*te(:ncol,k) + enddo + ent_tnd(:ncol) = ent_tnd(:ncol)/dt/gravit + endif + call geopotential_t ( & + state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & + state%t , state%q(:,:,:), rairv(:,:,state%lchnk), gravit , zvirv , & + state%zi , state%zm , ncol ) + + ! update original dry static energy + do k = 1, pver + state%s(:ncol,k) = state%t(:ncol,k )*cpairv(:ncol,k,lchnk) & + + gravit*state%zm(:ncol,k) + state%phis(:ncol) + enddo + + end subroutine physics_dme_adjust_THT +!----------------------------------------------------------------------- +!-tht :edoc tsujda_ygrene_emd +!=============================================================================== + !tht: _BAB version, violates energy now just the same as it did 22 years ago + subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) + use air_composition, only: dry_air_species_num,thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx + use dycore, only: dycore_is + use dme_adjust, only: dme_adjust_run + use ccpp_constituent_prop_mod, only: ccpp_const_props + !----------------------------------------------------------------------- + ! + ! Purpose: Adjust the dry mass in each layer back to the value of physics input state + ! + ! Method: Conserve the integrated mass, momentum and total energy in each layer + ! by scaling the specific mass of consituents, specific momentum (velocity) + ! and specific total energy by the relative change in layer mass. Solve for + ! the new temperature by subtracting the new kinetic energy from total energy + ! and inverting the hydrostatic equation + ! + ! The mass in each layer is modified, changing the relationship of the layer + ! interfaces and midpoints to the surface pressure. The result is no longer in + ! the original hybrid coordinate. + ! + ! Author: Byron Boville + + ! !REVISION HISTORY: + ! 03.03.28 Boville Created, partly from code by Lin in p_d_adjust + ! + !----------------------------------------------------------------------- + + implicit none + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in ) :: dt ! model physics timestep + ! + !---------------------------Local workspace----------------------------- + ! + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: k,m ! Longitude, level indices + real(r8) :: fdq(pcols) ! mass adjustment factor + real(r8) :: te(pcols) ! total energy in a layer + + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + + real(r8) :: tot_water (pcols,2) ! total water (initial, present) + real(r8) :: tot_water_chg(pcols) ! total water change + + + real(r8),allocatable :: cpairv_loc(:,:) + integer :: m_cnst + + logical :: is_dycore_moist + + character(len=512) :: errmsg + integer :: errflg + + ! + !----------------------------------------------------------------------- + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') + end if + + lchnk = state%lchnk + ncol = state%ncol + + ! + ! original code for backwards compatability with FV and EUL + ! + if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then + do k = 1, pver + !tht: removed heavily misleading comment + state%ps(:ncol) = state%pint(:ncol,1) + + ! adjustment factor is just change in water vapor + fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k) + + ! adjust constituents to conserve mass in each layer + do m = 1, pcnst + state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) + end do + ! compute new total pressure variables + state%pdel (:ncol,k ) = state%pdel(:ncol,k ) * fdq(:ncol) + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k) + state%pint (:ncol,k+1) = state%pint(:ncol,k ) + state%pdel(:ncol,k) + state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) + state%rpdel (:ncol,k ) = 1._r8/ state%pdel(:ncol,k ) + end do + else + is_dycore_moist = .true. + call dme_adjust_run (state%ncol, pver, pcnst, state%ps(:ncol), state%pint(:ncol,:), state%pdel(:ncol,:), & + state%lnpint(:ncol,:), state%rpdel(:ncol,:), & + ccpp_const_props, state%q(:ncol,:,:), qini(:ncol,:), liqini(:ncol,:), iceini(:ncol,:), & + is_dycore_moist, errmsg, errflg) + if (errflg /= 0) then + call endrun('physics_dme_adjust: '//errmsg) + end if + endif + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 + else + zvirv(:,:) = zvir + endif + + end subroutine physics_dme_adjust_BAB !tht :BAB +!=============================================================================== + + subroutine physics_state_copy(state_in, state_out) + + use ppgrid, only: pver, pverp + use constituents, only: pcnst + + implicit none + + ! + ! Arguments + ! + type(physics_state), intent(in) :: state_in + type(physics_state), intent(out) :: state_out + + ! + ! Local variables + ! + integer i, k, m, ncol + + ! Allocate state_out with same subcol dimension as state_in + call physics_state_alloc ( state_out, state_in%lchnk, state_in%psetcols) + + ncol = state_in%ncol + + state_out%psetcols = state_in%psetcols + state_out%ngrdcol = state_in%ngrdcol + state_out%lchnk = state_in%lchnk + state_out%ncol = state_in%ncol + state_out%count = state_in%count + + do i = 1, ncol + state_out%lat(i) = state_in%lat(i) + state_out%lon(i) = state_in%lon(i) + state_out%ps(i) = state_in%ps(i) + state_out%phis(i) = state_in%phis(i) + end do + state_out%te_ini (:ncol,:) = state_in%te_ini (:ncol,:) + state_out%te_cur (:ncol,:) = state_in%te_cur (:ncol,:) + state_out%hflx_ac(:ncol,:) = state_in%hflx_ac(:ncol,:) + state_out%hflx_bc(:ncol,:) = state_in%hflx_bc(:ncol,:) + state_out%tw_ini (:ncol ) = state_in%tw_ini (:ncol ) + state_out%tw_cur (:ncol ) = state_in%tw_cur (:ncol ) + + do k = 1, pver + do i = 1, ncol + state_out%temp_ini(i,k) = state_in%temp_ini(i,k) + state_out%z_ini(i,k) = state_in%z_ini(i,k) + state_out%t(i,k) = state_in%t(i,k) + state_out%u(i,k) = state_in%u(i,k) + state_out%v(i,k) = state_in%v(i,k) + state_out%s(i,k) = state_in%s(i,k) + state_out%omega(i,k) = state_in%omega(i,k) + state_out%pmid(i,k) = state_in%pmid(i,k) + state_out%pdel(i,k) = state_in%pdel(i,k) + state_out%rpdel(i,k) = state_in%rpdel(i,k) + state_out%lnpmid(i,k) = state_in%lnpmid(i,k) + state_out%exner(i,k) = state_in%exner(i,k) + state_out%zm(i,k) = state_in%zm(i,k) + end do + end do + + do k = 1, pverp + do i = 1, ncol + state_out%pint(i,k) = state_in%pint(i,k) + state_out%lnpint(i,k) = state_in%lnpint(i,k) + state_out%zi(i,k) = state_in% zi(i,k) + end do + end do + + + do i = 1, ncol + state_out%psdry(i) = state_in%psdry(i) + end do + do k = 1, pver + do i = 1, ncol + state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k) + state_out%pmiddry(i,k) = state_in%pmiddry(i,k) + state_out%pdeldry(i,k) = state_in%pdeldry(i,k) + state_out%rpdeldry(i,k) = state_in%rpdeldry(i,k) + end do + end do + do k = 1, pverp + do i = 1, ncol + state_out%pintdry(i,k) = state_in%pintdry(i,k) + state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k) + end do + end do + + do m = 1, pcnst + do k = 1, pver + do i = 1, ncol + state_out%q(i,k,m) = state_in%q(i,k,m) + end do + end do + end do + + end subroutine physics_state_copy +!=============================================================================== + + subroutine physics_tend_init(tend) + + implicit none + + ! + ! Arguments + ! + type(physics_tend), intent(inout) :: tend + + ! + ! Local variables + ! + + if (.not. allocated(tend%dtdt)) then + call endrun('physics_tend_init: tend must be allocated before it can be initialized') + end if + + tend%s_dme = 0._r8!+tht + tend%qt_dme = 0._r8!+tht + tend%dtdt = 0._r8 + tend%dudt = 0._r8 + tend%dvdt = 0._r8 + tend%flx_net = 0._r8 + tend%te_tnd = 0._r8 + tend%te_sen = 0._r8 + !tend%te_lat = 0._r8 + tend%tw_tnd = 0._r8 + +end subroutine physics_tend_init + +!=============================================================================== +! this routine only considers wv as not massless (FV and EUL) +subroutine set_state_pdry (state,pdeld_calc) + + use ppgrid, only: pver + use air_composition, only: dry_air_species_num,thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx + implicit none + + type(physics_state), intent(inout) :: state + logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default] + ! .false. don't calculate pdeld + + real(r8) :: tot_water (pcols) ! total td'ly active water + integer ncol + integer k, m, m_cnst + logical do_pdeld_calc + + if ( present(pdeld_calc) ) then + do_pdeld_calc = pdeld_calc + else + do_pdeld_calc = .true. + endif + + ncol = state%ncol + + + state%psdry(:ncol) = state%pint(:ncol,1) + state%pintdry(:ncol,1) = state%pint(:ncol,1) + + if (do_pdeld_calc) then + do k = 1, pver + tot_water(:ncol) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + end do + state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-tot_water(:ncol)) + end do + endif + + do k = 1, pver + state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k) + state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8 + state%psdry(:ncol) = state%psdry(:ncol) + state%pdeldry(:ncol,k) + end do + + state%rpdeldry(:ncol,:) = 1._r8/state%pdeldry(:ncol,:) + state%lnpmiddry(:ncol,:) = log(state%pmiddry(:ncol,:)) + state%lnpintdry(:ncol,:) = log(state%pintdry(:ncol,:)) + +end subroutine set_state_pdry + +!=============================================================================== + +subroutine set_wet_to_dry (state, convert_cnst_type) + + use constituents, only: pcnst, cnst_type + + type(physics_state), intent(inout) :: state + character(len=3), intent(in), optional :: convert_cnst_type + character(len=3) :: convert_type + + integer m, ncol + +if (present(convert_cnst_type)) then + convert_type=convert_cnst_type +else + convert_type='dry' +endif + + ncol = state%ncol + + do m = 1,pcnst + if (cnst_type(m).eq.convert_type) then + state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:) + endif + end do + +end subroutine set_wet_to_dry + +!=============================================================================== + +subroutine set_dry_to_wet (state, convert_cnst_type) + + use constituents, only: pcnst, cnst_type + + type(physics_state), intent(inout) :: state + character(len=3), intent(in), optional :: convert_cnst_type + character(len=3) :: convert_type + + integer m, ncol + +if (present(convert_cnst_type)) then + convert_type=convert_cnst_type +else + convert_type='dry' +endif + + ncol = state%ncol + + do m = 1,pcnst + if (cnst_type(m).eq.convert_type) then + state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:) + endif + end do + +end subroutine set_dry_to_wet + +!=============================================================================== + +subroutine physics_state_alloc(state,lchnk,psetcols) + + use infnan, only: inf, assignment(=) + +! allocate the individual state components + + type(physics_state), intent(inout) :: state + integer,intent(in) :: lchnk + + integer, intent(in) :: psetcols + + integer :: ierr=0 + + state%lchnk = lchnk + state%psetcols = psetcols + state%ngrdcol = get_ncols_p(lchnk) ! Number of grid columns + + !---------------------------------- + ! Following variables will be overwritten by sub-column generator, if sub-columns are being used + + ! state%ncol - is initialized in physics_state_set_grid, if not using sub-columns + + !---------------------------------- + + allocate(state%lat(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lat') + + allocate(state%lon(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lon') + + allocate(state%ps(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ps') + + allocate(state%psdry(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%psdry') + + allocate(state%phis(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%phis') + + allocate(state%ulat(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulat') + + allocate(state%ulon(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulon') + + allocate(state%t(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%t') + + allocate(state%u(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%u') + + allocate(state%v(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%v') + + allocate(state%s(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%s') + + allocate(state%omega(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%omega') + + allocate(state%pmid(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmid') + + allocate(state%pmiddry(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmiddry') + + allocate(state%pdel(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdel') + + allocate(state%pdeldry(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdeldry') + + allocate(state%rpdel(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdel') + + allocate(state%rpdeldry(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdeldry') + + allocate(state%lnpmid(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmid') + + allocate(state%lnpmiddry(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmiddry') + + allocate(state%exner(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%exner') + + allocate(state%zm(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zm') + + allocate(state%q(psetcols,pver,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%q') + + allocate(state%pint(psetcols,pver+1), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pint') + + allocate(state%pintdry(psetcols,pver+1), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pintdry') + + allocate(state%lnpint(psetcols,pver+1), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpint') + + allocate(state%lnpintdry(psetcols,pver+1), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpintdry') + + allocate(state%zi(psetcols,pver+1), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zi') + + allocate(state%te_ini(psetcols,2), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_ini') + + allocate(state%te_cur(psetcols,2), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur') + + allocate(state%hflx_ac(psetcols,num_hflx), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_ac') + + allocate(state%hflx_bc(psetcols,num_hflx), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_bc') + + allocate(state%tw_ini(psetcols ), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini') + + allocate(state%tw_cur(psetcols ), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur') + + allocate(state%temp_ini(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%temp_ini') + + allocate(state%z_ini(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%z_ini') + + allocate(state%latmapback(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%latmapback') + + allocate(state%lonmapback(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lonmapback') + + allocate(state%cid(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid') + + state%lat(:) = inf + state%lon(:) = inf + state%ulat(:) = inf + state%ulon(:) = inf + state%ps(:) = inf + state%psdry(:) = inf + state%phis(:) = inf + state%t(:,:) = inf + state%u(:,:) = inf + state%v(:,:) = inf + state%s(:,:) = inf + state%omega(:,:) = inf + state%pmid(:,:) = inf + state%pmiddry(:,:) = inf + state%pdel(:,:) = inf + state%pdeldry(:,:) = inf + state%rpdel(:,:) = inf + state%rpdeldry(:,:) = inf + state%lnpmid(:,:) = inf + state%lnpmiddry(:,:) = inf + state%exner(:,:) = inf + state%zm(:,:) = inf + state%q(:,:,:) = inf + + state%pint(:,:) = inf + state%pintdry(:,:) = inf + state%lnpint(:,:) = inf + state%lnpintdry(:,:) = inf + state%zi(:,:) = inf + + state%te_ini (:,:) = inf + state%te_cur (:,:) = inf + state%hflx_ac (:,:) = inf + state%hflx_bc (:,:) = inf + state%tw_ini (: ) = inf + state%tw_cur (: ) = inf + state%temp_ini(:,:) = inf + state%z_ini (:,:) = inf + +end subroutine physics_state_alloc + +!=============================================================================== + +subroutine physics_state_dealloc(state) + +! deallocate the individual state components + + type(physics_state), intent(inout) :: state + integer :: ierr = 0 + + deallocate(state%lat, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lat') + + deallocate(state%lon, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lon') + + deallocate(state%ps, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ps') + + deallocate(state%psdry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%psdry') + + deallocate(state%phis, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%phis') + + deallocate(state%ulat, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulat') + + deallocate(state%ulon, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulon') + + deallocate(state%t, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%t') + + deallocate(state%u, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%u') + + deallocate(state%v, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%v') + + deallocate(state%s, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%s') + + deallocate(state%omega, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%omega') + + deallocate(state%pmid, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmid') + + deallocate(state%pmiddry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmiddry') + + deallocate(state%pdel, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdel') + + deallocate(state%pdeldry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdeldry') + + deallocate(state%rpdel, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdel') + + deallocate(state%rpdeldry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdeldry') + + deallocate(state%lnpmid, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmid') + + deallocate(state%lnpmiddry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmiddry') + + deallocate(state%exner, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%exner') + + deallocate(state%zm, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zm') + + deallocate(state%q, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%q') + + deallocate(state%pint, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pint') + + deallocate(state%pintdry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pintdry') + + deallocate(state%lnpint, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpint') + + deallocate(state%lnpintdry, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpintdry') + + deallocate(state%zi, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zi') + + deallocate(state%te_ini, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_ini') + + deallocate(state%te_cur, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur') + + deallocate(state%hflx_ac, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_ac') + + deallocate(state%hflx_bc, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_bc') + + deallocate(state%tw_ini, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini') + + deallocate(state%tw_cur, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_cur') + + deallocate(state%temp_ini, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%temp_ini') + + deallocate(state%z_ini, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%z_ini') + + deallocate(state%latmapback, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%latmapback') + + deallocate(state%lonmapback, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback') + + deallocate(state%cid, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%cid') + +end subroutine physics_state_dealloc + +!=============================================================================== + +subroutine physics_tend_alloc(tend,psetcols) + + use infnan, only : inf, assignment(=) +! allocate the individual tend components + + type(physics_tend), intent(inout) :: tend + + integer, intent(in) :: psetcols + + integer :: ierr = 0 + + tend%psetcols = psetcols +!+tht + allocate(tend%s_dme(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%s_dme') + allocate(tend%qt_dme(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%qt_dme') +!-tht + allocate(tend%dtdt(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt') + + allocate(tend%dudt(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dudt') + + allocate(tend%dvdt(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dvdt') + + allocate(tend%flx_net(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%flx_net') + + allocate(tend%te_tnd(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_tnd') + + allocate(tend%te_sen(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_sen') + + !allocate(tend%te_lat(psetcols), stat=ierr) + !if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_lat') + + allocate(tend%tw_tnd(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd') + + tend%s_dme (:,:)= inf !+tht + tend%qt_dme(:,:)= inf !+tht + tend%dtdt(:,:) = inf + tend%dudt(:,:) = inf + tend%dvdt(:,:) = inf + tend%flx_net(:) = inf + tend%te_tnd(:) = inf + tend%te_sen(:) = inf + !tend%te_lat(:) = inf + tend%tw_tnd(:) = inf + +end subroutine physics_tend_alloc + +!=============================================================================== + +subroutine physics_tend_dealloc(tend) + +! deallocate the individual tend components + + type(physics_tend), intent(inout) :: tend + integer :: ierr = 0 +!+tht + deallocate(tend%s_dme, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%s_dme') + deallocate(tend%qt_dme, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%qt_dme') +!-tht + deallocate(tend%dtdt, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt') + + deallocate(tend%dudt, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dudt') + + deallocate(tend%dvdt, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dvdt') + + deallocate(tend%flx_net, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%flx_net') + + deallocate(tend%te_tnd, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_tnd') + + deallocate(tend%te_sen, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_sen') + + !deallocate(tend%te_lat, stat=ierr) + !if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_lat') + + deallocate(tend%tw_tnd, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%tw_tnd') +end subroutine physics_tend_dealloc + +!=============================================================================== + +subroutine physics_ptend_alloc(ptend,psetcols) + +! allocate the individual ptend components + + type(physics_ptend), intent(inout) :: ptend + + integer, intent(in) :: psetcols + + integer :: ierr = 0 + + ptend%psetcols = psetcols + + if (ptend%ls) then + allocate(ptend%s(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%s') + + allocate(ptend%hflux_srf(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_srf') + + allocate(ptend%hflux_top(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_top') + end if + + if (ptend%lu) then + allocate(ptend%u(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%u') + + allocate(ptend%taux_srf(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_srf') + + allocate(ptend%taux_top(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_top') + end if + + if (ptend%lv) then + allocate(ptend%v(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%v') + + allocate(ptend%tauy_srf(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_srf') + + allocate(ptend%tauy_top(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_top') + end if + + if (any(ptend%lq)) then + allocate(ptend%q(psetcols,pver,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%q') + + allocate(ptend%cflx_srf(psetcols,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_srf') + + allocate(ptend%cflx_top(psetcols,pcnst), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_top') + end if + +end subroutine physics_ptend_alloc + +!=============================================================================== + +subroutine physics_ptend_dealloc(ptend) + +! deallocate the individual ptend components + + type(physics_ptend), intent(inout) :: ptend + integer :: ierr = 0 + + ptend%psetcols = 0 + + if (allocated(ptend%s)) deallocate(ptend%s, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%s') + + if (allocated(ptend%hflux_srf)) deallocate(ptend%hflux_srf, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_srf') + + if (allocated(ptend%hflux_top)) deallocate(ptend%hflux_top, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_top') + + if (allocated(ptend%u)) deallocate(ptend%u, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%u') + + if (allocated(ptend%taux_srf)) deallocate(ptend%taux_srf, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_srf') + + if (allocated(ptend%taux_top)) deallocate(ptend%taux_top, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_top') + + if (allocated(ptend%v)) deallocate(ptend%v, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%v') + + if (allocated(ptend%tauy_srf)) deallocate(ptend%tauy_srf, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_srf') + + if (allocated(ptend%tauy_top)) deallocate(ptend%tauy_top, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_top') + + if (allocated(ptend%q)) deallocate(ptend%q, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%q') + + if (allocated(ptend%cflx_srf)) deallocate(ptend%cflx_srf, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_srf') + + if(allocated(ptend%cflx_top)) deallocate(ptend%cflx_top, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_top') + +end subroutine physics_ptend_dealloc + +end module physics_types diff --git a/src/physics/camnor_phys/physics/physpkg.F90 b/src/physics/camnor_phys/physics/physpkg.F90 new file mode 100644 index 0000000000..8558c01adf --- /dev/null +++ b/src/physics/camnor_phys/physics/physpkg.F90 @@ -0,0 +1,3199 @@ +module physpkg + !----------------------------------------------------------------------- + ! Purpose: + ! + ! Provides the interface to CAM physics package + ! + ! Module contains reordered physics to accomodate CLUBB + ! Modified after original physpkg module, Dec 2021, A. Herrington + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use physconst, only: latvap, latice + use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & + physics_ptend, physics_tend_init, physics_update, & + physics_type_alloc, physics_ptend_dealloc,& + physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc + use phys_grid, only: get_ncols_p + use phys_gmean, only: gmean_mass + use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols + use constituents, only: pcnst, cnst_name, cnst_get_ind + use camsrfexch, only: cam_out_t, cam_in_t + + use phys_control, only: use_hemco ! Use Harmonized Emissions Component (HEMCO) + + use cam_control_mod, only: ideal_phys, adiabatic + use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is + use scamMod, only: single_column, scm_crm_mode + use flux_avg, only: flux_avg_init + use perf_mod + 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 + + implicit none + private + save + + ! Public methods + public phys_register ! was initindx - register physics methods + public phys_init ! Public initialization method + public phys_run1 ! First phase of the public run method + public phys_run2 ! Second phase of the public run method + public phys_final ! Public finalization method + + ! Private module data + + ! Physics package options + character(len=16) :: shallow_scheme + character(len=16) :: macrop_scheme + character(len=16) :: microp_scheme + character(len=16) :: subcol_scheme + character(len=32) :: cam_take_snapshot_before ! Physics routine to take a snapshot "before" + character(len=32) :: cam_take_snapshot_after ! Physics routine to take a snapshot "after" + integer :: cld_macmic_num_steps ! Number of macro/micro substeps + integer :: cam_snapshot_before_num ! tape number for before snapshots + integer :: cam_snapshot_after_num ! tape number for after snapshots + logical :: do_clubb_sgs + logical :: use_subcol_microp ! if true, use subcolumns in microphysics + logical :: state_debug_checks ! Debug physics_state. + logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols + logical :: prog_modal_aero ! Prognostic modal aerosols present + + ! Physics buffer index + integer :: teout_idx = 0 + + integer :: landm_idx = 0 + integer :: sgh_idx = 0 + integer :: sgh30_idx = 0 + + integer :: qini_idx = 0 + integer :: cldliqini_idx = 0 + integer :: cldiceini_idx = 0 + integer :: totliqini_idx = 0 + integer :: toticeini_idx = 0 + +!+pel + integer :: enthalpy_prec_bc_idx = 0 + integer :: enthalpy_prec_ac_idx = 0 + !integer :: enthalpy_evap_idx = 0 !!tht +!-pel +!+tht + integer :: enthalpy_evop_idx = 0 + integer :: qcsedten_idx=0, qrsedten_idx=0 + integer :: qisedten_idx=0, qssedten_idx=0, qgsedten_idx=0 + integer :: qrain_mg_idx=0, qsnow_mg_idx=0 +!-tht + + integer :: prec_str_idx = 0 + integer :: snow_str_idx = 0 + integer :: prec_sed_idx = 0 + integer :: snow_sed_idx = 0 + integer :: prec_pcw_idx = 0 + integer :: snow_pcw_idx = 0 + integer :: prec_dp_idx = 0 + integer :: snow_dp_idx = 0 + integer :: prec_sh_idx = 0 + integer :: snow_sh_idx = 0 + integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. + integer :: ducore_idx = 0 ! ducore index in physics buffer + integer :: dvcore_idx = 0 ! dvcore index in physics buffer + integer :: dtcore_idx = 0 ! dtcore index in physics buffer + integer :: dqcore_idx = 0 ! dqcore index in physics buffer + integer :: cmfmczm_idx = 0 ! Zhang-McFarlane convective mass fluxes + integer :: rliqbc_idx = 0 ! tphysbc reserve liquid + integer :: psl_idx = 0 +!======================================================================= +contains +!======================================================================= + + subroutine phys_register + !----------------------------------------------------------------------- + ! + ! Purpose: Register constituents and physics buffer fields. + ! + ! Author: CSM Contact: M. Vertenstein, Aug. 1997 + ! B.A. Boville, Oct 2001 + ! A. Gettelman, Nov 2010 - put micro/macro physics into separate routines + ! + !----------------------------------------------------------------------- + use cam_abortutils, only: endrun + use physics_buffer, only: pbuf_init_time, pbuf_cam_snapshot_register + use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol + use constituents, only: cnst_add, cnst_chk_dim + + use cam_control_mod, only: moist_physics + use chemistry, only: chem_register + use mo_lightning, only: lightning_register + use cloud_fraction, only: cldfrc_register + use microp_driver, only: microp_driver_register + use microp_aero, only: microp_aero_register + ! OSLO_AERO begin + use oslo_aero_microp, only: oslo_aero_microp_register + ! OSLO_AERO end + use macrop_driver, only: macrop_driver_register + use clubb_intr, only: clubb_register_cam + use conv_water, only: conv_water_register + use physconst, only: mwh2o, cpwv + use tracers, only: tracers_register + use check_energy, only: check_energy_register + use carma_intr, only: carma_register + use ghg_data, only: ghg_data_register + use vertical_diffusion, only: vd_register + use convect_deep, only: convect_deep_register + use convect_diagnostics,only: convect_diagnostics_register + use radiation, only: radiation_register + use co2_cycle, only: co2_register + use flux_avg, only: flux_avg_register + use iondrag, only: iondrag_register + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_reg + use prescribed_ozone, only: prescribed_ozone_register + use prescribed_volcaero,only: prescribed_volcaero_register + use prescribed_strataero,only: prescribed_strataero_register + use prescribed_aero, only: prescribed_aero_register + use prescribed_ghg, only: prescribed_ghg_register + use aoa_tracers, only: aoa_tracers_register + use aircraft_emit, only: aircraft_emit_register + use cam_diagnostics, only: diag_register + use cloud_diagnostics, only: cloud_diagnostics_register + use cospsimulator_intr, only: cospsimulator_intr_register + use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not + use radheat, only: radheat_register + use subcol, only: subcol_register + use subcol_utils, only: is_subcol_on, subcol_get_scheme + use dyn_comp, only: dyn_register + use offline_driver, only: offline_driver_reg + use hemco_interface, only: HCOI_Chunk_Init + use surface_emissions_mod, only: surface_emissions_reg + use elevated_emissions_mod, only: elevated_emissions_reg + + use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars !+pel + + !---------------------------Local variables----------------------------- + ! + integer :: m ! loop index + integer :: mm ! constituent index + integer :: nmodes + !----------------------------------------------------------------------- + + ! Get physics options + call phys_getopts(shallow_scheme_out = shallow_scheme, & + macrop_scheme_out = macrop_scheme, & + microp_scheme_out = microp_scheme, & + cld_macmic_num_steps_out = cld_macmic_num_steps, & + do_clubb_sgs_out = do_clubb_sgs, & + use_subcol_microp_out = use_subcol_microp, & + state_debug_checks_out = state_debug_checks, & + cam_take_snapshot_before_out= cam_take_snapshot_before, & + cam_take_snapshot_after_out = cam_take_snapshot_after, & + cam_snapshot_before_num_out = cam_snapshot_before_num, & + cam_snapshot_after_num_out = cam_snapshot_after_num) + + subcol_scheme = subcol_get_scheme() + + ! Initialize dyn_time_lvls + call pbuf_init_time() + + ! Register the subcol scheme + call subcol_register() + + ! Register water vapor. + ! ***** N.B. ***** This must be the first call to cnst_add so that + ! water vapor is constituent 1. + if (moist_physics) then + call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & + longname='Specific humidity', readiv=.true., is_convtran1=.true.) + else + call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & + longname='Specific humidity', readiv=.false., is_convtran1=.true.) + end if + + ! Topography file fields. + call pbuf_add_field('LANDM', 'global', dtype_r8, (/pcols/), landm_idx) + call pbuf_add_field('SGH', 'global', dtype_r8, (/pcols/), sgh_idx) + call pbuf_add_field('SGH30', 'global', dtype_r8, (/pcols/), sgh30_idx) + + ! Fields for physics package diagnostics + call pbuf_add_field('QINI', 'physpkg', dtype_r8, (/pcols,pver/), qini_idx) + call pbuf_add_field('CLDLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), cldliqini_idx) + call pbuf_add_field('CLDICEINI', 'physpkg', dtype_r8, (/pcols,pver/), cldiceini_idx) + call pbuf_add_field('TOTLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), totliqini_idx) + call pbuf_add_field('TOTICEINI', 'physpkg', dtype_r8, (/pcols,pver/), toticeini_idx) + +!+pel + if (compute_enthalpy_flux) then + call pbuf_add_field('ENTHALPY_PREC_BC','physpkg', dtype_r8, (/pcols,num_enthalpy_vars/), enthalpy_prec_bc_idx) + call pbuf_add_field('ENTHALPY_PREC_AC','global' , dtype_r8, (/pcols,num_enthalpy_vars/), enthalpy_prec_ac_idx) + !+tht + call pbuf_add_field('ENTHALPY_EVOP' ,'global' , dtype_r8, (/pcols/), enthalpy_evop_idx) + call pbuf_add_field('qrain_mg' , 'physpkg', dtype_r8, (/pcols,pver/), qrain_mg_idx) + call pbuf_add_field('qsnow_mg' , 'physpkg', dtype_r8, (/pcols,pver/), qsnow_mg_idx) + !-tht + end if +!-pel + + ! check energy package + call check_energy_register + + ! If using a simple physics option (e.g., held_suarez, adiabatic), + ! the normal CAM physics parameterizations are not called. + if (moist_physics) then + + ! register fluxes for saving across time + if (phys_do_flux_avg()) call flux_avg_register() + + call cldfrc_register() + + ! cloud water + if (.not. do_clubb_sgs) call macrop_driver_register() + ! OSLO_AERO begin + call oslo_aero_microp_register() + ! OSLO_AERO end + call microp_driver_register() + + ! Register CLUBB_SGS here + if (do_clubb_sgs) call clubb_register_cam() + + call pbuf_add_field('PREC_STR', 'global',dtype_r8,(/pcols/),prec_str_idx) + call pbuf_add_field('SNOW_STR', 'global',dtype_r8,(/pcols/),snow_str_idx) + call pbuf_add_field('PREC_PCW', 'global',dtype_r8,(/pcols/),prec_pcw_idx) + call pbuf_add_field('SNOW_PCW', 'global',dtype_r8,(/pcols/),snow_pcw_idx) + call pbuf_add_field('PREC_SED', 'global',dtype_r8,(/pcols/),prec_sed_idx) + call pbuf_add_field('SNOW_SED', 'global',dtype_r8,(/pcols/),snow_sed_idx) + + if (is_subcol_on()) then + call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) + call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) + call pbuf_register_subcol('PREC_PCW', 'phys_register', prec_pcw_idx) + call pbuf_register_subcol('SNOW_PCW', 'phys_register', snow_pcw_idx) + call pbuf_register_subcol('PREC_SED', 'phys_register', prec_sed_idx) + call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) + end if + + ! Reserve liquid at end of tphysbc + call pbuf_add_field('RLIQBC','physpkg',dtype_r8,(/pcols/),rliqbc_idx) + + ! Who should add FRACIS? + ! -- It does not seem that aero_intr should add it since FRACIS is used in convection + ! even if there are no prognostic aerosols ... so do it here for now + call pbuf_add_field('FRACIS','physpkg',dtype_r8,(/pcols,pver,pcnst/),m) + + call conv_water_register() + + ! Determine whether its a 'modal' aerosol simulation or not + ! OSLO_AERO begin + clim_modal_aero = .false. + ! OSLO_AERO end + + call surface_emissions_reg() + call elevated_emissions_reg() + + ! register chemical constituents including aerosols ... + call chem_register() + + ! add prognostic lightning flash freq pbuf fld + call lightning_register() + + ! co2 constituents + call co2_register() + + ! register other constituents + call prescribed_volcaero_register() + call prescribed_strataero_register() + call prescribed_ozone_register() + call prescribed_aero_register() + call prescribed_ghg_register() + + ! register various data model gasses with pbuf + call ghg_data_register() + + ! carma microphysics + ! + call carma_register() + + ! Register iondrag variables with pbuf + call iondrag_register() + + ! Register ionosphere variables with pbuf if mode set to ionosphere + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_reg() + endif + + call aircraft_emit_register() + + ! deep convection + call convect_deep_register + + ! convection diagnostics + call convect_diagnostics_register + + ! radiation + call radiation_register + call cloud_diagnostics_register + call radheat_register + + ! COSP + call cospsimulator_intr_register + + ! vertical diffusion + call vd_register() + else + ! held_suarez/adiabatic physics option should be in simple_physics + call endrun('phys_register: moist_physics configuration error') + end if + + ! Register diagnostics PBUF + call diag_register() + + ! Register age of air tracers + call aoa_tracers_register() + + ! Register test tracers + call tracers_register() + + call dyn_register() + + ! All tracers registered, check that the dimensions are correct + call cnst_chk_dim() + + ! ***NOTE*** No registering constituents after the call to cnst_chk_dim. + + call offline_driver_reg() + + if (use_hemco) then + ! initialize harmonized emissions component (HEMCO) + call HCOI_Chunk_Init() + endif + + ! This needs to be last as it requires all pbuf fields to be added + if (cam_snapshot_before_num > 0 .or. cam_snapshot_after_num > 0) then + call pbuf_cam_snapshot_register() + end if + + end subroutine phys_register + + + + !======================================================================= + + subroutine phys_inidat( cam_out, pbuf2d ) + use cam_abortutils, only: endrun + + use physics_buffer, only: pbuf_get_index, physics_buffer_desc, pbuf_set_field, dyn_time_lvls + + + use cam_initfiles, only: initial_file_get_id, topo_file_get_id + use cam_grid_support, only: cam_grid_check, cam_grid_id + use cam_grid_support, only: cam_grid_get_dim_names + use pio, only: file_desc_t + use ncdio_atm, only: infld + use dycore, only: dycore_is + use polar_avg, only: polar_average + use short_lived_species, only: initialize_short_lived_species + use cam_control_mod, only: aqua_planet + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_inidat + + type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + integer :: lchnk, m, n, i, k, ncol + type(file_desc_t), pointer :: fh_ini, fh_topo + character(len=8) :: fieldname + real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) + + character(len=11) :: subname='phys_inidat' ! subroutine name + integer :: tpert_idx, qpert_idx, pblh_idx + + logical :: found=.false., found2=.false. + integer :: ierr + character(len=8) :: dim1name, dim2name + integer :: ixcldice, ixcldliq + integer :: grid_id ! grid ID for data mapping + + nullify(tptr,tptr_2,tptr3d,tptr3d_2) + + fh_ini => initial_file_get_id() + fh_topo => topo_file_get_id() + + ! dynamics variables are handled in dyn_init - here we read variables needed for physics + ! but not dynamics + + grid_id = cam_grid_id('physgrid') + if (.not. cam_grid_check(grid_id)) then + call endrun(trim(subname)//': Internal error, no "physgrid" grid') + end if + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + + allocate(tptr(1:pcols,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr(1:pcols,begchunk:endchunk)') + end if + + if (associated(fh_topo) .and. .not. aqua_planet) then + call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not. found) call endrun('ERROR: SGH not found on topo file') + + call pbuf_set_field(pbuf2d, sgh_idx, tptr) + + allocate(tptr_2(1:pcols,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr_2(1:pcols,begchunk:endchunk)') + end if + call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr_2, found, gridname='physgrid') + if(found) then + call pbuf_set_field(pbuf2d, sgh30_idx, tptr_2) + else + if (masterproc) write(iulog,*) 'Warning: Error reading SGH30 from topo file.' + if (masterproc) write(iulog,*) 'The field SGH30 will be filled using data from SGH.' + call pbuf_set_field(pbuf2d, sgh30_idx, tptr) + end if + + deallocate(tptr_2) + + call infld('LANDM_COSLAT', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + + if(.not.found) call endrun(' ERROR: LANDM_COSLAT not found on topo dataset.') + + call pbuf_set_field(pbuf2d, landm_idx, tptr) + + else + call pbuf_set_field(pbuf2d, sgh_idx, 0._r8) + call pbuf_set_field(pbuf2d, sgh30_idx, 0._r8) + call pbuf_set_field(pbuf2d, landm_idx, 0._r8) + end if + + call infld('PBLH', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) 'PBLH initialized to 0.' + end if + pblh_idx = pbuf_get_index('pblh') + + call pbuf_set_field(pbuf2d, pblh_idx, tptr) + + call infld('TPERT', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) 'TPERT initialized to 0.' + end if + tpert_idx = pbuf_get_index( 'tpert') + call pbuf_set_field(pbuf2d, tpert_idx, tptr) + + fieldname='QPERT' + qpert_idx = pbuf_get_index( 'qpert',ierr) + if (qpert_idx > 0) then + call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + call pbuf_set_field(pbuf2d, qpert_idx, tptr) + end if + + fieldname='CUSH' + m = pbuf_get_index('cush', ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not.found) then + if(masterproc) write(iulog,*) trim(fieldname), ' initialized to 1000.' + tptr=1000._r8 + end if + do n=1,dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr, start=(/1,n/), kount=(/pcols,1/)) + end do + deallocate(tptr) + end if + + ! + ! 3-D fields + ! + + allocate(tptr3d(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') + end if + + fieldname='CLOUD' + m = pbuf_get_index('CLD') + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + fieldname='QCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(.not. found) then + call infld('Q',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with Q' + if(dycore_is('LR')) call polar_average(pver, tptr3d) + else + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to huge()' + tptr3d = huge(1.0_r8) + end if + end if + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + end if + + fieldname = 'ICCWAT' + m = pbuf_get_index(fieldname, ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call cnst_get_ind('CLDICE', ixcldice) + call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + end if + if (masterproc) then + if (found) then + write(iulog,*) trim(fieldname), ' initialized with CLDICE' + else + write(iulog,*) trim(fieldname), ' initialized to 0.0' + end if + end if + end if + end if + + fieldname = 'LCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + allocate(tptr3d_2(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d_2(pcols,pver,begchunk:endchunk)') + end if + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + call infld('CLDLIQ',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d_2, found2, gridname='physgrid') + if(found .and. found2) then + do lchnk = begchunk, endchunk + ncol = get_ncols_p(lchnk) + tptr3d(:ncol,:,lchnk)=tptr3d(:ncol,:,lchnk)+tptr3d_2(:ncol,:,lchnk) + end do + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE + CLDLIQ' + else if (found) then ! Data already loaded in tptr3d + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE only' + else if (found2) then + tptr3d(:,:,:)=tptr3d_2(:,:,:) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDLIQ only' + end if + + if (found .or. found2) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + if(dycore_is('LR')) call polar_average(pver, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.0' + end if + deallocate(tptr3d_2) + end if + end if + + fieldname = 'TCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(.not.found) then + call infld('T', fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + if(dycore_is('LR')) call polar_average(pver, tptr3d) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with T' + else + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to huge()' + tptr3d = huge(1._r8) + end if + end if + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + end if + + fieldname = 'CONCLD' + m = pbuf_get_index('CONCLD',ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pverp,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') + end if + + fieldname = 'TKE' + m = pbuf_get_index( 'tke') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0.01_r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.01' + end if + + + fieldname = 'KVM' + m = pbuf_get_index('kvm') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + + fieldname = 'KVH' + m = pbuf_get_index('kvh') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + call initialize_short_lived_species(fh_ini, pbuf2d) + + !--------------------------------------------------------------------------------- + ! If needed, get ion and electron temperature fields from initial condition file + !--------------------------------------------------------------------------------- + + call waccmx_phys_ion_elec_temp_inidat(fh_ini,pbuf2d) + + end subroutine phys_inidat + + + subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) + + !----------------------------------------------------------------------- + ! + ! Initialization of physics package. + ! + !----------------------------------------------------------------------- + + use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index + use physconst, only: rair, cpair, gravit, zvir, & + karman + use cam_thermo, only: cam_thermo_init + use ref_pres, only: pref_edge, pref_mid + + use carma_intr, only: carma_init + use cam_control_mod, only: initial_run + use check_energy, only: check_energy_init + use chemistry, only: chem_init + use mo_lightning, only: lightning_init + use prescribed_ozone, only: prescribed_ozone_init + use prescribed_ghg, only: prescribed_ghg_init + use prescribed_aero, only: prescribed_aero_init + use aerodep_flx, only: aerodep_flx_init + use aircraft_emit, only: aircraft_emit_init + use prescribed_volcaero,only: prescribed_volcaero_init + use prescribed_strataero,only: prescribed_strataero_init + use cloud_fraction, only: cldfrc_init + use cldfrc2m, only: cldfrc2m_init + use co2_cycle, only: co2_init, co2_transport + use convect_deep, only: convect_deep_init + use convect_diagnostics,only: convect_diagnostics_init + use cam_diagnostics, only: diag_init + ! OSLO_AERO begin + use oslo_aero_diagnostics, only: oslo_aero_diagnostics_init + ! OSLO_AERO end + use gw_drag, only: gw_init + use radheat, only: radheat_init + use radiation, only: radiation_init + use cloud_diagnostics, only: cloud_diagnostics_init + use wv_saturation, only: wv_sat_init + use microp_driver, only: microp_driver_init + use microp_aero, only: microp_aero_init + ! OSLO_AERO begin + use oslo_aero_microp, only: oslo_aero_microp_init + ! OSLO_AERO end + use macrop_driver, only: macrop_driver_init + use conv_water, only: conv_water_init + use tracers, only: tracers_init + use aoa_tracers, only: aoa_tracers_init + use rayleigh_friction, only: rayleigh_friction_init + use vertical_diffusion, only: vertical_diffusion_init + use phys_debug_util, only: phys_debug_init + use phys_debug, only: phys_debug_state_init + use rad_constituents, only: rad_cnst_init + use aer_rad_props, only: aer_rad_props_init + use subcol, only: subcol_init + use qbo, only: qbo_init + use qneg_module, only: qneg_init + use lunar_tides, only: lunar_tides_init + use iondrag, only: iondrag_init +#if ( defined OFFLINE_DYN ) + use metdata, only: metdata_phys_init +#endif + use epp_ionization, only: epp_ionization_init, epp_ionization_active + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) + use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) + use clubb_intr, only: clubb_ini_cam + use tropopause, only: tropopause_init + use solar_data, only: solar_data_init + use dadadj_cam, only: dadadj_cam_init + use cam_abortutils, only: endrun + use nudging, only: Nudge_Model, nudging_init + use cam_snapshot, only: cam_snapshot_init + use cam_history, only: addfld, register_vector_field, add_default + use cam_budget, only: cam_budget_init + use phys_grid_ctem, only: phys_grid_ctem_init + use surface_emissions_mod, only: surface_emissions_init + use elevated_emissions_mod, only: elevated_emissions_init + + use ccpp_constituent_prop_mod, only: ccpp_const_props_init + + ! Input/output arguments + type(physics_state), pointer :: phys_state(:) + type(physics_tend ), pointer :: phys_tend(:) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + type(cam_in_t), intent(in) :: cam_in(begchunk:endchunk) + type(cam_out_t),intent(inout) :: cam_out(begchunk:endchunk) + + ! local variables + integer :: lchnk + integer :: ierr + integer :: ixq + + logical :: history_budget ! output tendencies and state variables for + ! temperature, water vapor, cloud + ! ice, cloud liquid, U, V + integer :: history_budget_histfile_num ! output history file number for budget fields + + !----------------------------------------------------------------------- + + call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) + + do lchnk = begchunk, endchunk + call physics_state_set_grid(lchnk, phys_state(lchnk)) + end do + + !------------------------------------------------------------------------------------------- + ! Initialize any variables in cam_thermo which are not temporally and/or spatially constant + !------------------------------------------------------------------------------------------- + call cam_thermo_init() + + ! Initialize debugging a physics column + call phys_debug_init() + + call pbuf_initialize(pbuf2d) + + ! Initialize subcol scheme + call subcol_init(pbuf2d) + + ! diag_init makes addfld calls for dynamics fields that are output from + ! the physics decomposition + call diag_init(pbuf2d) + ! OSLO_AERO begin + call oslo_aero_diagnostics_init() + ! OSLO_AERO end + + call check_energy_init() + + call tracers_init() + + ! age of air tracers + call aoa_tracers_init() + + teout_idx = pbuf_get_index( 'TEOUT') + + ! adiabatic or ideal physics should be only used if in simple_physics + if (adiabatic .or. ideal_phys) then + if (adiabatic) then + call endrun('phys_init: adiabatic configuration error') + else + call endrun('phys_init: ideal_phys configuration error') + end if + end if + + if (initial_run) then + call phys_inidat(cam_out, pbuf2d) + end if + + ! wv_saturation is relatively independent of everything else and + ! low level, so init it early. Must at least do this before radiation. + call wv_sat_init + + ! solar irradiance data modules + call solar_data_init() + + ! Initialize rad constituents and their properties + call rad_cnst_init() + + call radiation_init(pbuf2d) + + call aer_rad_props_init() + + ! initialize carma + call carma_init(pbuf2d) + call surface_emissions_init(pbuf2d) + call elevated_emissions_init(pbuf2d) + + ! Prognostic chemistry. + call chem_init(phys_state,pbuf2d) + + ! Lightning flash frq and NOx prod + call lightning_init( pbuf2d ) + + ! Prescribed tracers + call prescribed_ozone_init() + call prescribed_ghg_init() + call prescribed_aero_init() + call aerodep_flx_init() + call aircraft_emit_init() + call prescribed_volcaero_init() + call prescribed_strataero_init() + + ! co2 cycle + if (co2_transport()) then + call co2_init() + end if + + call gw_init() + + call rayleigh_friction_init() + + call vertical_diffusion_init(pbuf2d) + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_init () + ! Initialization of ionosphere module if mode set to ionosphere + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_init(pbuf2d) + endif + endif + + call cloud_diagnostics_init(pbuf2d) + + call radheat_init(pref_mid) + + call convect_diagnostics_init() + + call cldfrc_init() + call cldfrc2m_init() + + call convect_deep_init(pref_edge) + + if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) + ! OSLO_AERO begin + call oslo_aero_microp_init() + ! OSLO_AERO end + call microp_driver_init(pbuf2d) + call conv_water_init + + ! initiate CLUBB within CAM + if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) + + call qbo_init + + call lunar_tides_init() + + call iondrag_init(pref_mid) + ! Geomagnetic module -- after iondrag_init + if (epp_ionization_active) then + call epp_ionization_init() + endif + +#if ( defined OFFLINE_DYN ) + call metdata_phys_init() +#endif + call tropopause_init() + call dadadj_cam_init() + + prec_dp_idx = pbuf_get_index('PREC_DP') + snow_dp_idx = pbuf_get_index('SNOW_DP') + prec_sh_idx = pbuf_get_index('PREC_SH') + snow_sh_idx = pbuf_get_index('SNOW_SH') + + dlfzm_idx = pbuf_get_index('DLFZM', ierr) + cmfmczm_idx = pbuf_get_index('CMFMC_DP', ierr) + + ! OSLO_AERO begin + prog_modal_aero = .true. + ! OSLO_AERO end + + ! Initialize Nudging Parameters + !-------------------------------- + if(Nudge_Model) call nudging_init + + if (clim_modal_aero) then + + ! If climate calculations are affected by prescribed modal aerosols, the + ! initialization routine for the dry mode radius calculation is called + ! here. For prognostic MAM the initialization is called from + ! modal_aero_initialize + if (.not. prog_modal_aero) then + call modal_aero_calcsize_init(pbuf2d) + endif + + call modal_aero_wateruptake_init(pbuf2d) + + end if + + ! Initialize CAM CCPP constituent properties array + ! for use in CCPP-ized physics schemes: + call cnst_get_ind('Q', ixq) + call ccpp_const_props_init(ixq) + + ! Initialize qneg3 and qneg4 + call qneg_init() + + ! Initialize phys TEM diagnostics + call phys_grid_ctem_init() + + ! Initialize the snapshot capability + call cam_snapshot_init(cam_in, cam_out, pbuf2d, begchunk) + + ! Initialize the budget capability + call cam_budget_init() + + ! addfld calls for U, V tendency budget variables that are output in + ! tphysac, tphysbc + call addfld ( 'UTEND_DCONV', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by deep convection') + call addfld ( 'VTEND_DCONV', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by deep convection') + call register_vector_field ( 'UTEND_DCONV', 'VTEND_DCONV') + call addfld ( 'UTEND_SHCONV', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by shallow convection') + call addfld ( 'VTEND_SHCONV', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by shallow convection') + call register_vector_field ( 'UTEND_SHCONV', 'VTEND_SHCONV') + call addfld ( 'UTEND_MACROP', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by macrophysics') + call addfld ( 'VTEND_MACROP', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by macrophysics') + call register_vector_field ( 'UTEND_MACROP', 'VTEND_MACROP') + call addfld ( 'UTEND_VDIFF', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by vert. diffus.') + call addfld ( 'VTEND_VDIFF', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by vert. diffus.') + call register_vector_field ( 'UTEND_VDIFF', 'VTEND_VDIFF') + call addfld ( 'UTEND_RAYLEIGH', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by Rayleigh Fric.') + call addfld ( 'VTEND_RAYLEIGH', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by Rayleigh Fric.') + call register_vector_field ( 'UTEND_RAYLEIGH', 'VTEND_RAYLEIGH') + call addfld ( 'UTEND_GWDTOT', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by all GWs') + call addfld ( 'VTEND_GWDTOT', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by all GWs') + call register_vector_field ( 'UTEND_GWDTOT', 'VTEND_GWDTOT') + call addfld ( 'UTEND_QBORLX', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by QBO relaxation') + call addfld ( 'VTEND_QBORLX', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by QBO relaxation') + call register_vector_field ( 'UTEND_QBORLX', 'VTEND_QBORLX') + call addfld ( 'UTEND_LUNART', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by lunar tides') + call addfld ( 'VTEND_LUNART', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by lunar tides') + call register_vector_field ( 'UTEND_LUNART', 'VTEND_LUNART') + call addfld ( 'UTEND_IONDRG', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by ion drag') + call addfld ( 'VTEND_IONDRG', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by ion drag') + call register_vector_field ( 'UTEND_IONDRG', 'VTEND_IONDRG') + call addfld ( 'UTEND_NDG', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by nudging') + call addfld ( 'VTEND_NDG', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by nudging') + call register_vector_field ( 'UTEND_NDG', 'VTEND_NDG') + call addfld('UTEND_CORE', (/ 'lev' /), 'A', 'm/s2' , 'Zonal wind tendency due to dynamical core') + call addfld('VTEND_CORE', (/ 'lev' /), 'A', 'm/s2' , 'Meridional wind tendency due to dynamical core') + call register_vector_field('UTEND_CORE','VTEND_CORE') + + + call phys_getopts(history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + if ( history_budget ) then + call add_default ( 'UTEND_DCONV' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_DCONV' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_SHCONV' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_SHCONV' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_MACROP' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_MACROP' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_VDIFF' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_VDIFF' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_RAYLEIGH' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_RAYLEIGH' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_GWDTOT' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_GWDTOT' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_QBORLX' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_QBORLX' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_LUNART' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_LUNART' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_IONDRG' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_IONDRG' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_NDG' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_NDG' , history_budget_histfile_num, ' ') + call add_default ( 'UTEND_CORE' , history_budget_histfile_num, ' ') + call add_default ( 'VTEND_CORE' , history_budget_histfile_num, ' ') + end if + + ducore_idx = pbuf_get_index('DUCORE') + dvcore_idx = pbuf_get_index('DVCORE') + dtcore_idx = pbuf_get_index('DTCORE') + dqcore_idx = pbuf_get_index('DQCORE') + + psl_idx = pbuf_get_index('PSL') + + end subroutine phys_init + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! First part of atmospheric physics package before updating of surface models + ! + !----------------------------------------------------------------------- + use time_manager, only: get_nstep + use cam_diagnostics,only: diag_allocate, diag_physvar_ic + use check_energy, only: check_energy_gmean + use spmd_utils, only: mpicom + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate + use cam_history, only: outfld, write_camiop + use cam_abortutils, only: endrun +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_srf1 +#endif + ! + ! Input arguments + ! + real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 + ! + ! Input/Output arguments + ! + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + + type(physics_buffer_desc), pointer, dimension(:,:) :: pbuf2d + type(cam_in_t), dimension(begchunk:endchunk) :: cam_in + type(cam_out_t), dimension(begchunk:endchunk) :: cam_out + !----------------------------------------------------------------------- + ! + !---------------------------Local workspace----------------------------- + ! + integer :: c ! indices + integer :: ncol ! number of columns + integer :: nstep ! current timestep number + type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) + + call t_startf ('physpkg_st1') + nstep = get_nstep() + +#if ( defined OFFLINE_DYN ) + ! + ! if offline mode set SNOWH and TS for micro-phys + ! + call get_met_srf1( cam_in ) +#endif + + ! The following initialization depends on the import state (cam_in) + ! being initialized. This isn't true when cam_init is called, so need + ! to postpone this initialization to here. + if (nstep == 0 .and. phys_do_flux_avg()) call flux_avg_init(cam_in, pbuf2d) + + ! Compute total energy of input state and previous output state + call t_startf ('chk_en_gmean') + call check_energy_gmean(phys_state, pbuf2d, ztodt, nstep) + call t_stopf ('chk_en_gmean') + + call pbuf_allocate(pbuf2d, 'physpkg') + call diag_allocate() + + !----------------------------------------------------------------------- + ! Advance time information + !----------------------------------------------------------------------- + + call phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) + + call t_stopf ('physpkg_st1') + +#ifdef TRACER_CHECK + call gmean_mass ('before tphysbc DRY', phys_state) +#endif + + + !----------------------------------------------------------------------- + ! Tendency physics before flux coupler invocation + !----------------------------------------------------------------------- + ! + + if (write_camiop) then + do c=begchunk, endchunk + call outfld('Tg',cam_in(c)%ts,pcols ,c ) + end do + end if + + call t_barrierf('sync_bc_physics', mpicom) + call t_startf ('bc_physics') + call t_adj_detailf(+1) + +!$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) + do c=begchunk, endchunk + ! + ! Output physics terms to IC file + ! + phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) + + call t_startf ('diag_physvar_ic') + call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) + call t_stopf ('diag_physvar_ic') + + call tphysbc (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + end do + + call t_adj_detailf(-1) + call t_stopf ('bc_physics') + + ! Don't call the rest in CRM mode + if(single_column.and.scm_crm_mode) return + +#ifdef TRACER_CHECK + call gmean_mass ('between DRY', phys_state) +#endif + + end subroutine phys_run1 + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & + cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Second part of atmospheric physics package after updating of surface models + ! + !----------------------------------------------------------------------- + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_deallocate, pbuf_update_tim_idx + use mo_lightning, only: lightning_no_prod + use cam_diagnostics, only: diag_deallocate, diag_surf + use carma_intr, only: carma_accumulate_stats + use spmd_utils, only: mpicom + use iop_forcing, only: scam_use_iop_srf +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_srf2 +#endif + use hemco_interface, only: HCOI_Chunk_Run + ! + ! Input arguments + ! + real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 + ! + ! Input/Output arguments + ! + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + type(physics_buffer_desc),pointer, dimension(:,:) :: pbuf2d + + type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + ! + !----------------------------------------------------------------------- + !---------------------------Local workspace----------------------------- + ! + integer :: c ! chunk index + integer :: ncol ! number of columns + type(physics_buffer_desc),pointer, dimension(:) :: phys_buffer_chunk + ! + ! If exit condition just return + ! + + if(single_column.and.scm_crm_mode) then + call diag_deallocate() + return + end if + !----------------------------------------------------------------------- + ! if using IOP values for surface fluxes overwrite here after surface components run + !----------------------------------------------------------------------- + if (single_column) call scam_use_iop_srf(cam_in) + + if(use_hemco) then + !---------------------------------------------------------- + ! run hemco (phase 2 before chemistry) + ! only phase 2 is used currently for HEMCO-CESM + !---------------------------------------------------------- + call HCOI_Chunk_Run(cam_in, phys_state, pbuf2d, phase=2) + endif + + !----------------------------------------------------------------------- + ! Tendency physics after coupler + ! Not necessary at terminal timestep. + !----------------------------------------------------------------------- + ! +#if ( defined OFFLINE_DYN ) + ! + ! if offline mode set SHFLX QFLX TAUX TAUY for vert diffusion + ! + call get_met_srf2( cam_in ) +#endif + ! lightning flash freq and prod rate of NOx + call t_startf ('lightning_no_prod') + call lightning_no_prod( phys_state, pbuf2d, cam_in ) + call t_stopf ('lightning_no_prod') + + call t_barrierf('sync_ac_physics', mpicom) + call t_startf ('ac_physics') + call t_adj_detailf(+1) + +!$OMP PARALLEL DO PRIVATE (C, NCOL, phys_buffer_chunk) + + do c=begchunk,endchunk + ncol = get_ncols_p(c) + phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) + ! + ! surface diagnostics for history files + ! + call t_startf('diag_surf') + call diag_surf(cam_in(c), cam_out(c), phys_state(c), phys_buffer_chunk) + call t_stopf('diag_surf') + + call tphysac(ztodt, cam_in(c), & + cam_out(c), & + phys_state(c), phys_tend(c), phys_buffer_chunk) + end do ! Chunk loop + + call t_adj_detailf(-1) + call t_stopf('ac_physics') + +#ifdef TRACER_CHECK + call gmean_mass ('after tphysac FV:WET)', phys_state) +#endif + + call t_startf ('carma_accumulate_stats') + call carma_accumulate_stats() + call t_stopf ('carma_accumulate_stats') + + call t_startf ('physpkg_st2') + call pbuf_deallocate(pbuf2d, 'physpkg') + + call pbuf_update_tim_idx() + call diag_deallocate() + call t_stopf ('physpkg_st2') + + end subroutine phys_run2 + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_final( phys_state, phys_tend, pbuf2d ) + use physics_buffer, only: physics_buffer_desc, pbuf_deallocate + use chemistry, only: chem_final + use carma_intr, only: carma_final + use wv_saturation, only: wv_sat_final + use microp_aero, only: microp_aero_final + use phys_grid_ctem, only: phys_grid_ctem_final + use nudging, only: Nudge_Model, nudging_final + use hemco_interface, only: HCOI_Chunk_Final + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Finalization of physics package + ! + !----------------------------------------------------------------------- + ! Input/output arguments + type(physics_state), pointer :: phys_state(:) + type(physics_tend ), pointer :: phys_tend(:) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + if(associated(pbuf2d)) then + call pbuf_deallocate(pbuf2d,'global') + deallocate(pbuf2d) + end if + deallocate(phys_state) + deallocate(phys_tend) + call chem_final + call carma_final + call wv_sat_final + ! OSLO_AERO begin + ! microp_aero_final() not called + ! OSLO_AERO end + call phys_grid_ctem_final() + if(Nudge_Model) call nudging_final() + + if(use_hemco) then + ! cleanup hemco + call HCOI_Chunk_Final + endif + + end subroutine phys_final + + + subroutine tphysac (ztodt, cam_in, & + cam_out, state, tend, pbuf) + !----------------------------------------------------------------------- + ! + ! Tendency physics after coupling to land, sea, and ice models. + ! + ! Computes the following: + ! + ! o Aerosol Emission at Surface + ! o Stratiform Macro-Microphysics + ! o Wet Scavenging of Aerosol + ! o Radiation + ! o Source-Sink for Advected Tracers + ! o Symmetric Turbulence Scheme - Vertical Diffusion + ! o Rayleigh Friction + ! o Dry Deposition of Aerosol + ! o Enforce Charge Neutrality ( Only for WACCM ) + ! o Gravity Wave Drag + ! o QBO Relaxation ( Only for WACCM ) + ! o Ion Drag ( Only for WACCM ) + ! o Scale Dry Mass Energy + !----------------------------------------------------------------------- + use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx + use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions + use cam_diagnostics, only: diag_phys_tend_writeout + use gw_drag, only: gw_tend + use vertical_diffusion, only: vertical_diffusion_tend + use rayleigh_friction, only: rayleigh_friction_tend + use physics_types, only: physics_dme_adjust, set_dry_to_wet, physics_state_check, & + dyn_te_idx + use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X + use aoa_tracers, only: aoa_tracers_timestep_tend + use physconst, only: rhoh2o + use aero_model, only: aero_model_drydep + use check_energy, only: check_energy_timestep_init, check_energy_cam_chng + use check_energy, only: tot_energy_phys, enthalpy_adjustment !+pel/tht + use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng + use time_manager, only: get_nstep + use cam_abortutils, only: endrun + use dycore, only: dycore_is + use cam_control_mod, only: aqua_planet + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_set + use charge_neutrality, only: charge_balance + use qbo, only: qbo_relax + use iondrag, only: iondrag_calc, do_waccm_ions + use perf_mod + use flux_avg, only: flux_avg_run + use cam_history, only: hist_fld_active, outfld + use qneg_module, only: qneg4 + use co2_cycle, only: co2_cycle_set_ptend + use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend + use cam_snapshot, only: cam_snapshot_all_outfld_tphysac + use cam_snapshot_common,only: cam_snapshot_ptend_outfld + use lunar_tides, only: lunar_tides_tend + use ssatcontrail, only: ssatcontrail_d0 + use physics_types, only: physics_ptend_init, physics_ptend_sum, physics_ptend_scale + use microp_driver, only: microp_driver_tend + use microp_aero, only: microp_aero_run + ! OSLO_AERO begin + use oslo_aero_microp, only: oslo_aero_microp_run + use oslo_aero_share + ! OSLO_AERO end + use clubb_intr, only: clubb_tend_cam, clubb_emissions_cam + use subcol, only: subcol_gen, subcol_ptend_avg + use subcol_utils, only: subcol_ptend_copy, is_subcol_on + use subcol_SILHS, only: subcol_SILHS_var_covar_driver, init_state_subcol + use subcol_SILHS, only: subcol_SILHS_fill_holes_conserv + use subcol_SILHS, only: subcol_SILHS_hydromet_conc_tend_lim + use micro_pumas_cam, only: massless_droplet_destroyer + use convect_deep, only: convect_deep_tend_2, deep_scheme_does_scav_trans + use cloud_diagnostics, only: cloud_diagnostics_calc + use radiation, only: radiation_tend + use tropopause, only: tropopause_output + use cam_diagnostics, only: diag_phys_writeout, diag_conv, diag_clip_tend_writeout + use aero_model, only: aero_model_wetdep + use aero_wetdep_cam, only: wetdep_lq + use physics_buffer, only: col_type_subcol + use carma_intr, only: carma_wetdep_tend, carma_timestep_tend, carma_emission_tend + use carma_flags_mod, only: carma_do_aerosol, carma_do_emission, carma_do_detrain + use carma_flags_mod, only: carma_do_cldice, carma_do_cldliq, carma_do_wetdep + use dyn_tests_utils, only: vc_dycore + use cam_thermo, only: cam_thermo_water_update + use cam_budget, only: thermo_budget_history + use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure + use air_composition, only: cpairv, cp_or_cv_dycore +!+pel/tht + use air_composition, only: compute_enthalpy_flux + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx +!-pel/tht + ! + ! Arguments + ! + real(r8), intent(in) :: ztodt ! Two times model timestep (2 delta-t) + + type(cam_in_t), intent(inout) :: cam_in + type(cam_out_t), intent(inout) :: cam_out + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + + + type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes + + ! + !---------------------------Local workspace----------------------------- + ! + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + type(physics_ptend) :: ptend_macp_all ! sum of macrophysics tendencies (e.g. CLUBB) over substeps + type(physics_state) :: state_sc ! state for sub-columns + type(physics_ptend) :: ptend_sc ! ptend for sub-columns + type(physics_ptend) :: ptend_aero ! ptend for microp_aero + type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns + type(physics_tend) :: tend_sc ! tend for sub-columns + + integer :: nstep ! current timestep number + real(r8) :: zero(pcols) ! array of zeros + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer i,k,m ! Longitude, level indices + integer :: yr, mon, day, tod ! components of a date + integer :: ixq, ixcldice, ixcldliq ! constituent indices for vapor, cloud liquid and ice water. + + ! for macro/micro co-substepping + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep + + real(r8) :: net_flx(pcols) + + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) rtdt ! 1./ztodt + + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: flx_cnd(pcols) + + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: zero_tracers(pcols,pcnst) + + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + real(r8), pointer :: cmfmczm(:,:) ! ZM convective mass fluxes + real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid + + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + + ! Local copies for substepping + real(r8) :: prec_pcw_macmic(pcols) + real(r8) :: snow_pcw_macmic(pcols) + real(r8) :: prec_sed_macmic(pcols) + real(r8) :: snow_sed_macmic(pcols) + + ! carma precipitation variables + real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) + real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) + + logical :: labort ! abort flag + + real(r8) tvm(pcols,pver) ! virtual temperature + real(r8) prect(pcols) ! total precipitation + real(r8) surfric(pcols) ! surface friction velocity + real(r8) obklen(pcols) ! Obukhov length + real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_cam_chng. + real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space + real(r8) :: tmp_pdel (pcols,pver) ! tmp space + real(r8) :: tmp_ps (pcols) ! tmp space + real(r8) :: scaling(pcols,pver) + logical :: moist_mixing_ratio_dycore + + ! physics buffer fields for total energy and mass adjustment + integer itim_old, ifld + + real(r8), pointer, dimension(:,:) :: cld + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: totliqini + real(r8), pointer, dimension(:,:) :: toticeini + real(r8), pointer, dimension(:,:) :: dtcore + real(r8), pointer, dimension(:,:) :: dqcore + real(r8), pointer, dimension(:,:) :: ducore + real(r8), pointer, dimension(:,:) :: dvcore + real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction + +!+tht variables for dme_energy_adjust + real(r8), pointer, dimension(:,:) :: qcsedten, qrsedten, qisedten, qssedten, qgsedten + real(r8), pointer, dimension(:,:) :: qrain_mg , qsnow_mg + real(r8), dimension(pcols,pver) :: qrain_mg_macmic , qsnow_mg_macmic + integer :: m_cnst + real(r8):: hflx_iref(pcols) + character(50) :: physparname !(and a little extra log info) +!-tht + + !----------------------------------------------------------------------- + lchnk = state%lchnk + ncol = state%ncol + + nstep = get_nstep() + rtdt = 1._r8/ztodt + + ! Adjust the surface fluxes to reduce instabilities in near sfc layer + if (phys_do_flux_avg()) then + call flux_avg_run(state, cam_in, pbuf, nstep, ztodt) + endif + + ! Validate the physics state. + if (state_debug_checks) then + call physics_state_check(state, name="before tphysac") + end if + + call t_startf('tphysac_init') + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + + call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) + call pbuf_get_field(pbuf, totliqini_idx, totliqini) + call pbuf_get_field(pbuf, toticeini_idx, toticeini) + + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, start=(/1,1,itim_old/),kount=(/pcols,pver,1/)) + + ifld = pbuf_get_index('AST') + call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call cnst_get_ind('Q', ixq) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (is_subcol_on()) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + end if + + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) + else + dlf(:,:) = 0._r8 + end if + + if (cmfmczm_idx > 0) then + call pbuf_get_field(pbuf, cmfmczm_idx, cmfmczm) + cmfmc(:ncol,:) = cmfmczm(:ncol,:) + else + cmfmc(:ncol,:) = 0._r8 + end if + + call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) + rliq(:ncol) = rliqbc(:ncol) + + ! + ! accumulate fluxes into net flux array for spectral dycores + ! jrm Include latent heat of fusion for snow + ! + do i=1,ncol + tend%flx_net(i) = tend%flx_net(i) + cam_in%shf(i) + (cam_out%precc(i) & + + cam_out%precl(i))*latvap*rhoh2o & + + (cam_out%precsc(i) + cam_out%precsl(i))*latice*rhoh2o + end do + + ! emissions of aerosols and gas-phase chemistry constituents at surface + + if (trim(cam_take_snapshot_before) == "chem_emissions") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call chem_emissions( state, cam_in, pbuf ) + if (trim(cam_take_snapshot_after) == "chem_emissions") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + if (carma_do_emission) then + ! carma emissions + call carma_emission_tend (state, ptend, cam_in, ztodt, pbuf) + call physics_update(state, ptend, ztodt, tend) + end if + + ! get nstep and zero array for energy checker + zero = 0._r8 + zero_sc(:) = 0._r8 + zero_tracers(:,:) = 0._r8 + nstep = get_nstep() + call check_tracers_init(state, tracerint) + + ! Check if latent heat flux exceeds the total moisture content of the + ! lowest model layer, thereby creating negative moisture. + + hflx_iref(:ncol) = cam_in%shf(:ncol) !+tht + call qneg4('TPHYSAC', lchnk, ncol, ztodt , & + state%q(1,pver,1), state%rpdel(1,pver), & + hflx_iref, & !+tht + cam_in%shf, cam_in%lhf, cam_in%cflx) + + call t_stopf('tphysac_init') + + !=================================================== + ! Apply tracer surface fluxes to lowest model layer + !=================================================== + call t_startf('clubb_emissions_tend') + + call clubb_emissions_cam(state, cam_in, ptend) + + call physics_update(state, ptend, ztodt, tend) + + call check_energy_cam_chng(state, tend, "clubb_emissions_tend", nstep, ztodt, zero, zero, zero, zero) + + call t_stopf('clubb_emissions_tend') + + !=================================================== + ! Calculate tendencies from CARMA bin microphysics. + !=================================================== + ! + ! If CARMA is doing detrainment, then on output, rliq no longer represents + ! water reserved + ! for detrainment, but instead represents potential snow fall. The mass and + ! number of the + ! snow are stored in the physics buffer and will be incorporated by the MG + ! microphysics. + ! + ! Currently CARMA cloud microphysics is only supported with the MG + ! microphysics. + call t_startf('carma_timestep_tend') + + if (carma_do_cldice .or. carma_do_cldliq) then + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & + prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) + call physics_update(state, ptend, ztodt, tend) + + ! Before the detrainment, the reserved condensate is all liquid, but if + ! CARMA is doing + ! detrainment, then the reserved condensate is snow. + if (carma_do_detrain) then + call check_energy_cam_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) + else + call check_energy_cam_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + end if + end if + + call t_stopf('carma_timestep_tend') + + if( microp_scheme == 'MG' ) then + ! Start co-substepping of macrophysics and microphysics + cld_macmic_ztodt = ztodt/cld_macmic_num_steps + + ! Clear precip fields that should accumulate. + prec_sed_macmic = 0._r8 + snow_sed_macmic = 0._r8 + prec_pcw_macmic = 0._r8 + snow_pcw_macmic = 0._r8 +!+tht + if (compute_enthalpy_flux) then + qrain_mg_macmic(:ncol,:) = 0._r8 + qsnow_mg_macmic(:ncol,:) = 0._r8 + endif +!-tht + ! contrail parameterization + ! see Chen et al., 2012: Global contrail coverage simulated + ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES + ! https://doi.org/10.1029/2011MS000105 + call ssatcontrail_d0(state, pbuf, ztodt, ptend) + call physics_update(state, ptend, ztodt, tend) + + ! initialize ptend structures where macro and microphysics tendencies are + ! accumulated over macmic substeps + call physics_ptend_init(ptend_macp_all,state%psetcols,'macrophysics',lu=.true.,lv=.true.) + + do macmic_it = 1, cld_macmic_num_steps + + !=================================================== + ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) + !=================================================== + + call t_startf('macrop_tend') + + ! ===================================================== + ! CLUBB call (PBL, shallow convection, macrophysics) + ! ===================================================== + + if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) +!+tht + !flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) + flx_heat(:ncol) = hflx_iref(:ncol) + det_s(:ncol) +!-tht + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + ! Update physics tendencies and copy state to state_eq, because that is + ! input for microphysics + if ( (trim(cam_take_snapshot_after) == "clubb_tend_cam") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_ptend_sum(ptend,ptend_macp_all,ncol) + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code +!+tht (a little extra log info) + !call check_energy_cam_chng(state, tend, "clubb_tend", nstep, ztodt, & + write(physparname,"(i3)") macmic_it + physparname="clubb_tend "//trim(physparname) + call check_energy_cam_chng(state, tend, physparname, nstep, ztodt, & +!-tht + cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) + + call t_stopf('macrop_tend') + + !=================================================== + ! Calculate cloud microphysics + !=================================================== + + if (is_subcol_on() .neqv. use_subcol_microp ) then + call endrun("Error calculating cloud microphysics: is_subcol_on() != use_subcol_microp") + end if + + if (is_subcol_on()) then + ! Allocate sub-column structures. + call physics_state_alloc(state_sc, lchnk, psubcols*pcols) + call physics_tend_alloc(tend_sc, psubcols*pcols) + + ! Generate sub-columns using the requested scheme + if (trim(subcol_scheme) == 'SILHS') call init_state_subcol(state, tend, state_sc, tend_sc) + call subcol_gen(state, tend, state_sc, tend_sc, pbuf) + + !Initialize check energy for subcolumns + call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) + end if + + if (trim(cam_take_snapshot_before) == "microp_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + ! OSLO_AERO begin + call t_startf('oslo_aero_microp_run') + call oslo_aero_microp_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('oslo_aero_microp_run') + ! OSLO_AERO end + + call t_startf('microp_tend') + + if (use_subcol_microp) then + + if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) + ! Parameterize subcolumn effects on covariances, if enabled + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_var_covar_driver( cld_macmic_ztodt, state_sc, ptend_sc, pbuf ) + + ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero + call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) + + ! Call the conservative hole filler. + ! Hole filling is only necessary when using subcolumns. + ! Note: this needs to be called after subcol_ptend_avg but before + ! physics_ptend_scale. + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_fill_holes_conserv( state, cld_macmic_ztodt, & + ptend, pbuf ) + + ! Destroy massless droplets - Note this routine returns with no change unless + ! micro_do_massless_droplet_destroyer has been set to true + call massless_droplet_destroyer( cld_macmic_ztodt, state, & ! Intent(in) + ptend ) ! Intent(inout) + + ! Limit the value of hydrometeor concentrations in order to place + ! reasonable limits on hydrometeor drop size and keep them from + ! becoming too large. + ! Note: this needs to be called after hydrometeor mixing ratio + ! tendencies are adjusted by subcol_SILHS_fill_holes_conserv + ! and after massless drop concentrations are removed by the + ! subcol_SILHS_massless_droplet_destroyer, but before the + ! call to physics_ptend_scale. + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_hydromet_conc_tend_lim( state, cld_macmic_ztodt, ptend ) + + ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend + call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) + call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + call physics_ptend_dealloc(ptend_aero_sc) + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) + + if ( (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update (state_sc, ptend_sc, ztodt, tend_sc) + + if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call check_energy_cam_chng(state_sc, tend_sc, "microp_tend_subcol", & + nstep, ztodt, zero_sc, & + prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & + snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) + + call physics_state_dealloc(state_sc) + call physics_tend_dealloc(tend_sc) + call physics_ptend_dealloc(ptend_sc) + else + call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) + end if + ! combine aero and micro tendencies for the grid + call physics_ptend_sum(ptend_aero, ptend, ncol) + call physics_ptend_dealloc(ptend_aero) + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + call diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) + + if ( (trim(cam_take_snapshot_after) == "microp_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update (state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "microp_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if +!+tht (a little extra log info) + !call check_energy_cam_chng(state, tend, "microp_tend", nstep, ztodt, & + write(physparname,"(i3)") macmic_it + physparname="microp_tend "//trim(physparname) + call check_energy_cam_chng(state, tend, physparname, nstep, ztodt, & +!-tht + zero, prec_str(:ncol)/cld_macmic_num_steps, & + snow_str(:ncol)/cld_macmic_num_steps, zero) + + call t_stopf('microp_tend') + + prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) + snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) + prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) + snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) +!+tht + if (compute_enthalpy_flux) then + if(macmic_it.eq.1) then + qcsedten_idx = pbuf_get_index('QCSEDTEN' , errcode=i) + qrsedten_idx = pbuf_get_index('QRSEDTEN' , errcode=i) + qisedten_idx = pbuf_get_index('QISEDTEN' , errcode=i) + qssedten_idx = pbuf_get_index('QSSEDTEN' , errcode=i) + qgsedten_idx = pbuf_get_index('QGSEDTEN' , errcode=i) + endif + if (qcsedten_idx.gt.0) then + call pbuf_get_field(pbuf, qcsedten_idx, qcsedten) + qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qcsedten(:ncol,:) + endif + if (qrsedten_idx.gt.0) then + call pbuf_get_field(pbuf, qrsedten_idx, qrsedten) + qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qrsedten(:ncol,:) + endif + if (qisedten_idx.gt.0) then + call pbuf_get_field(pbuf, qisedten_idx, qisedten) + qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qisedten(:ncol,:) + endif + if (qssedten_idx.gt.0) then + call pbuf_get_field(pbuf, qssedten_idx, qssedten) + qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qssedten(:ncol,:) + endif + if (qgsedten_idx.gt.0) then + call pbuf_get_field(pbuf, qgsedten_idx, qgsedten) + qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qgsedten(:ncol,:) + endif + endif +!-tht + end do ! end substepping over macrophysics/microphysics + + call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) + call outfld( 'VTEND_MACROP', ptend_macp_all%v, pcols, lchnk) + call physics_ptend_dealloc(ptend_macp_all) + + prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps + snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps + prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps + snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps + prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) + snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) +!+tht + if (compute_enthalpy_flux) then + qrain_mg_idx = pbuf_get_index('qrain_mg' , errcode=i) + qsnow_mg_idx = pbuf_get_index('qsnow_mg' , errcode=i) + call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) + call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) + qrain_mg(:ncol,:) = qrain_mg_macmic(:ncol,:)/cld_macmic_num_steps + qsnow_mg(:ncol,:) = qsnow_mg_macmic(:ncol,:)/cld_macmic_num_steps + endif +!-tht + endif + + ! Add the precipitation from CARMA to the precipitation from stratiform. + if (carma_do_cldice .or. carma_do_cldliq) then + prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) + snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) + end if + + if ( .not. deep_scheme_does_scav_trans() ) then + + ! ------------------------------------------------------------------------------- + ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. + ! 2. Convective Transport of Non-Water Aerosol Species. + ! + ! . Aerosol wet chemistry determines scavenging fractions, and transformations + ! . Then do convective transport of all trace species except qv,ql,qi. + ! . We needed to do the scavenging first to determine the interstitial fraction. + ! . When UNICON is used as unified convection, we should still perform + ! wet scavenging but not 'convect_deep_tend2'. + ! ------------------------------------------------------------------------------- + + call t_startf('aerosol_wet_processes') + if (clim_modal_aero) then + if (prog_modal_aero) then + call physics_ptend_init(ptend, state%psetcols, 'aero_water_uptake', lq=wetdep_lq) + ! Do calculations of mode radius and water uptake if: + ! 1) modal aerosols are affecting the climate, or + ! 2) prognostic modal aerosols are enabled + call modal_aero_calcsize_sub(state, ptend, ztodt, pbuf) + ! for prognostic modal aerosols the transfer of mass between aitken and accumulation + ! modes is done in conjunction with the dry radius calculation + call modal_aero_wateruptake_dr(state, pbuf) + call physics_update(state, ptend, ztodt, tend) + else + call modal_aero_calcsize_diag(state, pbuf) + call modal_aero_wateruptake_dr(state, pbuf) + endif + endif + + if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) + if ( (trim(cam_take_snapshot_after) == "aero_model_wetdep") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + if (carma_do_wetdep) then + ! CARMA wet deposition + ! + ! NOTE: It needs to follow aero_model_wetdep, so that + ! cam_out%xxxwetxxx + ! fields have already been set for CAM aerosols and cam_out can be + ! added + ! to for CARMA aerosols. + call t_startf ('carma_wetdep_tend') + call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('carma_wetdep_tend') + end if + + call t_startf ('convect_deep_tend2') + call convect_deep_tend_2( state, ptend, ztodt, pbuf ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('convect_deep_tend2') + + ! check tracer integrals + call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) + + call t_stopf('aerosol_wet_processes') + + endif + + !=================================================== + ! Moist physical parameteriztions complete: + ! send dynamical variables, and derived variables to history file + !=================================================== + + call t_startf('bc_history_write') + call diag_phys_writeout(state, pbuf) + call diag_conv(state, ztodt, pbuf) + + call t_stopf('bc_history_write') + + !=================================================== + ! Write cloud diagnostics on history file + !=================================================== + + call t_startf('bc_cld_diag_history_write') + + call cloud_diagnostics_calc(state, pbuf) + + call t_stopf('bc_cld_diag_history_write') + + !=================================================== + ! Radiation computations + !=================================================== + call t_startf('radiation') + + if (trim(cam_take_snapshot_before) == "radiation_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) + + ! Set net flux used by spectral dycores + do i=1,ncol + tend%flx_net(i) = net_flx(i) + end do + + if ( (trim(cam_take_snapshot_after) == "radiation_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "radiation_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call check_energy_cam_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) + + call t_stopf('radiation') + + ! Diagnose the location of the tropopause and its location to the history file(s). + call t_startf('tropopause') + call tropopause_output(state) + call t_stopf('tropopause') + + !=================================================== + ! Source/sink terms for advected tracers. + !=================================================== + call t_startf('adv_tracer_src_snk') + ! Test tracers + + if (trim(cam_take_snapshot_before) == "aoa_tracers_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call aoa_tracers_timestep_tend(state, ptend, ztodt) + if ( (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + if (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & + cam_in%cflx) + + if (trim(cam_take_snapshot_before) == "co2_cycle_set_ptend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call co2_cycle_set_ptend(state, pbuf, ptend) + if ( (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + if (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + !=================================================== + ! Chemistry and MAM calculation + ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. + ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and + ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before + ! Gas chemistry and MAM core aerosol conversion. + ! Note that surface flux is not added into the atmosphere, but elevated emission is + ! added into the atmosphere as tendency. + !=================================================== + if (chem_is_active()) then + + if (trim(cam_take_snapshot_before) == "chem_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & + pbuf, fh2o=fh2o) + + + if ( (trim(cam_take_snapshot_after) == "chem_timestep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "chem_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call check_energy_cam_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) + call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & + cam_in%cflx) + end if + call t_stopf('adv_tracer_src_snk') + + !=================================================== + ! Vertical diffusion/pbl calculation + ! Call vertical diffusion (apply tracer emissions, molecular diffusion and pbl form drag) + !=================================================== + + call t_startf('vertical_diffusion_tend') + + if (trim(cam_take_snapshot_before) == "vertical_diffusion_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call vertical_diffusion_tend (ztodt ,state , cam_in, & + surfric ,obklen ,ptend ,ast ,pbuf ) + + !------------------------------------------ + ! Call major diffusion for extended model + !------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_tend (ztodt ,state ,ptend) + endif + + if ( (trim(cam_take_snapshot_after) == "vertical_diffusion_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_VDIFF', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_VDIFF', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "vertical_diffusion_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call t_stopf ('vertical_diffusion_tend') + + !=================================================== + ! Rayleigh friction calculation + !=================================================== + call t_startf('rayleigh_friction') + call rayleigh_friction_tend( ztodt, state, ptend) + if ( ptend%lu ) then + call outfld( 'UTEND_RAYLEIGH', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_RAYLEIGH', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + call t_stopf('rayleigh_friction') + + if (do_clubb_sgs) then + call check_energy_cam_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) + else + call check_energy_cam_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & + zero, cam_in%shf) + endif + + call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) + + ! aerosol dry deposition processes + call t_startf('aero_drydep') + + if (trim(cam_take_snapshot_before) == "aero_model_drydep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) + if ( (trim(cam_take_snapshot_after) == "aero_model_drydep") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "aero_model_drydep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call t_stopf('aero_drydep') + + ! CARMA microphysics + ! + ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing + ! the dry + ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, + ! so that + ! obklen and surfric have been calculated. It needs to follow + ! aero_model_drydep, so + ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and + ! cam_out + ! can be added to for CARMA aerosols. + if (carma_do_aerosol) then + call t_startf('carma_timestep_tend') + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) + call physics_update(state, ptend, ztodt, tend) + + call check_energy_cam_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) + call t_stopf('carma_timestep_tend') + end if + + !--------------------------------------------------------------------------------- + ! ... enforce charge neutrality + !--------------------------------------------------------------------------------- + call charge_balance(state, pbuf) + + !=================================================== + ! Gravity wave drag + !=================================================== + call t_startf('gw_tend') + + if (trim(cam_take_snapshot_before) == "gw_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) + + if ( (trim(cam_take_snapshot_after) == "gw_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_GWDTOT', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_GWDTOT', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "gw_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + ! Check energy integrals + call check_energy_cam_chng(state, tend, "gwdrag", nstep, ztodt, zero, & + zero, zero, flx_heat) + call t_stopf('gw_tend') + + ! QBO relaxation + + if (trim(cam_take_snapshot_before) == "qbo_relax") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + call qbo_relax(state, pbuf, ptend) + if ( (trim(cam_take_snapshot_after) == "qbo_relax") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_QBORLX', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_QBORLX', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "qbo_relax") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + ! Check energy integrals + call check_energy_cam_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) + + ! Lunar tides + call lunar_tides_tend( state, ptend ) + if ( ptend%lu ) then + call outfld( 'UTEND_LUNART', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_LUNART', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_cam_chng(state, tend, "lunar_tides", nstep, ztodt, zero, zero, zero, zero) + + ! Ion drag calculation + call t_startf ( 'iondrag' ) + + if (trim(cam_take_snapshot_before) == "iondrag_calc_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + + if ( do_waccm_ions ) then + call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) + else + call iondrag_calc( lchnk, ncol, state, ptend) + endif + !---------------------------------------------------------------------------- + ! Call ionosphere routines for extended model if mode is set to ionosphere + !---------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) + endif + + if ( (trim(cam_take_snapshot_after) == "iondrag_calc_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_IONDRG', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_IONDRG', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "iondrag_calc_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call tot_energy_phys(state, 'phAP') + call tot_energy_phys(state, 'dyAP',vc=vc_dycore) + + !--------------------------------------------------------------------------------- + ! Enforce charge neutrality after O+ change from ionos_tend + !--------------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call charge_balance(state, pbuf) + endif + + ! Check energy integrals + call check_energy_cam_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) + + call t_stopf ( 'iondrag' ) + + ! Update Nudging values, if needed + !---------------------------------- + if((Nudge_Model).and.(Nudge_ON)) then + call nudging_timestep_tend(state,ptend) + if ( ptend%lu ) then + call outfld( 'UTEND_NDG', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_NDG', ptend%v, pcols, lchnk) + end if + call physics_update(state,ptend,ztodt,tend) + call check_energy_cam_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) + endif + + if (compute_enthalpy_flux) then +!+tht + ! conserve energy + if (.not.dycore_is('SE')) then + call endrun("Explicit enthalpy flux functionality only supported for SE dycore") + end if + call enthalpy_adjustment(ncol,lchnk,state,cam_in,cam_out,pbuf,ztodt,itim_old,& + qini(:,:),totliqini(:,:),toticeini(:,:),tend) + else + ! standard CAM (violate energy conservation) +!-tht + !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + ! Save total energy for global fixer in next timestep + ! + ! This call must be after the last parameterization and call to physics_update + ! + call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) + ! + ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust + ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. + moist_mixing_ratio_dycore = dycore_is('LR').or. dycore_is('FV3') + ! + ! update cp/cv for energy computation based in updated water variables + ! + call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore,& + to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + + ! for dry mixing ratio dycore, physics_dme_adjust is called for energy diagnostic purposes only. + ! So, save off tracers + if (.not.moist_mixing_ratio_dycore) then + ! + ! for dry-mixing ratio based dycores dme_adjust takes place in the dynamical core + ! + ! only compute dme_adjust for diagnostics purposes + ! + if (thermo_budget_history) then + tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) + tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) + tmp_ps(:ncol) = state%ps(:ncol) + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + ! Restore pre-"physics_dme_adjust" tracers + state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) + state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) + state%ps(:ncol) = tmp_ps(:ncol) + end if + else + ! + ! for moist-mixing ratio based dycores + ! + ! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call + ! + call set_dry_to_wet(state, convert_cnst_type='dry') + + if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) + if (trim(cam_take_snapshot_after) == "physics_dme_adjust") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + endif + + if (vc_dycore == vc_height.or.vc_dycore == vc_dry_pressure) then + ! + ! MPAS and SE specific scaling of temperature for enforcing energy consistency + ! (and to make sure that temperature dependent diagnostic tendencies + ! are computed correctly; e.g. dtcore) + ! + scaling(1:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv_dycore(:ncol,:,lchnk) + state%T(1:ncol,:) = state%temp_ini(1:ncol,:)+& + scaling(1:ncol,:)*(state%T(1:ncol,:)-state%temp_ini(1:ncol,:)) + tend%dtdt(:ncol,:) = scaling(:ncol,:)*tend%dtdt(:ncol,:) + ! + ! else: do nothing for dycores with energy consistent with CAM physics + ! + endif + endif + + + ! store T, U, and V in buffer for use in computing dynamics T-tendency in next timestep + do k = 1,pver + dtcore(:ncol,k) = state%t(:ncol,k) + dqcore(:ncol,k) = state%q(:ncol,k,ixq) + ducore(:ncol,k) = state%u(:ncol,k) + dvcore(:ncol,k) = state%v(:ncol,k) + end do + + !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (aqua_planet) then + labort = .false. + do i=1,ncol + if (cam_in%ocnfrac(i) /= 1._r8) then + labort = .true. + if (masterproc) write(iulog,*) 'oceanfrac(',i,')=',cam_in%ocnfrac(i) + end if + end do + if (labort) then + call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') + endif + endif + + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, qini, cldliqini, cldiceini) + + call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) + + end subroutine tphysac + + subroutine tphysbc (ztodt, state, & + tend, pbuf, & + cam_out, cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Evaluate and apply physical processes that are calculated BEFORE + ! coupling to land, sea, and ice models. + ! + ! Processes currently included are: + ! + ! o Resetting Negative Tracers to Positive + ! o Global Mean Total Energy Fixer + ! o Dry Adjustment + ! o Asymmetric Turbulence Scheme - Deep Convection & Shallow Convection + ! + ! Method: + ! + ! Each parameterization should be implemented with this sequence of calls: + ! 1) Call physics interface + ! 2) Check energy + ! 3) Call physics_update + ! See Interface to Column Physics and Chemistry Packages + ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html + ! + !----------------------------------------------------------------------- + + use physics_buffer, only: physics_buffer_desc, pbuf_get_field + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx + use physics_buffer, only: col_type_subcol, dyn_time_lvls + + use dadadj_cam, only: dadadj_tend + use physics_types, only: physics_update, & + physics_state_check, & + dyn_te_idx + use physconst, only: rair, gravit + use cam_diagnostics, only: diag_conv_tend_ini, diag_export, diag_state_b4_phys_write + use cam_diagnostic_utils, only: cpslec + use cam_history, only: outfld + use constituents, only: qmin + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx +!+tht + use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars, cp_or_cv_dycore + use physics_buffer, only: pbuf_set_field +!-tht + use convect_deep, only: convect_deep_tend + use time_manager, only: is_first_step, get_nstep + use convect_diagnostics,only: convect_diagnostics_calc + use check_energy, only: check_energy_cam_chng, check_energy_cam_fix + use check_energy, only: check_tracers_data, check_tracers_init + use check_energy, only: tot_energy_phys + use dycore, only: dycore_is + use radiation, only: radiation_tend + use perf_mod + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_adj + use cam_abortutils, only: endrun + use subcol_utils, only: is_subcol_on + use qneg_module, only: qneg3 + use cam_snapshot, only: cam_snapshot_all_outfld_tphysbc + use cam_snapshot_common, only: cam_snapshot_ptend_outfld + use dyn_tests_utils, only: vc_dycore + use surface_emissions_mod,only: surface_emissions_set + use elevated_emissions_mod,only: elevated_emissions_set +!+pel + use air_composition, only: te_init,cpairv,compute_enthalpy_flux !xxx + use cam_thermo, only: get_hydrostatic_energy !xxx +!-pel + ! Arguments + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + + + ! + !---------------------------Local workspace----------------------------- + ! + + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + + integer :: nstep ! current timestep number + + real(r8) :: net_flx(pcols) + + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) rtdt ! 1./ztodt + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + integer :: m, m_cnst + + ! physics buffer fields to compute tendencies for stratiform package + integer itim_old, ifld + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction + + ! physics buffer fields for total energy and mass adjustment + real(r8), pointer, dimension(: ) :: teout + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: totliqini + real(r8), pointer, dimension(:,:) :: toticeini + real(r8), pointer, dimension(:,:) :: dtcore + real(r8), pointer, dimension(:,:) :: dqcore + real(r8), pointer, dimension(:,:) :: ducore + real(r8), pointer, dimension(:,:) :: dvcore + + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid + + ! convective precipitation variables + real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8),pointer :: snow_dp(:) ! snow from ZM convection + real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8),pointer :: snow_sh(:) ! snow from Hack convection + + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + + ! energy checking variables + real(r8) :: zero(pcols) ! array of zeros + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: flx_cnd(pcols) + real(r8) :: flx_heat(pcols) + type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes + real(r8) :: zero_tracers(pcols,pcnst) + + real(r8), pointer :: psl(:) ! Sea Level Pressure + + logical :: lq(pcnst) + + !----------------------------------------------------------------------- + + call t_startf('bc_init') + + zero = 0._r8 + zero_tracers(:,:) = 0._r8 + zero_sc(:) = 0._r8 + + lchnk = state%lchnk + ncol = state%ncol + + rtdt = 1._r8/ztodt + + nstep = get_nstep() + + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) + + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) + call pbuf_get_field(pbuf, totliqini_idx, totliqini) + call pbuf_get_field(pbuf, toticeini_idx, toticeini) + + call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + ifld = pbuf_get_index('FRACIS') + call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + fracis (:ncol,:,1:pcnst) = 1._r8 + + ! Set physics tendencies to 0 + tend%dTdt(:ncol,:pver) = 0._r8 + tend%dudt(:ncol,:pver) = 0._r8 + tend%dvdt(:ncol,:pver) = 0._r8 + + ! Verify state coming from the dynamics + if (state_debug_checks) then + call physics_state_check(state, name="before tphysbc (dycore?)") + end if + + call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) + + ! Since clybry_fam_adj operates directly on the tracers, and has no + ! physics_update call, re-run qneg3. + call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,state%q ) + + ! Validate output of clybry_fam_adj. + if (state_debug_checks) then + call physics_state_check(state, name="clybry_fam_adj") + end if + ! + ! Dump out "before physics" state + ! + call diag_state_b4_phys_write (state) + + ! compute mass integrals of input tracers state + call check_tracers_init(state, tracerint) + + call t_stopf('bc_init') + + call cnst_get_ind('Q', ixq) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + qini (:ncol,:pver) = state%q(:ncol,:pver, ixq) + cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + + totliqini(:ncol,:pver) = 0.0_r8 + do m_cnst=1,thermodynamic_active_species_liq_num + m = thermodynamic_active_species_liq_idx(m_cnst) + totliqini(:ncol,:pver) = totliqini(:ncol,:pver)+state%q(:ncol,:pver,m) + end do + toticeini(:ncol,:pver) = 0.0_r8 + do m_cnst=1,thermodynamic_active_species_ice_num + m = thermodynamic_active_species_ice_idx(m_cnst) + toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) + end do +!+pel + ! compute energy variables for state at the beginning of physics - xxx + if (compute_enthalpy_flux) then + call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & + state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & + state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& + vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & + te = te_init(:ncol,1,lchnk), se=te_init(:ncol,2,lchnk), po=te_init(:ncol,3,lchnk), ke=te_init(:ncol,4,lchnk)) + endif +!-pel + +!+tht (postponed call to fixer) + !=================================================== + ! Global mean total energy fixer + !=================================================== + + call t_startf('energy_fixer') + + call tot_energy_phys(state, 'phBF') + call tot_energy_phys(state, 'dyBF',vc=vc_dycore) + + if (.not.dycore_is('EUL')) then + call check_energy_cam_fix(state, ptend, nstep, flx_heat) + call physics_update(state, ptend, ztodt, tend) + call check_energy_cam_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) + end if + + call tot_energy_phys(state, 'phBP') + call tot_energy_phys(state, 'dyBP',vc=vc_dycore) + ! Save state for convective tendency calculations. + call diag_conv_tend_ini(state, pbuf) +!-tht + + call outfld('TEOUT', teout , pcols, lchnk ) + call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) + call outfld('TEFIX', state%te_cur(:,dyn_te_idx), pcols, lchnk ) + + ! T, U, V tendency due to dynamics + if ( nstep > dyn_time_lvls-1 ) then + dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt + dqcore(:ncol,:pver) = (state%q(:ncol,:pver,ixq) - dqcore(:ncol,:pver))/ztodt + ducore(:ncol,:pver) = (state%u(:ncol,:pver) - ducore(:ncol,:pver))/ztodt + dvcore(:ncol,:pver) = (state%v(:ncol,:pver) - dvcore(:ncol,:pver))/ztodt + call outfld( 'DTCORE', dtcore, pcols, lchnk ) + call outfld( 'DQCORE', dqcore, pcols, lchnk ) + call outfld( 'UTEND_CORE', ducore, pcols, lchnk ) + call outfld( 'VTEND_CORE', dvcore, pcols, lchnk ) + end if + + call t_stopf('energy_fixer') + + call surface_emissions_set( lchnk, ncol, pbuf ) + call elevated_emissions_set( lchnk, ncol, pbuf ) + + ! + !=================================================== + ! Dry adjustment + !=================================================== + call t_startf('dry_adjustment') + + if (trim(cam_take_snapshot_before) == "dadadj_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if + + call dadadj_tend(ztodt, state, ptend) + + if ( (trim(cam_take_snapshot_after) == "dadadj_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "dadadj_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if + + call t_stopf('dry_adjustment') + + !=================================================== + ! Moist convection + !=================================================== + call t_startf('moist_convection') + + call t_startf ('convect_deep_tend') + + if (trim(cam_take_snapshot_before) == "convect_deep_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if + + call convect_deep_tend( & + cmfmc, cmfcme, & + zdu, & + rliq, rice, & + ztodt, & + state, ptend, cam_in%landfrac, pbuf) + + if ( (trim(cam_take_snapshot_after) == "convect_deep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + + if ( ptend%lu ) then + call outfld( 'UTEND_DCONV', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_DCONV', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "convect_deep_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if + + call t_stopf('convect_deep_tend') + + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) + + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + end if + + ! Check energy integrals, including "reserved liquid" + flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) + snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) + call check_energy_cam_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) + snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) + + !=================================================== + ! Compute convect diagnostics + !=================================================== + + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) + else + dlf(:,:) = 0._r8 + end if + + if (trim(cam_take_snapshot_before) == "convect_diagnostics_calc") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if + call convect_diagnostics_calc (ztodt , cmfmc, & + dlf , dlf2 , rliq , rliq2, & + state , pbuf) + if ( (trim(cam_take_snapshot_after) == "convect_diagnostics_calc") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + + ! add reserve liquid to pbuf + call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) + rliqbc(:ncol) = rliq(:ncol) + + call t_stopf('moist_convection') + + if (is_first_step()) then + + !initiailize sedimentation arrays + prec_pcw = 0._r8 + snow_pcw = 0._r8 + prec_sed = 0._r8 + snow_sed = 0._r8 + prec_str = 0._r8 + snow_str = 0._r8 + +!+pel + ! In first time-step tphysac variables need to be zero'd out + if (compute_enthalpy_flux) then + ifld = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) + if (ifld>0) call pbuf_set_field(pbuf, ifld, 0._r8) + end if +!-pel + + if (is_subcol_on()) then + prec_str_sc = 0._r8 + snow_str_sc = 0._r8 + end if + + ! OSLO_AERO begin + !=================================================== + ! Run wet deposition routines to intialize aerosols + ! NOT CALLED IN OSLO AERO + !=================================================== + ! OSLO_AERO end + + !=================================================== + ! Radiation computations + ! initialize fluxes only, do not update state + !=================================================== + + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) + + end if + + ! Save atmospheric fields to force surface models + call t_startf('cam_export') + call pbuf_get_field(pbuf, psl_idx, psl) + call cpslec(ncol, state%pmid, state%phis, state%ps, state%t, psl, gravit, rair) + call cam_export (state,cam_in,cam_out,pbuf) + call t_stopf('cam_export') + + ! Write export state to history file + call t_startf('diag_export') + call diag_export(cam_out) + call t_stopf('diag_export') + + ! output these here -- after updates by chem_timestep_tend or export_fields within the current time step + if (associated(cam_out%nhx_nitrogen_flx)) then + call outfld('a2x_NHXDEP', cam_out%nhx_nitrogen_flx, pcols, lchnk) + end if + if (associated(cam_out%noy_nitrogen_flx)) then + call outfld('a2x_NOYDEP', cam_out%noy_nitrogen_flx, pcols, lchnk) + end if + + end subroutine tphysbc + +subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) +!----------------------------------------------------------------------------------- +! +! Purpose: The place for parameterizations to call per timestep initializations. +! Generally this is used to update time interpolated fields from boundary +! datasets. +! +!----------------------------------------------------------------------------------- + use chemistry, only: chem_timestep_init + use chem_surfvals, only: chem_surfvals_set + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc + use carma_intr, only: carma_timestep_init + use ghg_data, only: ghg_data_timestep_init + use aoa_tracers, only: aoa_tracers_timestep_init + use vertical_diffusion, only: vertical_diffusion_ts_init + use radheat, only: radheat_timestep_init + use solar_data, only: solar_data_advance + use qbo, only: qbo_timestep_init + use iondrag, only: do_waccm_ions, iondrag_timestep_init + use perf_mod + + use prescribed_ozone, only: prescribed_ozone_adv + use prescribed_ghg, only: prescribed_ghg_adv + use prescribed_aero, only: prescribed_aero_adv + use aerodep_flx, only: aerodep_flx_adv + use aircraft_emit, only: aircraft_emit_adv + use prescribed_volcaero, only: prescribed_volcaero_adv + use prescribed_strataero,only: prescribed_strataero_adv + use mo_apex, only: mo_apex_init + use epp_ionization, only: epp_ionization_active + use iop_forcing, only: scam_use_iop_srf + use nudging, only: Nudge_Model, nudging_timestep_init + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_timestep_init + use phys_grid_ctem, only: phys_grid_ctem_diags + use surface_emissions_mod,only: surface_emissions_adv + use elevated_emissions_mod,only: elevated_emissions_adv + ! OSLO_AERO begin + use oslo_aero_ocean, only: oslo_aero_ocean_adv + ! OSLO_AERO end + + implicit none + + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + !----------------------------------------------------------------------------- + + if (single_column) call scam_use_iop_srf(cam_in) + + ! update geomagnetic coordinates + if (epp_ionization_active .or. do_waccm_ions) then + call mo_apex_init(phys_state) + endif + + ! Chemistry surface values + call chem_surfvals_set() + call surface_emissions_adv(pbuf2d, phys_state) + call elevated_emissions_adv(pbuf2d, phys_state) + + ! Solar irradiance + call solar_data_advance() + + ! Time interpolate for chemistry. + call chem_timestep_init(phys_state, pbuf2d) + + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_timestep_init(phys_state,pbuf2d) + endif + + ! Prescribed tracers + call prescribed_ozone_adv(phys_state, pbuf2d) + call prescribed_ghg_adv(phys_state, pbuf2d) + call prescribed_aero_adv(phys_state, pbuf2d) + call aircraft_emit_adv(phys_state, pbuf2d) + call prescribed_volcaero_adv(phys_state, pbuf2d) + call prescribed_strataero_adv(phys_state, pbuf2d) + ! OSLO_AERO begin + call oslo_aero_ocean_adv(phys_state, pbuf2d) + ! OSLO_AERO end + + ! prescribed aerosol deposition fluxes + call aerodep_flx_adv(phys_state, pbuf2d, cam_out) + + ! Time interpolate data models of gasses in pbuf2d + call ghg_data_timestep_init(pbuf2d, phys_state) + + ! Upper atmosphere radiative processes + call radheat_timestep_init(phys_state, pbuf2d) + + ! Time interpolate for vertical diffusion upper boundary condition + call vertical_diffusion_ts_init(pbuf2d, phys_state) + + !---------------------------------------------------------------------- + ! update QBO data for this time step + !---------------------------------------------------------------------- + call qbo_timestep_init + + call iondrag_timestep_init() + + call carma_timestep_init() + + ! age of air tracers + call aoa_tracers_timestep_init(phys_state) + + ! Update Nudging values, if needed + !---------------------------------- + if(Nudge_Model) call nudging_timestep_init(phys_state) + + ! Update TEM diagnostics + call phys_grid_ctem_diags(phys_state) + +end subroutine phys_timestep_init + +end module physpkg diff --git a/src/physics/camnor_phys/physics/qneg_module.F90 b/src/physics/camnor_phys/physics/qneg_module.F90 new file mode 100644 index 0000000000..98b51e71f6 --- /dev/null +++ b/src/physics/camnor_phys/physics/qneg_module.F90 @@ -0,0 +1,493 @@ +module qneg_module + + use shr_kind_mod, only: r8 => shr_kind_r8, CS => SHR_KIND_CS + use perf_mod, only: t_startf, t_stopf + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use shr_sys_mod, only: shr_sys_flush + use cam_history_support, only: max_fieldname_len + use ppgrid, only: pcols + use constituents, only: pcnst, cnst_name + + implicit none + private + save + + ! Public interface. + + public :: qneg_readnl + public :: qneg_init + public :: qneg3 + public :: qneg4 + public :: qneg_print_summary + + ! Private module variables + character(len=8) :: print_qneg_warn + logical :: log_warnings = .false. + logical :: collect_stats = .false. + logical :: timestep_reset = .false. + + real(r8), parameter :: tol = 1.e-12_r8 + real(r8), parameter :: worst_reset = 1.e35_r8 + + ! Diagnostic field names + integer, parameter :: num_diag_fields = (2 * pcnst) + 1 + character(len=max_fieldname_len) :: diag_names(num_diag_fields) + logical :: cnst_out_calc = .false. + logical :: cnst_outfld(num_diag_fields) = .false. + + ! Summary buffers + integer, parameter :: num3_bins = 24 + integer, parameter :: num4_bins = 4 + character(len=CS) :: qneg3_warn_labels(num3_bins) = '' + character(len=CS) :: qneg4_warn_labels(num4_bins) = '' + integer :: qneg3_warn_num(pcnst, num3_bins) = 0 + integer :: qneg4_warn_num(num4_bins) = 0 + real(r8) :: qneg3_warn_worst(pcnst, num3_bins) = worst_reset + real(r8) :: qneg4_warn_worst(num4_bins) = worst_reset + + private :: calc_cnst_out + private :: find_index3 + private :: find_index4 + interface reset_stats + module procedure reset_stats_scalar + module procedure reset_stats_array + end interface reset_stats + +contains + + subroutine qneg_readnl(nlfile) + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_character, masterproc + ! File containing namelist input. + character(len=*), intent(in) :: nlfile + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: sub = 'qneg_readnl' + + namelist /qneg_nl/ print_qneg_warn + + print_qneg_warn = '' + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'qneg_nl', status=ierr) + if (ierr == 0) then + read(unitn, qneg_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist qneg_nl') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(print_qneg_warn, len(print_qneg_warn), mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: print_qneg_warn") + + select case(trim(print_qneg_warn)) + case('summary') + collect_stats = .true. + timestep_reset = .false. + case('timestep') + collect_stats = .true. + timestep_reset = .true. + case('off') + collect_stats = .false. + timestep_reset = .false. + case default + call endrun(sub//" FATAL: '"//trim(print_qneg_warn)//"' is not a valid value for print_qneg_warn") + end select + + if (masterproc) then + if (collect_stats) then + if (timestep_reset) then + write(iulog, *) sub, ": QNEG statistics will be collected and printed for each timestep" + else + write(iulog, *) sub, ": QNEG statistics will be collected and printed at the end of the run" + end if + else + write(iulog, *) sub, ": QNEG statistics will not be collected" + end if + end if + + end subroutine qneg_readnl + + subroutine qneg_init() + use cam_history, only: addfld, horiz_only + use constituents, only: cnst_longname + + integer :: index + + do index = 1, pcnst + diag_names(index) = trim(cnst_name(index))//'_qneg3' + call addfld(diag_names(index), (/ 'lev' /), 'I', 'kg/kg', & + trim(cnst_longname(index))//' QNEG3 error (cell)') + diag_names(pcnst+index) = trim(cnst_name(index))//'_qneg3_col' + call addfld(diag_names(pcnst+index), horiz_only, 'I', 'kg/kg', & + trim(cnst_longname(index))//' QNEG3 error (column)') + end do + diag_names((2*pcnst) + 1) = 'qflux_exceeded' + call addfld(diag_names((2*pcnst) + 1), horiz_only, 'I', 'kg/m^2/s', & + 'qflux excess (QNEG4)') + + end subroutine qneg_init + + subroutine calc_cnst_out() + use cam_history, only: hist_fld_active, history_initialized + integer :: index + + if (history_initialized()) then + ! to protect against routines that call qneg3 too early + do index = 1, num_diag_fields + cnst_outfld(index) = hist_fld_active(trim(diag_names(index))) + end do + cnst_out_calc = .true. + end if + + end subroutine calc_cnst_out + + integer function find_index3(nam) result(index) + ! Find a valid or new index for 'nam' entries + character(len=*), intent(in) :: nam + + integer :: i + + index = -1 + do i = 1, num3_bins + if (trim(nam) == trim(qneg3_warn_labels(i))) then + ! We found this entry, return its index + index = i + exit + else if (len_trim(qneg3_warn_labels(i)) == 0) then + ! We have run out of known entries, use a new one and reset its stats + qneg3_warn_labels(i) = nam + index = i + call reset_stats(qneg3_warn_num(:, index), qneg3_warn_worst(:,index)) + exit + end if + end do + end function find_index3 + + integer function find_index4(nam) result(index) + ! Find a valid or new index for 'nam' entries + character(len=*), intent(in) :: nam + + integer :: i + + index = -1 + do i = 1, num4_bins + if (trim(nam) == trim(qneg4_warn_labels(i))) then + ! We found this entry, return its index + index = i + exit + else if (len_trim(qneg4_warn_labels(i)) == 0) then + ! We have run out of known entries, use a new one and reset its stats + qneg4_warn_labels(i) = nam + index = i + call reset_stats(qneg4_warn_num(index), qneg4_warn_worst(index)) + exit + end if + end do + end function find_index4 + + subroutine qneg3 (subnam, idx, ncol, ncold, lver, lconst_beg, & + lconst_end, qmin, q) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Check moisture and tracers for minimum value, reset any below + ! minimum value to minimum value and return information to allow + ! warning message to be printed. The global average is NOT preserved. + ! + ! Method: + ! + ! + ! + ! Author: J. Rosinski + ! + !----------------------------------------------------------------------- + use cam_history, only: outfld + + !------------------------------Arguments-------------------------------- + ! + ! Input arguments + ! + character(len=*), intent(in) :: subnam ! name of calling routine + + integer, intent(in) :: idx ! chunk/latitude index + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: ncold ! declared number of atmospheric columns + integer, intent(in) :: lver ! number of vertical levels in column + integer, intent(in) :: lconst_beg ! beginning constituent + integer, intent(in) :: lconst_end ! ending constituent + + real(r8), intent(in) :: qmin(lconst_beg:lconst_end) ! Global minimum constituent concentration + + ! + ! Input/Output arguments + ! + real(r8), intent(inout) :: q(ncold,lver,lconst_beg:lconst_end) ! moisture/tracer field + ! + !---------------------------Local workspace----------------------------- + ! + integer :: nvals ! number of values found < qmin + integer :: i, k ! longitude, level indices + integer :: index ! For storing stats + integer :: m ! constituent index + integer :: iw,kw ! i,k indices of worst violator + + logical :: found ! true => at least 1 minimum violator found + + real(r8) :: badvals(ncold, lver) ! Collector for outfld calls + real(r8) :: badcols(ncold) ! Column sum for outfld + real(r8) :: worst ! biggest violator + ! + !----------------------------------------------------------------------- + ! + + call t_startf ('qneg3') + ! The first time we call this, we need to determine whether to call outfld + if (.not. cnst_out_calc) then + call calc_cnst_out() + end if + + if (collect_stats) then + index = find_index3(trim(subnam)) + else + index = -1 + end if + + do m = lconst_beg, lconst_end + nvals = 0 + found = .false. + worst = worst_reset + badvals(:,:) = 0.0_r8 + iw = -1 + kw = -1 + ! + ! Test all field values for being less than minimum value. Set q = qmin + ! for all such points. Trace offenders and identify worst one. + ! + do k = 1, lver + do i = 1, ncol + if (q(i,k,m) < qmin(m)) then + found = .true. + nvals = nvals + 1 + badvals(i, k) = q(i, k, m) + if (index > 0) then + qneg3_warn_num(m, index) = qneg3_warn_num(m, index) + 1 + end if + if (q(i,k,m) < worst) then + worst = q(i,k,m) + iw = i + kw = k + if (index > 0) then + qneg3_warn_worst(m, index) = worst + end if + end if + q(i,k,m) = qmin(m) + end if + end do + end do + ! Maybe output bad values + if ((cnst_outfld(m)) .and. (worst < worst_reset)) then + call outfld(trim(diag_names(m)), badvals, pcols, idx) + end if + if ((cnst_outfld(pcnst+m)) .and. (worst < worst_reset)) then + do i = 1, pcols + badcols(i) = SUM(badvals(i,:)) + end do + call outfld(trim(diag_names(pcnst+m)), badcols, pcols, idx) + end if + end do + call t_stopf ('qneg3') + + end subroutine qneg3 + + subroutine qneg4 (subnam, lchnk, ncol, ztodt, & + !qbot, srfrpdel, shflx, lhflx, qflx) + qbot, srfrpdel, seflx, shflx, lhflx, qflx)!+tht + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Check if moisture flux into the ground is exceeding the total + ! moisture content of the lowest model layer (creating negative moisture + ! values). If so, then subtract the excess from the moisture and + ! latent heat fluxes and add it to the sensible heat flux. + ! + ! Method: + ! + ! + ! + ! Author: J. Olson + ! + !----------------------------------------------------------------------- + use physconst, only: gravit, latvap, latice !+tht + use constituents, only: qmin + use cam_history, only: outfld + + ! + ! Input arguments + ! + character(len=*), intent(in) :: subnam ! name of calling routine + ! + integer, intent(in) :: lchnk ! chunk index + integer, intent(in) :: ncol ! number of atmospheric columns + ! + real(r8), intent(in) :: ztodt ! two times model timestep (2 delta-t) + real(r8), intent(in) :: qbot(ncol,pcnst) ! moisture at lowest model level + real(r8), intent(in) :: srfrpdel(ncol) ! 1./(pint(K+1)-pint(K)) + ! + ! Input/Output arguments + ! + real(r8), intent(inout) :: seflx(ncol) !+tht: heat flux for energy checker (ice ref.state) + real(r8), intent(inout) :: shflx(ncol) ! Surface sensible heat flux (J/m2/s) + real(r8), intent(inout) :: lhflx(ncol) ! Surface latent heat flux (J/m2/s) + real(r8), intent(inout) :: qflx (ncol,pcnst) ! surface water flux (kg/m^2/s) + ! + !---------------------------Local workspace----------------------------- + ! + integer :: i ! column index + integer :: iw ! i index of worst violator + integer :: index ! caller bin index + ! + real(r8):: worst ! biggest violator + real(r8):: excess(ncol) ! Excess downward sfc latent heat flux + ! + !----------------------------------------------------------------------- + + call t_startf ('qneg4') + ! The first time we call this, we need to determine whether to call outfld + if (.not. cnst_out_calc) then + call calc_cnst_out() + end if + + if (collect_stats) then + index = find_index4(trim(subnam)) + else + index = -1 + end if + + ! + ! Compute excess downward (negative) q flux compared to a theoretical + ! maximum downward q flux. The theoretical max is based upon the + ! given moisture content of lowest level of the model atmosphere. + ! + worst = worst_reset + do i = 1, ncol + excess(i) = qflx(i,1) - (qmin(1) - qbot(i,1))/(ztodt*gravit*srfrpdel(i)) + ! + ! If there is an excess downward (negative) q flux, then subtract + ! excess from "qflx" and "lhflx" and add to "shflx". + ! + if (excess(i) < 0._r8) then + if (excess(i) < worst) then + iw = i + worst = excess(i) + end if + qflx (i,1) = qflx (i,1) - excess(i) + lhflx(i) = lhflx(i) - excess(i)*latvap + shflx(i) = shflx(i) + excess(i)*latvap + seflx(i) = seflx(i) + excess(i)*(latvap+latice) !+tht + if (index > 0) then + qneg4_warn_num(index) = qneg4_warn_num(index) + 1 + end if + end if + end do + ! Maybe output bad values + if ((cnst_outfld((2*pcnst)+1)) .and. (worst < worst_reset)) then + do i = 1, ncol + if (excess(i) > 0.0_r8) then + excess(i) = 0.0_r8 + end if + end do + call outfld(trim(diag_names((2*pcnst)+1)), excess(1:ncol), ncol, lchnk) + end if + call t_stopf ('qneg4') + + end subroutine qneg4 + + subroutine qneg_print_summary(end_of_run) + use spmd_utils, only: mpicom, masterprocid, masterproc + use spmd_utils, only: MPI_MIN, MPI_SUM, MPI_INTEGER, MPI_REAL8 + + logical, intent(in) :: end_of_run + + integer :: global_warn_num(pcnst) + real(r8) :: global_warn_worst(pcnst) + integer :: index, m + integer :: ierr + + if (collect_stats) then + if (timestep_reset .or. end_of_run) then + do index = 1, num3_bins + ! QNEG3 + call reset_stats(global_warn_num(:), global_warn_worst(:)) + call MPI_REDUCE(qneg3_warn_num(:, index), global_warn_num(:), & + pcnst, MPI_INTEGER, MPI_SUM, masterprocid, mpicom, ierr) + call MPI_REDUCE(qneg3_warn_worst(:, index), global_warn_worst(:),& + pcnst, MPI_REAL8, MPI_MIN, masterprocid, mpicom, ierr) + if (masterproc) then + do m = 1, pcnst + if ( (global_warn_num(m) > 0) .and. & + (abs(global_warn_worst(m)) > tol)) then + write(iulog, 9100) trim(qneg3_warn_labels(index)), & + trim(cnst_name(m)), global_warn_num(m), & + global_warn_worst(m) + end if + call shr_sys_flush(iulog) + end do + end if + call reset_stats(qneg3_warn_num(:,index), qneg3_warn_worst(:,index)) + end do + do index = 1, num4_bins + ! QNEG4 + call reset_stats(qneg4_warn_num(index), qneg4_warn_worst(index)) + call reset_stats(global_warn_num(1), global_warn_worst(1)) + call MPI_REDUCE(qneg4_warn_num(index), global_warn_num(1), & + 1, MPI_INTEGER, MPI_SUM, masterprocid, mpicom, ierr) + call MPI_REDUCE(qneg4_warn_worst(index), global_warn_worst(1), & + 1, MPI_REAL8, MPI_MIN, masterprocid, mpicom, ierr) + if (masterproc) then + if ( (global_warn_num(1) > 0) .and. & + (abs(global_warn_worst(1)) > tol)) then + write(iulog, 9101) trim(qneg4_warn_labels(index)), & + global_warn_num(1), global_warn_worst(1) + end if + call shr_sys_flush(iulog) + end if + call reset_stats(qneg4_warn_num(index), qneg4_warn_worst(index)) + end do + end if + end if + + return +9100 format(' QNEG3 from ', a, ':', a, & + ' Min. mixing ratio violated at ', i9, ' points. Worst = ', e10.1) +9101 format(' QNEG4 from ',a,': moisture flux exceeded at', & + i9, ' points. Worst = ', e10.1) + end subroutine qneg_print_summary + + subroutine reset_stats_array(num_array, worst_array) + ! Private routine to reset statistics + integer, intent(inout) :: num_array(:) + real(r8), intent(inout) :: worst_array(:) + + num_array(:) = 0 + worst_array(:) = worst_reset + end subroutine reset_stats_array + + subroutine reset_stats_scalar(num, worst) + ! Private routine to reset statistics + integer, intent(inout) :: num + real(r8), intent(inout) :: worst + + num = 0 + worst = worst_reset + end subroutine reset_stats_scalar + +end module qneg_module diff --git a/src/physics/camnor_phys/physics/zm_conv_evap.F90 b/src/physics/camnor_phys/physics/zm_conv_evap.F90 new file mode 100644 index 0000000000..5e26d80e06 --- /dev/null +++ b/src/physics/camnor_phys/physics/zm_conv_evap.F90 @@ -0,0 +1,262 @@ +module zm_conv_evap + + use ccpp_kinds, only: kind_phys + + implicit none + + save + private ! Make default type private to the module +! +! PUBLIC: interfaces +! + public zm_conv_evap_run ! evaporation of precip from ZM schemea + +contains + + +!=============================================================================== +!> \section arg_table_zm_conv_evap_run Argument Table +!! \htmlinclude zm_conv_evap_run.html +!! +subroutine zm_conv_evap_run(ncol, pver, pverp, & + gravit, latice, latvap, tmelt, & + cpres, ke, ke_lnd, & + t,pmid,pdel,q, & + landfrac, & + tend_s, tend_s_snwprd, tend_s_snwevmlt, tend_q, & + prdprec_gen, cldfrc, deltat, & + prec_gen, snow, ntprprd, ntsnprd, fsnow_conv, flxprec, flxsnow, scheme_name, errmsg, errflg) + +!----------------------------------------------------------------------- +! Compute tendencies due to evaporation of rain from ZM scheme +!-- +! Compute the total precipitation and snow fluxes at the surface. +! Add in the latent heat of fusion for snow formation and melt, since it not dealt with +! in the Zhang-MacFarlane parameterization. +! Evaporate some of the precip directly into the environment using a Sundqvist type algorithm +!----------------------------------------------------------------------- + + use wv_saturation, only: qsat + +!------------------------------Arguments-------------------------------- + integer,intent(in) :: ncol ! number of columns + integer,intent(in) :: pver, pverp + real(kind_phys),intent(in) :: gravit ! gravitational acceleration (m s-2) + real(kind_phys),intent(in) :: latice ! Latent heat of fusion (J kg-1) + real(kind_phys),intent(in) :: latvap ! Latent heat of vaporization (J kg-1) + real(kind_phys),intent(in) :: tmelt ! Freezing point of water (K) + real(kind_phys), intent(in) :: cpres ! specific heat at constant pressure in j/kg-degk. + real(kind_phys), intent(in) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke + real(kind_phys), intent(in) :: ke_lnd + real(kind_phys),intent(in), dimension(:,:) :: t ! temperature (K) (ncol,pver) + real(kind_phys),intent(in), dimension(:,:) :: pmid ! midpoint pressure (Pa) (ncol,pver) + real(kind_phys),intent(in), dimension(:,:) :: pdel ! layer thickness (Pa) (ncol,pver) + real(kind_phys),intent(in), dimension(:,:) :: q ! water vapor (kg/kg) (ncol,pver) + real(kind_phys),intent(in), dimension(:) :: landfrac ! land fraction (ncol) + + real(kind_phys),intent(out), dimension(:,:) :: tend_s ! heating rate (J/kg/s) (ncol,pver) + real(kind_phys),intent(out), dimension(:,:) :: tend_q ! water vapor tendency (kg/kg/s) (ncol,pver) + real(kind_phys),intent(out), dimension(:,:) :: tend_s_snwprd ! Heating rate of snow production (ncol,pver) + real(kind_phys),intent(out), dimension(:,:) :: tend_s_snwevmlt ! Heating rate of evap/melting of snow (ncol,pver) + + real(kind_phys), intent(in ) :: prdprec_gen(:,:)! precipitation production (kg/ks/s) (ncol,pver) + real(kind_phys), intent(in ) :: cldfrc(:,:) ! cloud fraction (ncol,pver) + real(kind_phys), intent(in ) :: deltat ! time step + real(kind_phys), intent(in ) :: fsnow_conv(:,:) ! snow fraction in precip production + + real(kind_phys), intent(inout) :: prec_gen(:) ! Convective-scale preciptn rate (ncol) + real(kind_phys), intent(out) :: snow(:) ! Convective-scale snowfall rate (ncol) + +! +!---------------------------Local storage------------------------------- + real(kind_phys), parameter :: density_fresh_water=1000._kind_phys + + real(kind_phys) :: es (ncol,pver) ! Saturation vapor pressure + real(kind_phys) :: qs (ncol,pver) ! saturation specific humidity + real(kind_phys),intent(out) :: flxprec(:,:) ! Convective-scale flux of precip at interfaces (kg/m2/s) ! (ncol,pverp) + real(kind_phys),intent(out) :: flxsnow(:,:) ! Convective-scale flux of snow at interfaces (kg/m2/s) ! (ncol,pverp) + real(kind_phys),intent(out) :: ntprprd(:,:) ! net precip production in layer ! (ncol,pver) + real(kind_phys),intent(out) :: ntsnprd(:,:) ! net snow production in layer ! (ncol,pver) + + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + character(len=40), intent(out) :: scheme_name + + real(kind_phys) :: work1 ! temp variable (pjr) + real(kind_phys) :: work2 ! temp variable (pjr) + + real(kind_phys) :: evpvint(ncol) ! vertical integral of evaporation + real(kind_phys) :: evpprec(ncol) ! evaporation of precipitation (kg/kg/s) + real(kind_phys) :: evpsnow(ncol) ! evaporation of snowfall (kg/kg/s) + real(kind_phys) :: snowmlt(ncol) ! snow melt tendency in layer + real(kind_phys) :: flxsntm(ncol) ! flux of snow into layer, after melting + + real(kind_phys) :: kemask + real(kind_phys) :: evplimit ! temp variable for evaporation limits + real(kind_phys) :: rlat(ncol) + real(kind_phys) :: dum + real(kind_phys) :: omsm + + integer :: i,k ! longitude,level indices + logical :: old_snow + +logical, parameter:: tht_tweaks=.false. + +!----------------------------------------------------------------------- + scheme_name = "zm_conv_evap_run" + errmsg = '' + errflg = 0 + + old_snow=.true. + +! convert input precip to kg/m2/s + prec_gen(:ncol) = prec_gen(:ncol)* density_fresh_water + +! determine saturation vapor pressure + do k = 1,pver + call qsat(t(1:ncol,k), pmid(1:ncol,k), es(1:ncol,k), qs(1:ncol,k), ncol) + end do + +! zero the flux integrals on the top boundary + flxprec(:ncol,1) = 0._kind_phys + flxsnow(:ncol,1) = 0._kind_phys + evpvint(:ncol) = 0._kind_phys + omsm=0.9999_kind_phys + + do k = 1, pver + do i = 1, ncol + +! Melt snow falling into layer, if necessary. + if( old_snow ) then + if (t(i,k) > tmelt) then + flxsntm(i) = 0._kind_phys + snowmlt(i) = flxsnow(i,k) * gravit/ pdel(i,k) + else + flxsntm(i) = flxsnow(i,k) + snowmlt(i) = 0._kind_phys + end if + else + ! make sure melting snow doesn't reduce temperature below threshold + if (t(i,k) > tmelt) then + dum = -latice/cpres*flxsnow(i,k)*gravit/pdel(i,k)*deltat + if (t(i,k) + dum .le. tmelt) then + dum = (t(i,k)-tmelt)*cpres/latice/deltat + dum = dum/(flxsnow(i,k)*gravit/pdel(i,k)) + dum = max(0._kind_phys,dum) + dum = min(1._kind_phys,dum) + else + dum = 1._kind_phys + end if + dum = dum*omsm + flxsntm(i) = flxsnow(i,k)*(1.0_kind_phys-dum) + snowmlt(i) = dum*flxsnow(i,k)*gravit/ pdel(i,k) + else + flxsntm(i) = flxsnow(i,k) + snowmlt(i) = 0._kind_phys + end if + end if + +! relative humidity depression must be > 0 for evaporation + if (tht_tweaks) then + !tht Q is a mixing ratio, QS a specific humidity: correcting + evplimit = max(1._kind_phys - q(i,k)/(1._kind_phys+q(i,k))/qs(i,k), 0._kind_phys) !+tht + else + evplimit = max(1._kind_phys - q(i,k)/qs(i,k), 0._kind_phys) + endif + if (tht_tweaks) then + !tht: default is inconsistent with use of separate KE and KE_LND parameters + kemask = ke * (1._kind_phys - landfrac(i)) + ke_lnd * landfrac(i) + else + kemask = ke + endif +!-tht + +! total evaporation depends on flux in the top of the layer +! flux prec is the net production above layer minus evaporation into environmet + evpprec(i) = kemask * (1._kind_phys - cldfrc(i,k)) * evplimit * sqrt(flxprec(i,k)) + +! Don't let evaporation supersaturate layer (approx). Layer may already be saturated. +! Currently does not include heating/cooling change to qs + if (tht_tweaks) then + evplimit = max(0._kind_phys, (qs(i,k)-q(i,k)/(1._kind_phys+q(i,k))) / deltat) !+tht + else + evplimit = max(0._kind_phys, (qs(i,k)-q(i,k)) / deltat) + endif + +! Don't evaporate more than is falling into the layer - do not evaporate rain formed +! in this layer but if precip production is negative, remove from the available precip +! Negative precip production occurs because of evaporation in downdrafts. + evplimit = min(evplimit, flxprec(i,k) * gravit / pdel(i,k)) + +! Total evaporation cannot exceed input precipitation + evplimit = min(evplimit, (prec_gen(i) - evpvint(i)) * gravit / pdel(i,k)) + + evpprec(i) = min(evplimit, evpprec(i)) + if( .not.old_snow ) then + evpprec(i) = max(0._kind_phys, evpprec(i)) + evpprec(i) = evpprec(i)*omsm + end if + + +! evaporation of snow depends on snow fraction of total precipitation in the top after melting + if (flxprec(i,k) > 0._kind_phys) then +! prevent roundoff problems + work1 = min(max(0._kind_phys,flxsntm(i)/flxprec(i,k)),1._kind_phys) + evpsnow(i) = evpprec(i) * work1 + else + evpsnow(i) = 0._kind_phys + end if + +! vertically integrated evaporation + evpvint(i) = evpvint(i) + evpprec(i) * pdel(i,k)/gravit + +! net precip production is production - evaporation + ntprprd(i,k) = prdprec_gen(i,k) - evpprec(i) +! net snow production is precip production * ice fraction - evaporation - melting +! the small amount added to flxprec in the work1 expression has been increased from +! 1e-36 to 8.64e-11 (1e-5 mm/day). This causes the temperature based partitioning +! scheme to be used for small flxprec amounts. This is to address error growth problems. + + if( old_snow ) then + if (flxprec(i,k).gt.0._kind_phys) then + work1 = min(max(0._kind_phys,flxsnow(i,k)/flxprec(i,k)),1._kind_phys) + else + work1 = 0._kind_phys + endif + + work2 = max(fsnow_conv(i,k), work1) + if (snowmlt(i).gt.0._kind_phys) work2 = 0._kind_phys + ntsnprd(i,k) = prdprec_gen(i,k)*work2 - evpsnow(i) - snowmlt(i) + tend_s_snwprd (i,k) = prdprec_gen(i,k)*work2*latice + tend_s_snwevmlt(i,k) = - ( evpsnow(i) + snowmlt(i) )*latice + end if + +! precipitation fluxes + flxprec(i,k+1) = flxprec(i,k) + ntprprd(i,k) * pdel(i,k)/gravit + flxsnow(i,k+1) = flxsnow(i,k) + ntsnprd(i,k) * pdel(i,k)/gravit + +! protect against rounding error + flxprec(i,k+1) = max(flxprec(i,k+1), 0._kind_phys) + flxsnow(i,k+1) = max(flxsnow(i,k+1), 0._kind_phys) + +! heating (cooling) and moistening due to evaporation +! - latent heat of vaporization for precip production has already been accounted for +! - snow is contained in prec + if( old_snow ) then + tend_s(i,k) =-evpprec(i)*latvap + ntsnprd(i,k)*latice + else + tend_s(i,k) =-evpprec(i)*latvap + tend_s_snwevmlt(i,k) + end if + tend_q(i,k) = evpprec(i) + end do + end do + +! set output precipitation rates (m/s) +! convert from 'kg m-2 s-1' to 'm s-1' + prec_gen(:ncol) = flxprec(:ncol,pverp) / density_fresh_water + snow(:ncol) = flxsnow(:ncol,pverp) / density_fresh_water + + end subroutine zm_conv_evap_run + + +end module zm_conv_evap diff --git a/src/physics/camnor_phys/physics/zm_conv_intr.F90 b/src/physics/camnor_phys/physics/zm_conv_intr.F90 new file mode 100644 index 0000000000..984e2e348e --- /dev/null +++ b/src/physics/camnor_phys/physics/zm_conv_intr.F90 @@ -0,0 +1,969 @@ +module zm_conv_intr +!--------------------------------------------------------------------------------- +! Purpose: +! +! CAM interface to the Zhang-McFarlane deep convection scheme +! +! Author: D.B. Coleman +! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer +!--------------------------------------------------------------------------------- + use shr_kind_mod, only: r8=>shr_kind_r8 + use physconst, only: cpair, cpliq, cpwv, epsilo, gravit, latvap, tmelt, rair + use ppgrid, only: pver, pcols, pverp, begchunk, endchunk + use zm_conv_evap, only: zm_conv_evap_run + use zm_convr, only: zm_convr_init, zm_convr_run + use zm_conv_convtran, only: zm_conv_convtran_run + use zm_conv_momtran, only: zm_conv_momtran_run + use cloud_fraction_fice, only: cloud_fraction_fice_run + + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & + rad_cnst_get_aer_props, rad_cnst_get_mode_props !, & + use cam_abortutils, only: endrun + use physconst, only: pi + use spmd_utils, only: masterproc + use perf_mod + use cam_logfile, only: iulog + use constituents, only: cnst_add + use ref_pres, only: trop_cloud_top_lev + use phys_control, only: phys_getopts + + implicit none + private + save + + ! Public methods + + public ::& + zm_conv_register, &! register fields in physics buffer + zm_conv_readnl, &! read namelist + zm_conv_init, &! initialize donner_deep module + zm_conv_tend, &! return tendencies + zm_conv_tend_2 ! return tendencies + + public zmconv_ke, zmconv_ke_lnd ! needed by convect_shallow + + integer ::& ! indices for fields in the physics buffer + zm_mu_idx, & + zm_eu_idx, & + zm_du_idx, & + zm_md_idx, & + zm_ed_idx, & + zm_dp_idx, & + zm_dsubcld_idx, & + zm_jt_idx, & + zm_maxg_idx, & + zm_ideep_idx, & + dp_flxprc_idx, & + dp_flxsnw_idx, & + dp_cldliq_idx, & + dp_cldice_idx, & + dlfzm_idx, & ! detrained convective cloud water mixing ratio. + prec_dp_idx, & + snow_dp_idx, & + mconzm_idx ! convective mass flux +!+tht + integer :: dp_ntprp_idx = 0 + integer :: dp_ntsnp_idx = 0 +!-tht + + real(r8), parameter :: unset_r8 = huge(1.0_r8) + real(r8) :: zmconv_c0_lnd = unset_r8 + real(r8) :: zmconv_c0_ocn = unset_r8 + real(r8) :: zmconv_ke = unset_r8 + real(r8) :: zmconv_ke_lnd = unset_r8 + real(r8) :: zmconv_momcu = unset_r8 + real(r8) :: zmconv_momcd = unset_r8 + integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + real(r8) :: zmconv_dmpdz = unset_r8 ! Parcel fractional mass entrainment rate + real(r8) :: zmconv_tiedke_add = unset_r8 ! Convective parcel temperature perturbation + real(r8) :: zmconv_capelmt = unset_r8 ! Triggering thereshold for ZM convection + logical :: zmconv_parcel_pbl = .false. ! switch for parcel pbl calculation + real(r8) :: zmconv_parcel_hscale = unset_r8! Fraction of PBL depth over which to mix initial parcel + real(r8) :: zmconv_tau = unset_r8 ! Timescale for convection +!+tht + real(r8) :: zmconv_tiedke_lnd = unset_r8 + real(r8) :: zmconv_entrmn = 2e-4_r8 + real(r8) :: zmconv_alfadet = 1e-1_r8 + real(r8) :: zmconv_plclmin = 6.e2_r8 + logical :: zmconv_tht_thermo = .false. + logical :: zmconv_retrigger = .false. +!-tht + +! indices for fields in the physics buffer + integer :: cld_idx = 0 + integer :: icwmrdp_idx = 0 + integer :: rprddp_idx = 0 + integer :: fracis_idx = 0 + integer :: nevapr_dpcu_idx = 0 + integer :: dgnum_idx = 0 + + integer :: nmodes + integer :: nbulk + +!========================================================================================= +contains +!========================================================================================= + +subroutine zm_conv_register + +!---------------------------------------- +! Purpose: register fields with the physics buffer +!---------------------------------------- + + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + + implicit none + + integer idx + + call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) + call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) + call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) + call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) + call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) + + ! wg layer thickness in mbs (between upper/lower interface). + call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) + + ! wg layer thickness in mbs between lcl and maxi. + call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) + + ! wg top level index of deep cumulus convection. + call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) + + ! wg gathered values of maxi. + call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) + + ! map gathered points to chunk index + call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) + +! Flux of precipitation from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) +!+tht + call pbuf_add_field('dp_ntprp','physpkg',dtype_r8,(/pcols,pver /),dp_ntprp_idx) + call pbuf_add_field('dp_ntsnp','physpkg',dtype_r8,(/pcols,pver /),dp_ntsnp_idx) +!-tht + +! Flux of snow from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) + + call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) + call pbuf_add_field('RPRDDP', 'physpkg',dtype_r8,(/pcols,pver/),rprddp_idx) + call pbuf_add_field('NEVAPR_DPCU','physpkg',dtype_r8,(/pcols,pver/),nevapr_dpcu_idx) + call pbuf_add_field('PREC_DP', 'physpkg',dtype_r8,(/pcols/), prec_dp_idx) + call pbuf_add_field('SNOW_DP', 'physpkg',dtype_r8,(/pcols/), snow_dp_idx) + + ! detrained convective cloud water mixing ratio. + call pbuf_add_field('DLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dlfzm_idx) + ! convective mass fluxes + call pbuf_add_field('CMFMC_DP', 'physpkg', dtype_r8, (/pcols,pverp/), mconzm_idx) + + +end subroutine zm_conv_register + +!========================================================================================= + +subroutine zm_conv_readnl(nlfile) + + use spmd_utils, only: mpicom, masterproc, masterprocid, mpi_real8, mpi_integer, mpi_logical + use namelist_utils, only: find_group_name + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'zm_conv_readnl' + + namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_num_cin, & + zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, & + zmconv_dmpdz, zmconv_tiedke_add, zmconv_capelmt, & + zmconv_tiedke_lnd, & !+tht additional param + zmconv_tht_thermo, & !+tht additional param + zmconv_retrigger , & !+tht additional param + zmconv_entrmn , & !+tht undeclared param (=2e-4_kind_phys) ! maximum convective entrainment rate + zmconv_alfadet , & !+tht undeclared param (=1e-1_kind_phys) ! convective detrainment/entrainment ratio + zmconv_plclmin , & !+tht undeclated param (=6.e2_kind_phys) ! don't convect if LCL above this level (p= 4.e3_r8) then + limcnv = 1 + else + do k=1,plev + if (pref_edge(k) < 4.e3_r8 .and. pref_edge(k+1) >= 4.e3_r8) then + limcnv = k + exit + end if + end do + if ( limcnv == 0 ) limcnv = plevp + end if + + if (masterproc) then + write(iulog,*)'ZM_CONV_INIT: Deep convection will be capped at intfc ',limcnv, & + ' which is ',pref_edge(limcnv),' pascals' + end if + + ! If thickness of bottom layer is less than dz_min, and zmconv_parcel_pbl=.false., + ! then issue a warning. + dz_bot_layer = scale_height * log(pref_edge(pverp)/pref_edge(pver)) + if (dz_bot_layer < dz_min .and. .not. zmconv_parcel_pbl) then + if (masterproc) then + write(iulog,*)'********** WARNING **********' + write(iulog,*)' ZM_CONV_INIT: Bottom layer thickness (m) is ', dz_bot_layer + write(iulog,*)' The namelist variable zmconv_parcel_pbl should be set to .true.' + write(iulog,*)' when the bottom layer thickness is < ', dz_min + write(iulog,*)'********** WARNING **********' + end if + end if + + no_deep_pbl = phys_deepconv_pbl() + call zm_convr_init(plev, plevp, cpair, cpliq, cpwv, epsilo, gravit, latvap, tmelt, rair, & + pref_edge,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, zmconv_num_cin, & + no_deep_pbl, zmconv_tiedke_add, & +!+tht + zmconv_tiedke_lnd,& + zmconv_entrmn ,& + zmconv_alfadet ,& + zmconv_plclmin ,& + zmconv_tht_thermo,& + zmconv_retrigger ,& +!-tht + zmconv_capelmt, zmconv_dmpdz, & + zmconv_parcel_pbl, zmconv_parcel_hscale, zmconv_tau, & + masterproc, iulog, errmsg, errflg) + + if (errflg /= 0) then + call endrun('From zm_convr_init:' // errmsg) + end if + + cld_idx = pbuf_get_index('CLD') + fracis_idx = pbuf_get_index('FRACIS') + +end subroutine zm_conv_init +!========================================================================================= +!subroutine zm_conv_tend(state, ptend, tdt) + +subroutine zm_conv_tend(pblh ,mcon ,cme , & + tpert ,zdu , & + rliq ,rice ,ztodt , & + jctop ,jcbot , & + state ,ptend_all ,landfrac, pbuf) + + + use cam_history, only: outfld + use physics_types, only: physics_state, physics_ptend + use physics_types, only: physics_ptend_init, physics_update + use physics_types, only: physics_state_copy, physics_state_dealloc + use physics_types, only: physics_ptend_sum, physics_ptend_dealloc + + use time_manager, only: get_nstep, is_first_step + use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx + use physics_buffer, only : pbuf_set_field !+tht + use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 + use physconst, only: gravit, latice, latvap, tmelt, cpwv, cpliq, rh2o + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + + use phys_control, only: cam_physpkg_is + use ccpp_constituent_prop_mod, only: ccpp_const_props + + ! Arguments + + type(physics_state), intent(in),target :: state ! Physics state variables + type(physics_ptend), intent(out) :: ptend_all ! individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + real(r8), intent(in) :: pblh(pcols) ! Planetary boundary layer height + real(r8), intent(in) :: tpert(pcols) ! Thermal temperature excess + real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac + + real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c + real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation + real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux + + real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals + real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldice) for energy integrals + + + ! Local variables + character(len=512) :: errmsg + integer :: errflg + + integer :: i,k,l,m + integer :: ilon ! global longitude index of a column + integer :: ilat ! global latitude index of a column + integer :: nstep + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: itim_old ! for physics buffer fields + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: ntprprd(pcols,pver) ! evap outfld: net precip production in layer + real(r8) :: ntsnprd(pcols,pver) ! evap outfld: net snow production in layer + real(r8) :: tend_s_snwprd (pcols,pver) ! Heating rate of snow production + real(r8) :: tend_s_snwevmlt(pcols,pver) ! Heating rate of evap/melting of snow + real(r8) :: fake_dpdry(pcols,pver) ! used in convtran call + + ! physics types + type(physics_state) :: state1 ! locally modify for evaporation to use, not returned + type(physics_ptend),target :: ptend_loc ! package tendencies + + ! physics buffer fields + real(r8), pointer, dimension(:) :: prec ! total precipitation + real(r8), pointer, dimension(:) :: snow ! snow from ZM convection + real(r8), pointer, dimension(:,:) :: cld + real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. + real(r8), pointer, dimension(:,:) :: rprd ! rain production rate + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + real(r8), pointer, dimension(:,:) :: evapcdp ! Evaporation of deep convective precipitation + real(r8), pointer, dimension(:,:) :: flxprec ! Convective-scale flux of precip at interfaces (kg/m2/s) + real(r8), pointer, dimension(:,:) :: flxsnow ! Convective-scale flux of snow at interfaces (kg/m2/s) + real(r8), pointer :: dlf(:,:) ! detrained convective cloud water mixing ratio. + real(r8), pointer :: lambdadpcu(:,:) ! slope of cloud liquid size distr + real(r8), pointer :: mudpcu(:,:) ! width parameter of droplet size distr + real(r8), pointer :: mconzm(:,:) !convective mass fluxes + + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) + integer :: lengath + + real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. + real(r8) :: jcbot(pcols) ! o row of base of cloud indices passed out. + + real(r8) :: pcont(pcols), pconb(pcols), freqzm(pcols) + + real(r8) :: lat_all(pcols), long_all(pcols) + +!+tht + real(r8) :: eurt(pcols,pver) !+tht: entr.rate 3D +!-tht + + ! history output fields + real(r8) :: cape(pcols) ! w convective available potential energy. + real(r8) :: mu_out(pcols,pver) + real(r8) :: md_out(pcols,pver) + real(r8) :: dif(pcols,pver) + + ! used in momentum transport calculation + real(r8) :: pguallu(pcols, pver) + real(r8) :: pguallv(pcols, pver) + real(r8) :: pgdallu(pcols, pver) + real(r8) :: pgdallv(pcols, pver) + real(r8) :: icwuu(pcols,pver) + real(r8) :: icwuv(pcols,pver) + real(r8) :: icwdu(pcols,pver) + real(r8) :: icwdv(pcols,pver) + real(r8) :: seten(pcols, pver) + logical :: l_windt + real(r8) :: tfinal1, tfinal2 + integer :: ii + + real(r8) :: fice(pcols,pver) + real(r8) :: fsnow_conv(pcols,pver) + + logical :: lq(pcnst) + character(len=16) :: macrop_scheme + character(len=40) :: scheme_name + character(len=40) :: str + integer :: top_lev + + !---------------------------------------------------------------------- + + ! initialize + lchnk = state%lchnk + ncol = state%ncol + nstep = get_nstep() + + ftem = 0._r8 + mu_out(:,:) = 0._r8 + md_out(:,:) = 0._r8 + + call physics_state_copy(state,state1) ! copy state to local state1. + + lq(:) = .FALSE. + lq(1) = .TRUE. + call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr_run', ls=.true., lq=lq)! initialize local ptend type + +! +! Associate pointers with physics buffer fields +! + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, icwmrdp_idx, ql ) + call pbuf_get_field(pbuf, rprddp_idx, rprd ) + call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) + call pbuf_get_field(pbuf, prec_dp_idx, prec ) + call pbuf_get_field(pbuf, snow_dp_idx, snow ) + + call pbuf_get_field(pbuf, zm_mu_idx, mu) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_md_idx, md) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) + 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) + + call pbuf_get_field(pbuf, dlfzm_idx, dlf) + call pbuf_get_field(pbuf, mconzm_idx, mconzm) + +! Begin with Zhang-McFarlane (1996) convection parameterization +! + call t_startf ('zm_convr_run') + +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + ptend_loc%q(:,:,1) = 0._r8 + ptend_loc%s(:,:) = 0._r8 + dif(:,:) = 0._r8 + mcon(:,:) = 0._r8 + dlf(:,:) = 0._r8 + cme(:,:) = 0._r8 + cape(:) = 0._r8 + zdu(:,:) = 0._r8 + rprd(:,:) = 0._r8 + mu(:,:) = 0._r8 + eu(:,:) = 0._r8 + du(:,:) = 0._r8 + md(:,:) = 0._r8 + ed(:,:) = 0._r8 + dp(:,:) = 0._r8 + dsubcld(:) = 0._r8 + jctop(:) = 0._r8 + jcbot(:) = 0._r8 + prec(:) = 0._r8 + rliq(:) = 0._r8 + rice(:) = 0._r8 + ideep(:) = 0._r8 +!REMOVECAM_END + + + call get_rlat_all_p(lchnk, ncol, lat_all) + call get_rlon_all_p(lchnk, ncol, long_all) + + call zm_convr_run(ncol, pver, & + pverp, gravit, latice, cpwv, cpliq, rh2o, & + lat_all, long_all, & + state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), & + pblh(:ncol), state%zm(:ncol,:), state%phis(:ncol), state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & + ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & + ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), eurt(:ncol,:), & !tht + tpert(:ncol), dlf(:ncol,:), dif(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & + mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & + dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & + ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & + rice(:ncol), lengath, scheme_name, errmsg, errflg) + + if (errflg /= 0) then + write(str,*) 'From zm_convr_run: at chunk ',lchnk, ' : ' + call endrun(str // errmsg) + end if + + jctop(:) = real(pver,r8) + jcbot(:) = 1._r8 + do i = 1,lengath + jctop(ideep(i)) = real(jt(i), r8) + jcbot(ideep(i)) = real(maxg(i), r8) + end do + + call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output + call outfld('EURT', eurt(1,1), pcols, lchnk) !+tht + +! +! Output fractional occurance of ZM convection +! + freqzm(:) = 0._r8 + do i = 1,lengath + freqzm(ideep(i)) = 1.0_r8 + end do + call outfld('FREQZM ',freqzm ,pcols ,lchnk ) + + mconzm(:ncol,:pverp) = mcon(:ncol,:pverp) + + call outfld('CMFMC_DP', mconzm, pcols, lchnk) + + ! Store upward and downward mass fluxes in un-gathered arrays + ! + convert from mb/s to kg/m^2/s + do i=1,lengath + do k=1,pver + ii = ideep(i) + mu_out(ii,k) = mu(i,k) * 100._r8/gravit + md_out(ii,k) = md(i,k) * 100._r8/gravit + end do + end do + + call outfld('ZMMU', mu_out, pcols, lchnk) + call outfld('ZMMD', md_out, pcols, lchnk) + + ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld('ZMDT ',ftem ,pcols ,lchnk ) + call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call t_stopf ('zm_convr_run') + + call outfld('DLFZM' ,dlf ,pcols, lchnk) + + pcont(:ncol) = state%ps(:ncol) + pconb(:ncol) = state%ps(:ncol) + do i = 1,lengath + if (maxg(i).gt.jt(i)) then + pcont(ideep(i)) = state%pmid(ideep(i),jt(i)) ! gathered array (or jctop ungathered) + pconb(ideep(i)) = state%pmid(ideep(i),maxg(i))! gathered array + endif + ! write(iulog,*) ' pcont, pconb ', pcont(i), pconb(i), cnt(i), cnb(i) + end do + call outfld('PCONVT ',pcont ,pcols ,lchnk ) + call outfld('PCONVB ',pconb ,pcols ,lchnk ) + + call physics_ptend_init(ptend_all, state%psetcols, 'zm_conv_tend') + + ! add tendency from this process to tendencies from other processes + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + ! initialize ptend for next process + lq(:) = .FALSE. + lq(1) = .TRUE. + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap_run', ls=.true., lq=lq) + + call t_startf ('zm_conv_evap_run') +! +! Determine the phase of the precipitation produced and add latent heat of fusion +! Evaporate some of the precip directly into the environment (Sundqvist) +! Allow this to use the updated state1 and the fresh ptend_loc type +! heating and specific humidity tendencies produced +! + + call pbuf_get_field(pbuf, dp_flxprc_idx, flxprec ) + call pbuf_get_field(pbuf, dp_flxsnw_idx, flxsnow ) +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + flxprec(:,:) = 0._r8 + flxsnow(:,:) = 0._r8 + snow(:) = 0._r8 + fice(:,:) = 0._r8 + fsnow_conv(:,:) = 0._r8 +!REMOVECAM_END + + top_lev = 1 + call phys_getopts (macrop_scheme_out = macrop_scheme) + if ( .not. (macrop_scheme == "rk")) top_lev = trop_cloud_top_lev + + call cloud_fraction_fice_run(ncol, state1%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow_conv(:ncol,:), errmsg, errflg) + + call zm_conv_evap_run(state1%ncol, pver, pverp, & + gravit, latice, latvap, tmelt, & + cpair, zmconv_ke, zmconv_ke_lnd, & + state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & + landfrac(:ncol), & + ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & + rprd(:ncol,:), cld(:ncol,:), ztodt, & + prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), fsnow_conv(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:),& + scheme_name, errmsg, errflg) + + evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) +!+tht + call pbuf_set_field(pbuf, dp_ntprp_idx, ntprprd) + call pbuf_set_field(pbuf, dp_ntsnp_idx, ntsnprd) +!-tht + +! +! Write out variables from zm_conv_evap_run +! + ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld('EVAPTZM ',ftem ,pcols ,lchnk ) + ftem(:ncol,:pver) = tend_s_snwprd (:ncol,:pver)/cpair + call outfld('FZSNTZM ',ftem ,pcols ,lchnk ) + ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver)/cpair + call outfld('EVSNTZM ',ftem ,pcols ,lchnk ) + call outfld('EVAPQZM ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call outfld('ZMFLXPRC', flxprec, pcols, lchnk) + call outfld('ZMFLXSNW', flxsnow, pcols, lchnk) + call outfld('ZMNTPRPD', ntprprd, pcols, lchnk) + call outfld('ZMNTSNPD', ntsnprd, pcols, lchnk) + call outfld('ZMEIHEAT', ptend_loc%s, pcols, lchnk) + call outfld('CMFMC_DP ',mcon , pcols ,lchnk ) + call outfld('PRECCDZM ',prec, pcols ,lchnk ) + + + call t_stopf ('zm_conv_evap_run') + + call outfld('PRECZ ', prec , pcols, lchnk) + + ! add tendency from this process to tend from other processes here + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + + ! Momentum Transport + + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) + + l_windt = .true. +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + ptend_loc%s(:,:) = 0._r8 + ptend_loc%u(:,:) = 0._r8 + ptend_loc%v(:,:) = 0._r8 +!REMOVECAM_END + + call t_startf ('zm_conv_momtran_run') + + call zm_conv_momtran_run (ncol, pver, pverp, & + l_windt,state1%u(:ncol,:), state1%v(:ncol,:), mu(:ncol,:), md(:ncol,:), & + zmconv_momcu, zmconv_momcd, & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, ptend_loc%u(:ncol,:), ptend_loc%v(:ncol,:),& + pguallu(:ncol,:), pguallv(:ncol,:), pgdallu(:ncol,:), pgdallv(:ncol,:), & + icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:), & + scheme_name, errmsg, errflg) + call t_stopf ('zm_conv_momtran_run') + + ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) + + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! Output ptend variables before they are set to zero with physics_update + call outfld('ZMMTU', ptend_loc%u, pcols, lchnk) + call outfld('ZMMTV', ptend_loc%v, pcols, lchnk) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair + call outfld('ZMMTT', ftem , pcols, lchnk) + + ! Output apparent force from pressure gradient + call outfld('ZMUPGU', pguallu, pcols, lchnk) + call outfld('ZMUPGD', pgdallu, pcols, lchnk) + call outfld('ZMVPGU', pguallv, pcols, lchnk) + call outfld('ZMVPGD', pgdallv, pcols, lchnk) + + ! Output in-cloud winds + call outfld('ZMICUU', icwuu, pcols, lchnk) + call outfld('ZMICUD', icwdu, pcols, lchnk) + call outfld('ZMICVU', icwuv, pcols, lchnk) + call outfld('ZMICVD', icwdv, pcols, lchnk) + + ! Transport cloud water and ice only + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + lq(:) = .FALSE. + lq(2:) = cnst_is_convtran1(2:) + call physics_ptend_init(ptend_loc, state1%psetcols, 'convtran1', lq=lq) + + + ! dpdry is not used in this call to convtran since the cloud liquid and ice mixing + ! ratios are moist + fake_dpdry(:,:) = 0._r8 + + call t_startf ('convtran1') + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + ptend_loc%q(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_convtran_run (ncol, pver, & + ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ccpp_const_props, & + scheme_name, errmsg, errflg) + call t_stopf ('convtran1') + + call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) + call outfld('ZMDLIQ ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk ) + + ! add tendency from this process to tend from other processes here + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + call physics_state_dealloc(state1) + call physics_ptend_dealloc(ptend_loc) + + + +end subroutine zm_conv_tend +!========================================================================================= + + +subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) + + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use time_manager, only: get_nstep + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc + use constituents, only: pcnst, cnst_is_convtran2 + use ccpp_constituent_prop_mod, only: ccpp_const_props + + +! Arguments + type(physics_state), intent(in ) :: state ! Physics state variables + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + +! Local variables + integer :: i, lchnk, istat + integer :: lengath ! number of columns with deep convection + integer :: nstep + integer :: ncol + + real(r8), dimension(pcols,pver) :: dpdry + + ! physics buffer fields + real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) + + character(len=40) :: scheme_name + character(len=512) :: errmsg + integer :: errflg + + !----------------------------------------------------------------------------------- + + + call physics_ptend_init(ptend, state%psetcols, 'convtran2', lq=cnst_is_convtran2 ) + + call pbuf_get_field(pbuf, fracis_idx, fracis) + call pbuf_get_field(pbuf, zm_mu_idx, mu) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_md_idx, md) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) + 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) + + + lchnk = state%lchnk + ncol = state%ncol + nstep = get_nstep() + + lengath = count(ideep > 0) + if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake + + if (any(ptend%lq(:))) then + ! initialize dpdry for call to convtran + ! it 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 t_startf ('convtran2') + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + ptend%q(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_convtran_run (ncol, pver, & + ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ccpp_const_props, & + scheme_name, errmsg, errflg) + + if (errflg /= 0) then + call endrun('From zm_conv_convtran_run:' // errmsg) + end if + + call t_stopf ('convtran2') + end if + +end subroutine zm_conv_tend_2 + +!========================================================================================= + + +end module zm_conv_intr diff --git a/src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only b/src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only new file mode 100644 index 0000000000..5d5b3ff95f --- /dev/null +++ b/src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only @@ -0,0 +1,928 @@ +module zm_conv_intr +!--------------------------------------------------------------------------------- +! Purpose: +! +! CAM interface to the Zhang-McFarlane deep convection scheme +! +! Author: D.B. Coleman +! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer +!--------------------------------------------------------------------------------- + use shr_kind_mod, only: r8=>shr_kind_r8 + use physconst, only: cpair, epsilo, gravit, latvap, tmelt, rair + use ppgrid, only: pver, pcols, pverp, begchunk, endchunk + use zm_conv_evap, only: zm_conv_evap_run + use zm_convr, only: zm_convr_init, zm_convr_run + use zm_conv_convtran, only: zm_conv_convtran_run + use zm_conv_momtran, only: zm_conv_momtran_run + use cloud_fraction_fice, only: cloud_fraction_fice_run + + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & + rad_cnst_get_aer_props, rad_cnst_get_mode_props !, & + use cam_abortutils, only: endrun + use physconst, only: pi + use spmd_utils, only: masterproc + use perf_mod + use cam_logfile, only: iulog + use constituents, only: cnst_add + use ref_pres, only: trop_cloud_top_lev + use phys_control, only: phys_getopts + + implicit none + private + save + + ! Public methods + + public ::& + zm_conv_register, &! register fields in physics buffer + zm_conv_readnl, &! read namelist + zm_conv_init, &! initialize donner_deep module + zm_conv_tend, &! return tendencies + zm_conv_tend_2 ! return tendencies + + public zmconv_ke, zmconv_ke_lnd ! needed by convect_shallow + + integer ::& ! indices for fields in the physics buffer + zm_mu_idx, & + zm_eu_idx, & + zm_du_idx, & + zm_md_idx, & + zm_ed_idx, & + zm_dp_idx, & + zm_dsubcld_idx, & + zm_jt_idx, & + zm_maxg_idx, & + zm_ideep_idx, & + dp_flxprc_idx, & + dp_flxsnw_idx, & + dp_cldliq_idx, & + dp_cldice_idx, & + dlfzm_idx, & ! detrained convective cloud water mixing ratio. + prec_dp_idx, & + snow_dp_idx, & + mconzm_idx ! convective mass flux +!+tht + integer :: dp_ntprp_idx = 0 + integer :: dp_ntsnp_idx = 0 +!-tht + + real(r8), parameter :: unset_r8 = huge(1.0_r8) + real(r8) :: zmconv_c0_lnd = unset_r8 + real(r8) :: zmconv_c0_ocn = unset_r8 + real(r8) :: zmconv_ke = unset_r8 + real(r8) :: zmconv_ke_lnd = unset_r8 + real(r8) :: zmconv_momcu = unset_r8 + real(r8) :: zmconv_momcd = unset_r8 + integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + real(r8) :: zmconv_dmpdz = unset_r8 ! Parcel fractional mass entrainment rate + real(r8) :: zmconv_tiedke_add = unset_r8 ! Convective parcel temperature perturbation + real(r8) :: zmconv_capelmt = unset_r8 ! Triggering thereshold for ZM convection + logical :: zmconv_parcel_pbl = .false. ! switch for parcel pbl calculation + real(r8) :: zmconv_parcel_hscale = unset_r8! Fraction of PBL depth over which to mix initial parcel + real(r8) :: zmconv_tau = unset_r8 ! Timescale for convection + + +! indices for fields in the physics buffer + integer :: cld_idx = 0 + integer :: icwmrdp_idx = 0 + integer :: rprddp_idx = 0 + integer :: fracis_idx = 0 + integer :: nevapr_dpcu_idx = 0 + integer :: dgnum_idx = 0 + + integer :: nmodes + integer :: nbulk + +!========================================================================================= +contains +!========================================================================================= + +subroutine zm_conv_register + +!---------------------------------------- +! Purpose: register fields with the physics buffer +!---------------------------------------- + + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + + implicit none + + integer idx + + call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) + call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) + call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) + call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) + call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) + + ! wg layer thickness in mbs (between upper/lower interface). + call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) + + ! wg layer thickness in mbs between lcl and maxi. + call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) + + ! wg top level index of deep cumulus convection. + call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) + + ! wg gathered values of maxi. + call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) + + ! map gathered points to chunk index + call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) + +! Flux of precipitation from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) +!+tht + call pbuf_add_field('dp_ntprp','physpkg',dtype_r8,(/pcols,pver /),dp_ntprp_idx) + call pbuf_add_field('dp_ntsnp','physpkg',dtype_r8,(/pcols,pver /),dp_ntsnp_idx) +!-tht + +! Flux of snow from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) + + call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) + call pbuf_add_field('RPRDDP', 'physpkg',dtype_r8,(/pcols,pver/),rprddp_idx) + call pbuf_add_field('NEVAPR_DPCU','physpkg',dtype_r8,(/pcols,pver/),nevapr_dpcu_idx) + call pbuf_add_field('PREC_DP', 'physpkg',dtype_r8,(/pcols/), prec_dp_idx) + call pbuf_add_field('SNOW_DP', 'physpkg',dtype_r8,(/pcols/), snow_dp_idx) + + ! detrained convective cloud water mixing ratio. + call pbuf_add_field('DLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dlfzm_idx) + ! convective mass fluxes + call pbuf_add_field('CMFMC_DP', 'physpkg', dtype_r8, (/pcols,pverp/), mconzm_idx) + +end subroutine zm_conv_register + +!========================================================================================= + +subroutine zm_conv_readnl(nlfile) + + use spmd_utils, only: mpicom, masterproc, masterprocid, mpi_real8, mpi_integer, mpi_logical + use namelist_utils, only: find_group_name + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'zm_conv_readnl' + + namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_num_cin, & + zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, & + zmconv_dmpdz, zmconv_tiedke_add, zmconv_capelmt, & + zmconv_parcel_hscale, & + zmconv_parcel_pbl, zmconv_tau + !----------------------------------------------------------------------------- + + if (masterproc) then + open( newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'zmconv_nl', status=ierr) + if (ierr == 0) then + read(unitn, zmconv_nl, 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(zmconv_num_cin, 1, mpi_integer, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_num_cin") + call mpi_bcast(zmconv_c0_lnd, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_c0_lnd") + call mpi_bcast(zmconv_c0_ocn, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_c0_ocn") + call mpi_bcast(zmconv_ke, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_ke") + call mpi_bcast(zmconv_ke_lnd, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_ke_lnd") + call mpi_bcast(zmconv_momcu, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcu") + call mpi_bcast(zmconv_momcd, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcd") + call mpi_bcast(zmconv_dmpdz, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_dmpdz") + call mpi_bcast(zmconv_tiedke_add, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_tiedke_add") + call mpi_bcast(zmconv_capelmt, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_capelmt") + call mpi_bcast(zmconv_parcel_pbl, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_parcel_pbl") + call mpi_bcast(zmconv_parcel_hscale, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_parcel_hscale") + call mpi_bcast(zmconv_tau, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_tau") + +end subroutine zm_conv_readnl + +!========================================================================================= + +subroutine zm_conv_init(pref_edge) + +!---------------------------------------- +! Purpose: declare output fields, initialize variables needed by convection +!---------------------------------------- + + use cam_history, only: addfld, add_default, horiz_only + use ppgrid, only: pcols, pver + use zm_convr, only: zm_convr_init + use pmgrid, only: plev,plevp + use spmd_utils, only: masterproc + use phys_control, only: phys_deepconv_pbl, phys_getopts, cam_physpkg_is + use physics_buffer, only: pbuf_get_index + + implicit none + + real(r8),intent(in) :: pref_edge(plevp) ! reference pressures at interfaces + + ! local variables + real(r8), parameter :: scale_height = 7000._r8 ! std atm scale height (m) + real(r8), parameter :: dz_min = 100._r8 ! minimum thickness for using + ! zmconv_parcel_pbl=.false. + real(r8) :: dz_bot_layer ! thickness of bottom layer (m) + + character(len=512) :: errmsg + integer :: errflg + + logical :: no_deep_pbl ! if true, no deep convection in PBL + integer limcnv ! top interface level limit for convection + integer k, istat + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + +! +! Register fields with the output buffer +! + + call addfld ('PRECZ', horiz_only, 'A', 'm/s','total precipitation from ZM convection') + call addfld ('ZMDT', (/ 'lev' /), 'A', 'K/s','T tendency - Zhang-McFarlane moist convection') + call addfld ('ZMDQ', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Zhang-McFarlane moist convection') + call addfld ('ZMDICE', (/ 'lev' /), 'A', 'kg/kg/s','Cloud ice tendency - Zhang-McFarlane convection') + call addfld ('ZMDLIQ', (/ 'lev' /), 'A', 'kg/kg/s','Cloud liq tendency - Zhang-McFarlane convection') + call addfld ('EVAPTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Evaporation/snow prod from Zhang convection') + call addfld ('FZSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Rain to snow conversion from Zhang convection') + call addfld ('EVSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Snow to rain prod from Zhang convection') + call addfld ('EVAPQZM', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Evaporation from Zhang-McFarlane moist convection') + + call addfld ('ZMFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of precipitation from ZM convection' ) + call addfld ('ZMFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of snow from ZM convection' ) + call addfld ('ZMNTPRPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net precipitation production from ZM convection') + call addfld ('ZMNTSNPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net snow production from ZM convection' ) + call addfld ('ZMEIHEAT', (/ 'lev' /) , 'A', 'W/kg' ,'Heating by ice and evaporation in ZM convection') + + call addfld ('CMFMC_DP', (/ 'ilev' /), 'A', 'kg/m2/s','Convection mass flux from ZM deep ') + call addfld ('PRECCDZM', horiz_only, 'A', 'm/s','Convective precipitation rate from ZM deep') + + call addfld ('PCONVB', horiz_only , 'A', 'Pa' ,'convection base pressure') + call addfld ('PCONVT', horiz_only , 'A', 'Pa' ,'convection top pressure') + + call addfld ('CAPE', horiz_only, 'A', 'J/kg', 'Convectively available potential energy') + call addfld ('FREQZM', horiz_only , 'A', 'fraction', 'Fractional occurance of ZM convection') + + call addfld ('ZMMTT', (/ 'lev' /), 'A', 'K/s', 'T tendency - ZM convective momentum transport') + call addfld ('ZMMTU', (/ 'lev' /), 'A', 'm/s2', 'U tendency - ZM convective momentum transport') + call addfld ('ZMMTV', (/ 'lev' /), 'A', 'm/s2', 'V tendency - ZM convective momentum transport') + + call addfld ('ZMMU', (/ 'lev' /), 'A', 'kg/m2/s', 'ZM convection updraft mass flux') + call addfld ('ZMMD', (/ 'lev' /), 'A', 'kg/m2/s', 'ZM convection downdraft mass flux') + + call addfld ('ZMUPGU', (/ 'lev' /), 'A', 'm/s2', 'zonal force from ZM updraft pressure gradient term') + call addfld ('ZMUPGD', (/ 'lev' /), 'A', 'm/s2', 'zonal force from ZM downdraft pressure gradient term') + call addfld ('ZMVPGU', (/ 'lev' /), 'A', 'm/s2', 'meridional force from ZM updraft pressure gradient term') + call addfld ('ZMVPGD', (/ 'lev' /), 'A', 'm/s2', 'merdional force from ZM downdraft pressure gradient term') + + call addfld ('ZMICUU', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud U updrafts') + call addfld ('ZMICUD', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud U downdrafts') + call addfld ('ZMICVU', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud V updrafts') + call addfld ('ZMICVD', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud V downdrafts') + + call addfld ('DLFZM' ,(/ 'lev' /), 'A','kg/kg/s ','Detrained liquid water from ZM convection') + + call phys_getopts( history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + if ( history_budget ) then + call add_default('EVAPTZM ', history_budget_histfile_num, ' ') + call add_default('EVAPQZM ', history_budget_histfile_num, ' ') + call add_default('ZMDT ', history_budget_histfile_num, ' ') + call add_default('ZMDQ ', history_budget_histfile_num, ' ') + call add_default('ZMDLIQ ', history_budget_histfile_num, ' ') + call add_default('ZMDICE ', history_budget_histfile_num, ' ') + call add_default('ZMMTT ', history_budget_histfile_num, ' ') + end if + +! +! Limit deep convection to regions below 40 mb +! Note this calculation is repeated in the shallow convection interface +! + limcnv = 0 ! null value to check against below + if (pref_edge(1) >= 4.e3_r8) then + limcnv = 1 + else + do k=1,plev + if (pref_edge(k) < 4.e3_r8 .and. pref_edge(k+1) >= 4.e3_r8) then + limcnv = k + exit + end if + end do + if ( limcnv == 0 ) limcnv = plevp + end if + + if (masterproc) then + write(iulog,*)'ZM_CONV_INIT: Deep convection will be capped at intfc ',limcnv, & + ' which is ',pref_edge(limcnv),' pascals' + end if + + ! If thickness of bottom layer is less than dz_min, and zmconv_parcel_pbl=.false., + ! then issue a warning. + dz_bot_layer = scale_height * log(pref_edge(pverp)/pref_edge(pver)) + if (dz_bot_layer < dz_min .and. .not. zmconv_parcel_pbl) then + if (masterproc) then + write(iulog,*)'********** WARNING **********' + write(iulog,*)' ZM_CONV_INIT: Bottom layer thickness (m) is ', dz_bot_layer + write(iulog,*)' The namelist variable zmconv_parcel_pbl should be set to .true.' + write(iulog,*)' when the bottom layer thickness is < ', dz_min + write(iulog,*)'********** WARNING **********' + end if + end if + + no_deep_pbl = phys_deepconv_pbl() + call zm_convr_init(plev, plevp, cpair, epsilo, gravit, latvap, tmelt, rair, & + pref_edge,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, zmconv_num_cin, & + no_deep_pbl, zmconv_tiedke_add, & + zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_parcel_hscale, zmconv_tau, & + masterproc, iulog, errmsg, errflg) + + if (errflg /= 0) then + call endrun('From zm_convr_init:' // errmsg) + end if + + cld_idx = pbuf_get_index('CLD') + fracis_idx = pbuf_get_index('FRACIS') + +end subroutine zm_conv_init +!========================================================================================= +!subroutine zm_conv_tend(state, ptend, tdt) + +subroutine zm_conv_tend(pblh ,mcon ,cme , & + tpert ,zdu , & + rliq ,rice ,ztodt , & + jctop ,jcbot , & + state ,ptend_all ,landfrac, pbuf) + + + use cam_history, only: outfld + use physics_types, only: physics_state, physics_ptend + use physics_types, only: physics_ptend_init, physics_update + use physics_types, only: physics_state_copy, physics_state_dealloc + use physics_types, only: physics_ptend_sum, physics_ptend_dealloc + + use time_manager, only: get_nstep, is_first_step + use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx + use physics_buffer, only : pbuf_set_field + use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 + use physconst, only: gravit, latice, latvap, tmelt, cpwv, cpliq, rh2o + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + + use phys_control, only: cam_physpkg_is + use ccpp_constituent_prop_mod, only: ccpp_const_props + + ! Arguments + + type(physics_state), intent(in),target :: state ! Physics state variables + type(physics_ptend), intent(out) :: ptend_all ! individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + real(r8), intent(in) :: pblh(pcols) ! Planetary boundary layer height + real(r8), intent(in) :: tpert(pcols) ! Thermal temperature excess + real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac + + real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c + real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation + real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux + + real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals + real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldice) for energy integrals + + + ! Local variables + character(len=512) :: errmsg + integer :: errflg + + integer :: i,k,l,m + integer :: ilon ! global longitude index of a column + integer :: ilat ! global latitude index of a column + integer :: nstep + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: itim_old ! for physics buffer fields + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: ntprprd(pcols,pver) ! evap outfld: net precip production in layer + real(r8) :: ntsnprd(pcols,pver) ! evap outfld: net snow production in layer + real(r8) :: tend_s_snwprd (pcols,pver) ! Heating rate of snow production + real(r8) :: tend_s_snwevmlt(pcols,pver) ! Heating rate of evap/melting of snow + real(r8) :: fake_dpdry(pcols,pver) ! used in convtran call + + ! physics types + type(physics_state) :: state1 ! locally modify for evaporation to use, not returned + type(physics_ptend),target :: ptend_loc ! package tendencies + + ! physics buffer fields + real(r8), pointer, dimension(:) :: prec ! total precipitation + real(r8), pointer, dimension(:) :: snow ! snow from ZM convection + real(r8), pointer, dimension(:,:) :: cld + real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. + real(r8), pointer, dimension(:,:) :: rprd ! rain production rate + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + real(r8), pointer, dimension(:,:) :: evapcdp ! Evaporation of deep convective precipitation + real(r8), pointer, dimension(:,:) :: flxprec ! Convective-scale flux of precip at interfaces (kg/m2/s) + real(r8), pointer, dimension(:,:) :: flxsnow ! Convective-scale flux of snow at interfaces (kg/m2/s) + real(r8), pointer :: dlf(:,:) ! detrained convective cloud water mixing ratio. + real(r8), pointer :: lambdadpcu(:,:) ! slope of cloud liquid size distr + real(r8), pointer :: mudpcu(:,:) ! width parameter of droplet size distr + real(r8), pointer :: mconzm(:,:) !convective mass fluxes + + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) + integer :: lengath + + real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. + real(r8) :: jcbot(pcols) ! o row of base of cloud indices passed out. + + real(r8) :: pcont(pcols), pconb(pcols), freqzm(pcols) + + real(r8) :: lat_all(pcols), long_all(pcols) + + ! history output fields + real(r8) :: cape(pcols) ! w convective available potential energy. + real(r8) :: mu_out(pcols,pver) + real(r8) :: md_out(pcols,pver) + real(r8) :: dif(pcols,pver) + + ! used in momentum transport calculation + real(r8) :: pguallu(pcols, pver) + real(r8) :: pguallv(pcols, pver) + real(r8) :: pgdallu(pcols, pver) + real(r8) :: pgdallv(pcols, pver) + real(r8) :: icwuu(pcols,pver) + real(r8) :: icwuv(pcols,pver) + real(r8) :: icwdu(pcols,pver) + real(r8) :: icwdv(pcols,pver) + real(r8) :: seten(pcols, pver) + logical :: l_windt + real(r8) :: tfinal1, tfinal2 + integer :: ii + + real(r8) :: fice(pcols,pver) + real(r8) :: fsnow_conv(pcols,pver) + + logical :: lq(pcnst) + character(len=16) :: macrop_scheme + character(len=40) :: scheme_name + character(len=40) :: str + integer :: top_lev + + !---------------------------------------------------------------------- + + ! initialize + lchnk = state%lchnk + ncol = state%ncol + nstep = get_nstep() + + ftem = 0._r8 + mu_out(:,:) = 0._r8 + md_out(:,:) = 0._r8 + + call physics_state_copy(state,state1) ! copy state to local state1. + + lq(:) = .FALSE. + lq(1) = .TRUE. + call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr_run', ls=.true., lq=lq)! initialize local ptend type + +! +! Associate pointers with physics buffer fields +! + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, icwmrdp_idx, ql ) + call pbuf_get_field(pbuf, rprddp_idx, rprd ) + call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) + call pbuf_get_field(pbuf, prec_dp_idx, prec ) + call pbuf_get_field(pbuf, snow_dp_idx, snow ) + + call pbuf_get_field(pbuf, zm_mu_idx, mu) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_md_idx, md) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) + 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) + + call pbuf_get_field(pbuf, dlfzm_idx, dlf) + call pbuf_get_field(pbuf, mconzm_idx, mconzm) + +! Begin with Zhang-McFarlane (1996) convection parameterization +! + call t_startf ('zm_convr_run') + +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + ptend_loc%q(:,:,1) = 0._r8 + ptend_loc%s(:,:) = 0._r8 + dif(:,:) = 0._r8 + mcon(:,:) = 0._r8 + dlf(:,:) = 0._r8 + cme(:,:) = 0._r8 + cape(:) = 0._r8 + zdu(:,:) = 0._r8 + rprd(:,:) = 0._r8 + mu(:,:) = 0._r8 + eu(:,:) = 0._r8 + du(:,:) = 0._r8 + md(:,:) = 0._r8 + ed(:,:) = 0._r8 + dp(:,:) = 0._r8 + dsubcld(:) = 0._r8 + jctop(:) = 0._r8 + jcbot(:) = 0._r8 + prec(:) = 0._r8 + rliq(:) = 0._r8 + rice(:) = 0._r8 + ideep(:) = 0._r8 +!REMOVECAM_END + + + call get_rlat_all_p(lchnk, ncol, lat_all) + call get_rlon_all_p(lchnk, ncol, long_all) + + call zm_convr_run(ncol, pver, & + pverp, gravit, latice, cpwv, cpliq, rh2o, & + lat_all, long_all, & + state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), & + pblh(:ncol), state%zm(:ncol,:), state%phis(:ncol), state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & + ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & + ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), & + tpert(:ncol), dlf(:ncol,:), dif(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & + mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & + dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & + ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & + rice(:ncol), lengath, scheme_name, errmsg, errflg) + + if (errflg /= 0) then + write(str,*) 'From zm_convr_run: at chunk ',lchnk, ' : ' + call endrun(str // errmsg) + end if + + jctop(:) = real(pver,r8) + jcbot(:) = 1._r8 + do i = 1,lengath + jctop(ideep(i)) = real(jt(i), r8) + jcbot(ideep(i)) = real(maxg(i), r8) + end do + + call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output +! +! Output fractional occurance of ZM convection +! + freqzm(:) = 0._r8 + do i = 1,lengath + freqzm(ideep(i)) = 1.0_r8 + end do + call outfld('FREQZM ',freqzm ,pcols ,lchnk ) +! +! Convert mass flux from reported mb/s to kg/m^2/s +! done in convr now + !mcon(:ncol,:pverp) = mcon(:ncol,:pverp) * 100._r8/gravit + mconzm(:ncol,:pverp) = mcon(:ncol,:pverp) + + call outfld('CMFMC_DP', mconzm, pcols, lchnk) + + ! Store upward and downward mass fluxes in un-gathered arrays + ! + convert from mb/s to kg/m^2/s + do i=1,lengath + do k=1,pver + ii = ideep(i) + mu_out(ii,k) = mu(i,k) * 100._r8/gravit + md_out(ii,k) = md(i,k) * 100._r8/gravit + end do + end do + + call outfld('ZMMU', mu_out, pcols, lchnk) + call outfld('ZMMD', md_out, pcols, lchnk) + + ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld('ZMDT ',ftem ,pcols ,lchnk ) + call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call t_stopf ('zm_convr_run') + + call outfld('DLFZM' ,dlf ,pcols, lchnk) + + pcont(:ncol) = state%ps(:ncol) + pconb(:ncol) = state%ps(:ncol) + do i = 1,lengath + if (maxg(i).gt.jt(i)) then + pcont(ideep(i)) = state%pmid(ideep(i),jt(i)) ! gathered array (or jctop ungathered) + pconb(ideep(i)) = state%pmid(ideep(i),maxg(i))! gathered array + endif + ! write(iulog,*) ' pcont, pconb ', pcont(i), pconb(i), cnt(i), cnb(i) + end do + call outfld('PCONVT ',pcont ,pcols ,lchnk ) + call outfld('PCONVB ',pconb ,pcols ,lchnk ) + + call physics_ptend_init(ptend_all, state%psetcols, 'zm_conv_tend') + + ! add tendency from this process to tendencies from other processes + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + ! initialize ptend for next process + lq(:) = .FALSE. + lq(1) = .TRUE. + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap_run', ls=.true., lq=lq) + + call t_startf ('zm_conv_evap_run') +! +! Determine the phase of the precipitation produced and add latent heat of fusion +! Evaporate some of the precip directly into the environment (Sundqvist) +! Allow this to use the updated state1 and the fresh ptend_loc type +! heating and specific humidity tendencies produced +! + + call pbuf_get_field(pbuf, dp_flxprc_idx, flxprec ) + call pbuf_get_field(pbuf, dp_flxsnw_idx, flxsnow ) +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + flxprec(:,:) = 0._r8 + flxsnow(:,:) = 0._r8 + snow(:) = 0._r8 + fice(:,:) = 0._r8 + fsnow_conv(:,:) = 0._r8 +!REMOVECAM_END + + top_lev = 1 + call phys_getopts (macrop_scheme_out = macrop_scheme) + !if ( .not. (macrop_scheme == "rk" .or. macrop_scheme == "SPCAM_sam1mom")) top_lev = trop_cloud_top_lev + if ( .not. (macrop_scheme == "rk")) top_lev = trop_cloud_top_lev + + call cloud_fraction_fice_run(ncol, state1%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow_conv(:ncol,:), errmsg, errflg) + + call zm_conv_evap_run(state1%ncol, pver, pverp, & + gravit, latice, latvap, tmelt, & + cpair, zmconv_ke, zmconv_ke_lnd, & + state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & + landfrac(:ncol), & + ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & + rprd(:ncol,:), cld(:ncol,:), ztodt, & + prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), fsnow_conv(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:),& + scheme_name, errmsg, errflg) + + evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) +!+tht + call pbuf_set_field(pbuf, dp_ntprp_idx, ntprprd) + call pbuf_set_field(pbuf, dp_ntsnp_idx, ntsnprd) +!-tht + +! +! Write out variables from zm_conv_evap_run +! + ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld('EVAPTZM ',ftem ,pcols ,lchnk ) + ftem(:ncol,:pver) = tend_s_snwprd (:ncol,:pver)/cpair + call outfld('FZSNTZM ',ftem ,pcols ,lchnk ) + ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver)/cpair + call outfld('EVSNTZM ',ftem ,pcols ,lchnk ) + call outfld('EVAPQZM ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call outfld('ZMFLXPRC', flxprec, pcols, lchnk) + call outfld('ZMFLXSNW', flxsnow, pcols, lchnk) + call outfld('ZMNTPRPD', ntprprd, pcols, lchnk) + call outfld('ZMNTSNPD', ntsnprd, pcols, lchnk) + call outfld('ZMEIHEAT', ptend_loc%s, pcols, lchnk) + call outfld('CMFMC_DP ',mcon , pcols ,lchnk ) + call outfld('PRECCDZM ',prec, pcols ,lchnk ) + + call t_stopf ('zm_conv_evap_run') + + call outfld('PRECZ ', prec , pcols, lchnk) + + ! add tendency from this process to tend from other processes here + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + + ! Momentum Transport + + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) + + l_windt = .true. +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + ptend_loc%s(:,:) = 0._r8 + ptend_loc%u(:,:) = 0._r8 + ptend_loc%v(:,:) = 0._r8 +!REMOVECAM_END + + call t_startf ('zm_conv_momtran_run') + + call zm_conv_momtran_run (ncol, pver, pverp, & + l_windt,state1%u(:ncol,:), state1%v(:ncol,:), mu(:ncol,:), md(:ncol,:), & + zmconv_momcu, zmconv_momcd, & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, ptend_loc%u(:ncol,:), ptend_loc%v(:ncol,:),& + pguallu(:ncol,:), pguallv(:ncol,:), pgdallu(:ncol,:), pgdallv(:ncol,:), & + icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:), & + scheme_name, errmsg, errflg) + call t_stopf ('zm_conv_momtran_run') + + ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) + + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! Output ptend variables before they are set to zero with physics_update + call outfld('ZMMTU', ptend_loc%u, pcols, lchnk) + call outfld('ZMMTV', ptend_loc%v, pcols, lchnk) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair + call outfld('ZMMTT', ftem , pcols, lchnk) + + ! Output apparent force from pressure gradient + call outfld('ZMUPGU', pguallu, pcols, lchnk) + call outfld('ZMUPGD', pgdallu, pcols, lchnk) + call outfld('ZMVPGU', pguallv, pcols, lchnk) + call outfld('ZMVPGD', pgdallv, pcols, lchnk) + + ! Output in-cloud winds + call outfld('ZMICUU', icwuu, pcols, lchnk) + call outfld('ZMICUD', icwdu, pcols, lchnk) + call outfld('ZMICVU', icwuv, pcols, lchnk) + call outfld('ZMICVD', icwdv, pcols, lchnk) + + ! Transport cloud water and ice only + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + lq(:) = .FALSE. + lq(2:) = cnst_is_convtran1(2:) + call physics_ptend_init(ptend_loc, state1%psetcols, 'convtran1', lq=lq) + + + ! dpdry is not used in this call to convtran since the cloud liquid and ice mixing + ! ratios are moist + fake_dpdry(:,:) = 0._r8 + + call t_startf ('convtran1') + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + ptend_loc%q(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_convtran_run (ncol, pver, & + ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ccpp_const_props, & + scheme_name, errmsg, errflg) + call t_stopf ('convtran1') + + call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) + call outfld('ZMDLIQ ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk ) + + ! add tendency from this process to tend from other processes here + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + call physics_state_dealloc(state1) + call physics_ptend_dealloc(ptend_loc) + + + +end subroutine zm_conv_tend +!========================================================================================= + + +subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) + + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use time_manager, only: get_nstep + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc + use constituents, only: pcnst, cnst_is_convtran2 + use ccpp_constituent_prop_mod, only: ccpp_const_props + + +! Arguments + type(physics_state), intent(in ) :: state ! Physics state variables + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + +! Local variables + integer :: i, lchnk, istat + integer :: lengath ! number of columns with deep convection + integer :: nstep + integer :: ncol + + real(r8), dimension(pcols,pver) :: dpdry + + ! physics buffer fields + real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) + + character(len=40) :: scheme_name + character(len=512) :: errmsg + integer :: errflg + + !----------------------------------------------------------------------------------- + + + call physics_ptend_init(ptend, state%psetcols, 'convtran2', lq=cnst_is_convtran2 ) + + call pbuf_get_field(pbuf, fracis_idx, fracis) + call pbuf_get_field(pbuf, zm_mu_idx, mu) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_md_idx, md) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) + 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) + + + lchnk = state%lchnk + ncol = state%ncol + nstep = get_nstep() + + lengath = count(ideep > 0) + if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake + + if (any(ptend%lq(:))) then + ! initialize dpdry for call to convtran + ! it 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 t_startf ('convtran2') + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + ptend%q(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_convtran_run (ncol, pver, & + ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ccpp_const_props, & + scheme_name, errmsg, errflg) + + if (errflg /= 0) then + call endrun('From zm_conv_convtran_run:' // errmsg) + end if + + call t_stopf ('convtran2') + end if + +end subroutine zm_conv_tend_2 + +!========================================================================================= + + +end module zm_conv_intr diff --git a/src/physics/camnor_phys/physics/zm_convr.F90 b/src/physics/camnor_phys/physics/zm_convr.F90 new file mode 100644 index 0000000000..125e1f4c5a --- /dev/null +++ b/src/physics/camnor_phys/physics/zm_convr.F90 @@ -0,0 +1,3138 @@ +module zm_convr + + use ccpp_kinds, only: kind_phys +!+tht + use physconst, only: cpvir, zvir +!-tht + + implicit none + + save + private ! Make default type private to the module +! +! PUBLIC: interfaces +! + public zm_convr_init ! ZM schemea + public zm_convr_run ! ZM schemea + + real(kind_phys) rl ! wg latent heat of vaporization. + real(kind_phys) cpres ! specific heat at constant pressure in j/kg-degk. + real(kind_phys) :: capelmt ! namelist configurable: + ! threshold value for cape for deep convection. + real(kind_phys) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke + real(kind_phys) :: ke_lnd + real(kind_phys) :: c0_lnd ! set from namelist input zmconv_c0_lnd + real(kind_phys) :: c0_ocn ! set from namelist input zmconv_c0_ocn + integer :: num_cin ! set from namelist input zmconv_num_cin + ! The number of negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + real(kind_phys) tau ! convective time scale + real(kind_phys) :: tfreez + real(kind_phys) :: eps1 + real(kind_phys) :: momcu + real(kind_phys) :: momcd + + logical :: no_deep_pbl ! default = .false. + ! no_deep_pbl = .true. eliminates deep convection entirely within PBL + + + real(kind_phys) :: rgrav ! reciprocal of grav + real(kind_phys) :: rgas ! gas constant for dry air + real(kind_phys) :: grav ! = gravit + real(kind_phys) :: cp ! = cpres = cpair + + integer limcnv ! top interface level limit for convection + + logical :: lparcel_pbl ! Switch to turn on mixing of parcel MSE air, and picking launch level to be the top of the PBL. + real(kind_phys) :: parcel_hscale + + real(kind_phys) :: tiedke_add ! namelist configurable + real(kind_phys) :: dmpdz_param ! namelist configurable + + real(kind_phys) :: dcol, zv, cpv ! tht_thermo + +!+tht + ! added parameters + logical :: retrigger =.true. & !+tht iterate parcel-plume calculation and trigger condition + ,tht_thermo =.true. !+tht latent heat of freezing added in plume ensemble + real(kind_phys) :: & + tiedke_lnd = 1.0_kind_phys & + ! previously undeclared parameters: + ,entrmn = 2e-4_kind_phys & !+tht maximum convective entrainment rate + ,alfadet = 0.1_kind_phys & !+tht convective detrainment/entrainment ratio + ,plclmin = 6.e2_kind_phys !+tht don't convect if LCL above this level (p \section arg_table_zm_convr_init Argument Table +!! \htmlinclude zm_convr_init.html +!! +subroutine zm_convr_init(plev, plevp, cpair, cpliq, cpwv, epsilo, gravit, latvap, tmelt, rair, & + pref_edge, zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, zmconv_num_cin, & + no_deep_pbl_in, zmconv_tiedke_add, & +!+tht + zmconv_tiedke_lnd,& + zmconv_entrmn ,& + zmconv_alfadet ,& + zmconv_plclmin ,& + zmconv_tht_thermo,& + zmconv_retrigger ,& +!-tht + zmconv_capelmt, zmconv_dmpdz, & + zmconv_parcel_pbl, zmconv_parcel_hscale, zmconv_tau, & + masterproc, iulog, errmsg, errflg) + + integer, intent(in) :: plev + integer, intent(in) :: plevp + + real(kind_phys), intent(in) :: cpair,cpliq,cpwv! specific heats (J K-1 kg-1) + real(kind_phys), intent(in) :: epsilo ! ratio of h2o to dry air molecular weights + real(kind_phys), intent(in) :: gravit ! gravitational acceleration (m s-2) + real(kind_phys), intent(in) :: latvap ! Latent heat of vaporization (J kg-1) + real(kind_phys), intent(in) :: tmelt ! Freezing point of water (K) + real(kind_phys), intent(in) :: rair ! Dry air gas constant (J K-1 kg-1) + real(kind_phys), intent(in) :: pref_edge(:) ! reference pressures at interfaces + integer, intent(in) :: zmconv_num_cin ! Number negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + real(kind_phys),intent(in) :: zmconv_c0_lnd + real(kind_phys),intent(in) :: zmconv_c0_ocn + real(kind_phys),intent(in) :: zmconv_ke + real(kind_phys),intent(in) :: zmconv_ke_lnd + real(kind_phys),intent(in) :: zmconv_momcu + real(kind_phys),intent(in) :: zmconv_momcd + logical ,intent(in) :: no_deep_pbl_in ! no_deep_pbl = .true. eliminates ZM convection entirely within PBL + real(kind_phys),intent(in) :: zmconv_tiedke_add + real(kind_phys),intent(in) :: zmconv_capelmt + real(kind_phys),intent(in) :: zmconv_dmpdz + logical ,intent(in) :: zmconv_parcel_pbl ! Should the parcel properties include PBL mixing? + real(kind_phys),intent(in) :: zmconv_parcel_hscale ! Fraction of PBL over which to mix ZM parcel. + real(kind_phys),intent(in) :: zmconv_tau +!+tht + real(kind_phys),intent(in) :: zmconv_tiedke_lnd + real(kind_phys),intent(in) :: zmconv_entrmn + real(kind_phys),intent(in) :: zmconv_alfadet + real(kind_phys),intent(in) :: zmconv_plclmin + logical ,intent(in) :: zmconv_tht_thermo + logical ,intent(in) :: zmconv_retrigger +!-tht + logical, intent(in) :: masterproc + integer, intent(in) :: iulog + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: k + + errmsg ='' + errflg = 0 + + ! Initialization of ZM constants + tfreez = tmelt + eps1 = epsilo + rl = latvap + cpres = cpair + rgrav = 1.0_kind_phys/gravit + rgas = rair + grav = gravit + cp = cpres + + c0_lnd = zmconv_c0_lnd + c0_ocn = zmconv_c0_ocn + num_cin = zmconv_num_cin + ke = zmconv_ke + ke_lnd = zmconv_ke_lnd + momcu = zmconv_momcu + momcd = zmconv_momcd + + tiedke_add = zmconv_tiedke_add + capelmt = zmconv_capelmt + dmpdz_param = zmconv_dmpdz + no_deep_pbl = no_deep_pbl_in + lparcel_pbl = zmconv_parcel_pbl + parcel_hscale = zmconv_parcel_hscale +!+tht + ! added parameters + tht_thermo = zmconv_tht_thermo + retrigger = zmconv_retrigger + ! previously undeclared parameters + entrmn = zmconv_entrmn + alfadet = zmconv_alfadet + plclmin = zmconv_plclmin + ! implied parameters + second_call= retrigger + tht_tweaks = (retrigger.or.tht_thermo) + ! set tiedke_lnd but ensure regression to standard ZM + if(tht_tweaks) then + tiedke_lnd = zmconv_tiedke_lnd + else + tiedke_lnd = tiedke_add + endif + ! auxiliary vars + if(tht_thermo) then + dcol=(cpliq-cpwv)/latvap + zv=zvir + cpv=cpvir + else + dcol=0._kind_phys + zv =0._kind_phys + cpv =0._kind_phys + endif +!-tht + + tau = zmconv_tau + + ! + ! Limit deep convection to regions below 40 mb + ! Note this calculation is repeated in the shallow convection interface + ! + limcnv = 0 ! null value to check against below + if (pref_edge(1) >= 4.e3_kind_phys) then + limcnv = 1 + else + do k=1,plev + if (pref_edge(k) < 4.e3_kind_phys .and. pref_edge(k+1) >= 4.e3_kind_phys) then + limcnv = k + exit + end if + end do + if ( limcnv == 0 ) limcnv = plevp + end if + + if ( masterproc ) then + write(iulog,*)'ZM_CONVR_INIT' + write(iulog,*)'tht algorithmic mods:' + !write(iulog,*) ' (tht) Apply CIN threshold condition to allow convect.: use_cin ',use_cin + write(iulog,*) ' (tht) Conservatively mix plume enthalpy not entropy : tht_tweaks ',tht_tweaks + write(iulog,*) ' (tht) Account for freezing in plume-ensemble buoyancy: tht_thermo ',tht_thermo + write(iulog,*) ' (tht) Iterate CAPE calculation using diagnosed entrnm: second_call',second_call + write(iulog,*) ' (tht) Retrigger ZM convection using diagnosed entrnm : retrigger ',retrigger + ! if (.not.tht_tweaks .and. (second_call.or.retrigger.or.tht_thermo)) & + !call endrun('**** ZM_CONVI : tht_tweaks must be T in order to use any other tht mods ****') + write(iulog,*)'Standard tuning parameters:' + write(iulog,*) ' zm_convr_init: tau',tau + write(iulog,*) ' zm_convr_init: c0_lnd',c0_lnd,' , c0_ocn', c0_ocn + write(iulog,*) ' zm_convr_init: num_cin', num_cin + write(iulog,*) ' zm_convr_init: ke',ke,' , ke_lnd', ke_lnd + write(iulog,*) ' zm_convr_init: no_deep_pbl',no_deep_pbl + write(iulog,*) ' zm_convr_init: zm_capelmt', capelmt + write(iulog,*) ' zm_convr_init: zm_tiedke_add', tiedke_add + write(iulog,*) ' zm_convr_init: zm_parcel_pbl', lparcel_pbl + if(.not.tht_tweaks) & + write(iulog,*)' zm_convr_init: zm_dmpdz', dmpdz_param + if( tht_tweaks) & + write(iulog,*)' (tht) Entrainment rate in initial test plume for CAPE:-dmpdz_param',-dmpdz_param + write(iulog,*)'Hard-wired parameters:' + write(iulog,*) ' convection capping: level ',limcnv,' at ',pref_edge(limcnv)/100.,' hPa' + write(iulog,*) ' Minimum pressure of LCL allowed : plclmin ',plclmin + write(iulog,*) ' Maximum entrainment rate in convective ensemble: entrmn ',entrmn + write(iulog,*) ' Detrainment/entrainment ratio in convect. ens. : alfadet ',alfadet + write(iulog,*) ' (tht) Tiedke parameter over land : tiedke_lnd ',tiedke_lnd + ! if (use_cin) & + !write(iulog,*) ' (tht) Maximum allowed CIN as a fraction of CAPE : cin_threshd',cin_threshd + write(iulog,*)'**** ZM: DILUTE Buoyancy Calculation ****' + endif + +end subroutine zm_convr_init + + +!=============================================================================== +!> \section arg_table_zm_convr_run Argument Table +!! \htmlinclude zm_convr_run.html +!! +subroutine zm_convr_run( ncol ,pver , & + pverp, gravit ,latice ,cpwv ,cpliq , rh2o, & + lat, long, & + t ,qh ,prec , & + pblh ,zm ,geos ,zi ,qtnd , & + heat ,pap ,paph ,dpp , & + delt ,mcon ,cme ,cape ,eurt , & + tpert ,dlf ,dif ,zdu ,rprd , & + mu ,md ,du ,eu ,ed , & + dp ,dsubcld ,jt ,maxg ,ideep , & + ql ,rliq ,landfrac, & + rice ,lengath ,scheme_name, errmsg ,errflg) +!----------------------------------------------------------------------- +! +! Purpose: +! Main driver for zhang-mcfarlane convection scheme +! +! Method: +! performs deep convective adjustment based on mass-flux closure +! algorithm. +! +! Author:guang jun zhang, m.lazare, n.mcfarlane. CAM Contact: P. Rasch +! +! This is contributed code not fully standardized by the CAM core group. +! All variables have been typed, where most are identified in comments +! The current procedure will be reimplemented in a subsequent version +! of the CAM where it will include a more straightforward formulation +! and will make use of the standard CAM nomenclature +! +!----------------------------------------------------------------------- +! +! ************************ index of variables ********************** +! +! wg * alpha array of vertical differencing used (=1. for upstream). +! w * cape convective available potential energy. +! wg * capeg gathered convective available potential energy. +! c * capelmt threshold value for cape for deep convection. +! ic * cpres specific heat at constant pressure in j/kg-degk. +! i * dpp +! ic * delt length of model time-step in seconds. +! wg * dp layer thickness in mbs (between upper/lower interface). +! wg * dqdt mixing ratio tendency at gathered points. +! wg * dsdt dry static energy ("temp") tendency at gathered points. +! wg * dudt u-wind tendency at gathered points. +! wg * dvdt v-wind tendency at gathered points. +! wg * dsubcld layer thickness in mbs between lcl and maxi. +! ic * grav acceleration due to gravity in m/sec2. +! wg * du detrainment in updraft. specified in mid-layer +! wg * ed entrainment in downdraft. +! wg * eu entrainment in updraft. +! wg * hmn moist static energy. +! wg * hsat saturated moist static energy. +! w * ideep holds position of gathered points vs longitude index. +! ic * pver number of model levels. +! wg * j0 detrainment initiation level index. +! wg * jd downdraft initiation level index. +! ic * jlatpr gaussian latitude index for printing grids (if needed). +! wg * jt top level index of deep cumulus convection. +! w * lcl base level index of deep cumulus convection. +! wg * lclg gathered values of lcl. +! w * lel index of highest theoretical convective plume. +! wg * lelg gathered values of lel. +! w * lon index of onset level for deep convection. +! w * maxi index of level with largest moist static energy. +! wg * maxg gathered values of maxi. +! wg * mb cloud base mass flux. +! wg * mc net upward (scaled by mb) cloud mass flux. +! wg * md downward cloud mass flux (positive up). +! wg * mu upward cloud mass flux (positive up). specified +! at interface +! ic * msg number of missing moisture levels at the top of model. +! w * p grid slice of ambient mid-layer pressure in mbs. +! i * pblt row of pbl top indices. +! w * pcpdh scaled surface pressure. +! w * pf grid slice of ambient interface pressure in mbs. +! wg * pg grid slice of gathered values of p. +! w * q grid slice of mixing ratio. +! wg * qd grid slice of mixing ratio in downdraft. +! wg * qg grid slice of gathered values of q. +! i/o * qh grid slice of specific humidity. +! w * qh0 grid slice of initial specific humidity. +! wg * qhat grid slice of upper interface mixing ratio. +! wg * ql grid slice of cloud liquid water. +! wg * qs grid slice of saturation mixing ratio. +! w * qstp grid slice of parcel temp. saturation mixing ratio. +! wg * qstpg grid slice of gathered values of qstp. +! wg * qu grid slice of mixing ratio in updraft. +! ic * rgas dry air gas constant. +! wg * rl latent heat of vaporization. +! w * s grid slice of scaled dry static energy (t+gz/cp). +! wg * sd grid slice of dry static energy in downdraft. +! wg * sg grid slice of gathered values of s. +! wg * shat grid slice of upper interface dry static energy. +! wg * su grid slice of dry static energy in updraft. +! i/o * t +! wg * tg grid slice of gathered values of t. +! w * tl row of parcel temperature at lcl. +! wg * tlg grid slice of gathered values of tl. +! w * tp grid slice of parcel temperatures. +! wg * tpg grid slice of gathered values of tp. +! i/o * u grid slice of u-wind (real). +! wg * ug grid slice of gathered values of u. +! i/o * utg grid slice of u-wind tendency (real). +! i/o * v grid slice of v-wind (real). +! w * va work array re-used by called subroutines. +! wg * vg grid slice of gathered values of v. +! i/o * vtg grid slice of v-wind tendency (real). +! i * w grid slice of diagnosed large-scale vertical velocity. +! w * z grid slice of ambient mid-layer height in metres. +! w * zf grid slice of ambient interface height in metres. +! wg * zfg grid slice of gathered values of zf. +! wg * zg grid slice of gathered values of z. +! +!----------------------------------------------------------------------- +! +! multi-level i/o fields: +! i => input arrays. +! i/o => input/output arrays. +! w => work arrays. +! wg => work arrays operating only on gathered points. +! ic => input data constants. +! c => data constants pertaining to subroutine itself. +! +! input arguments +! + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pver, pverp + + real(kind_phys), intent(in) :: gravit ! gravitational acceleration (m s-2) + real(kind_phys), intent(in) :: latice ! Latent heat of fusion (J kg-1) + real(kind_phys), intent(in) :: cpwv ! specific heat of water vapor (J K-1 kg-1) + real(kind_phys), intent(in) :: cpliq ! specific heat of fresh h2o (J K-1 kg-1) + real(kind_phys), intent(in) :: rh2o ! Water vapor gas constant (J K-1 kg-1) + + real(kind_phys), intent(in) :: lat(:) + real(kind_phys), intent(in) :: long(:) + + real(kind_phys), intent(in) :: t(:,:) ! grid slice of temperature at mid-layer. (ncol,pver) + real(kind_phys), intent(in) :: qh(:,:) ! grid slice of specific humidity. (ncol,pver) + real(kind_phys), intent(in) :: pap(:,:) ! (ncol,pver) + real(kind_phys), intent(in) :: paph(:,:) ! (ncol,pver+1) + real(kind_phys), intent(in) :: dpp(:,:) ! local sigma half-level thickness (i.e. dshj). (ncol,pver) + real(kind_phys), intent(in) :: zm(:,:) ! (ncol,pver) + real(kind_phys), intent(in) :: geos(:) ! (ncol) + real(kind_phys), intent(in) :: zi(:,:) ! (ncol,pver+1) + real(kind_phys), intent(in) :: pblh(:) ! (ncol) + real(kind_phys), intent(in) :: tpert(:) ! (ncol) + real(kind_phys), intent(in) :: landfrac(:) ! RBN Landfrac (ncol) + +! output arguments +! + real(kind_phys), intent(out) :: qtnd(:,:) ! specific humidity tendency (kg/kg/s) (ncol,pver) + real(kind_phys), intent(out) :: heat(:,:) ! heating rate (dry static energy tendency, W/kg) (ncol,pver) + real(kind_phys), intent(out) :: mcon(:,:) ! (ncol,pverp) + real(kind_phys), intent(out) :: dif(:,:) + real(kind_phys), intent(out) :: dlf(:,:) ! scattrd version of the detraining cld h2o tend (ncol,pver) + real(kind_phys), intent(out) :: cme(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: cape(:) ! w convective available potential energy. (ncol) + real(kind_phys), intent(out) :: zdu(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: rprd(:,:) ! rain production rate (ncol,pver) + +! move these vars from local storage to output so that convective +! transports can be done in outside of conv_cam. + real(kind_phys), intent(out) :: mu(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: eu(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: eurt(:,:)! (ncol,pver) + real(kind_phys), intent(out) :: du(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: md(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: ed(:,:) ! (ncol,pver) + real(kind_phys), intent(out) :: dp(:,:) ! wg layer thickness in mbs (between upper/lower interface). (ncol,pver) + real(kind_phys), intent(out) :: dsubcld(:) ! wg layer thickness in mbs between lcl and maxi. (ncol) + real(kind_phys), intent(out) :: prec(:) ! (ncol) + real(kind_phys), intent(out) :: rliq(:) ! reserved liquid (not yet in cldliq) for energy integrals (ncol) + real(kind_phys), intent(out) :: rice(:) ! reserved ice (not yet in cldce) for energy integrals (ncol) + + integer, intent(out) :: ideep(:) ! column indices of gathered points (ncol) + + integer, intent(out) :: jt(:) ! wg top level index of deep cumulus convection. + integer, intent(out) :: maxg(:)! wg gathered values of maxi. + + integer, intent(out) :: lengath + + real(kind_phys),intent(out):: ql(:,:) ! wg grid slice of cloud liquid water. + + character(len=40), intent(out) :: scheme_name + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + + ! Local variables + + + real(kind_phys) zs(ncol) + real(kind_phys) dlg(ncol,pver) ! gathrd version of the detraining cld h2o tend + real(kind_phys) cug(ncol,pver) ! gathered condensation rate + + real(kind_phys) evpg(ncol,pver) ! gathered evap rate of rain in downdraft + real(kind_phys) dptot(ncol) + + real(kind_phys) mumax(ncol) + real(kind_phys) pblt(ncol) ! i row of pbl top indices. + +!----------------------------------------------------------------------- +! +! general work fields (local variables): +! + real(kind_phys) q(ncol,pver) ! w grid slice of mixing ratio. + real(kind_phys) p(ncol,pver) ! w grid slice of ambient mid-layer pressure in mbs. + real(kind_phys) z(ncol,pver) ! w grid slice of ambient mid-layer height in metres. + real(kind_phys) s(ncol,pver) ! w grid slice of scaled dry static energy (t+gz/cp). + real(kind_phys) tp(ncol,pver) ! w grid slice of parcel temperatures. + real(kind_phys) zf(ncol,pver+1) ! w grid slice of ambient interface height in metres. + real(kind_phys) pf(ncol,pver+1) ! w grid slice of ambient interface pressure in mbs. + real(kind_phys) qstp(ncol,pver) ! w grid slice of parcel temp. saturation mixing ratio. + + real(kind_phys) tl(ncol) ! w row of parcel temperature at lcl. + + integer lcl(ncol) ! w base level index of deep cumulus convection. + integer lel(ncol) ! w index of highest theoretical convective plume. + integer lon(ncol) ! w index of onset level for deep convection. + integer maxi(ncol) ! w index of level with largest moist static energy. + + real(kind_phys) precip +! +! gathered work fields: +! + real(kind_phys) qg(ncol,pver) ! wg grid slice of gathered values of q. + real(kind_phys) tg(ncol,pver) ! w grid slice of temperature at interface. + real(kind_phys) pg(ncol,pver) ! wg grid slice of gathered values of p. + real(kind_phys) zg(ncol,pver) ! wg grid slice of gathered values of z. + real(kind_phys) sg(ncol,pver) ! wg grid slice of gathered values of s. + real(kind_phys) tpg(ncol,pver) ! wg grid slice of gathered values of tp. + real(kind_phys) zfg(ncol,pver+1) ! wg grid slice of gathered values of zf. + real(kind_phys) qstpg(ncol,pver) ! wg grid slice of gathered values of qstp. + real(kind_phys) ug(ncol,pver) ! wg grid slice of gathered values of u. + real(kind_phys) vg(ncol,pver) ! wg grid slice of gathered values of v. + real(kind_phys) cmeg(ncol,pver) + + real(kind_phys) rprdg(ncol,pver) ! wg gathered rain production rate + real(kind_phys) capeg(ncol) ! wg gathered convective available potential energy. + real(kind_phys) tlg(ncol) ! wg grid slice of gathered values of tl. + real(kind_phys) landfracg(ncol) ! wg grid slice of landfrac + + integer lclg(ncol) ! wg gathered values of lcl. + integer lelg(ncol) + + integer indxd(ncol) !+tht work array + +! +! work fields arising from gathered calculations. +! + real(kind_phys) dqdt(ncol,pver) ! wg mixing ratio tendency at gathered points. + real(kind_phys) dsdt(ncol,pver) ! wg dry static energy ("temp") tendency at gathered points. + real(kind_phys) sd(ncol,pver) ! wg grid slice of dry static energy in downdraft. + real(kind_phys) qd(ncol,pver) ! wg grid slice of mixing ratio in downdraft. + real(kind_phys) mc(ncol,pver) ! wg net upward (scaled by mb) cloud mass flux. + real(kind_phys) qhat(ncol,pver) ! wg grid slice of upper interface mixing ratio. + real(kind_phys) qu(ncol,pver) ! wg grid slice of mixing ratio in updraft. + real(kind_phys) su(ncol,pver) ! wg grid slice of dry static energy in updraft. + real(kind_phys) qs(ncol,pver) ! wg grid slice of saturation mixing ratio. + real(kind_phys) shat(ncol,pver) ! wg grid slice of upper interface dry static energy. + real(kind_phys) hmn(ncol,pver) ! wg moist static energy. + real(kind_phys) hsat(ncol,pver) ! wg saturated moist static energy. + real(kind_phys) qlg(ncol,pver) + real(kind_phys) dudt(ncol,pver) ! wg u-wind tendency at gathered points. + real(kind_phys) dvdt(ncol,pver) ! wg v-wind tendency at gathered points. + + real(kind_phys) dmpdz(ncol,pver) !+tht Parcel fractional mass entrainment rate (/m) + + real(kind_phys) qldeg(ncol,pver) ! cloud liquid water mixing ratio for detrainment (kg/kg) + real(kind_phys) mb(ncol) ! wg cloud base mass flux. + + integer jlcl(ncol) + integer j0(ncol) ! wg detrainment initiation level index. + integer jd(ncol) ! wg downdraft initiation level index. + + real(kind_phys),intent(in):: delt ! length of model time-step in seconds. + + integer i + integer ii + integer k, kk, l, m + + integer msg ! ic number of missing moisture levels at the top of model. + real(kind_phys) qdifr + real(kind_phys) sdifr + + real(kind_phys) hk, dmsm(ncol) !+tht for diagnostic entrainment + + real(kind_phys), parameter :: dcon = 25.e-6_kind_phys + real(kind_phys), parameter :: mucon = 5.3_kind_phys + real(kind_phys) negadq + logical doliq + + +! +!--------------------------Data statements------------------------------ + + scheme_name = "zm_convr_run" + errmsg = '' + errflg = 0 +! +! Set internal variable "msg" (convection limit) to "limcnv-1" +! + msg = limcnv - 1 +! +! initialize necessary arrays. +! zero out variables not used in cam + + dmpdz(:,:)=dmpdz_param !+tht initialise value for entrainment rate + + qtnd(:,:) = 0._kind_phys + heat(:,:) = 0._kind_phys + mcon(:,:) = 0._kind_phys + rliq(:ncol) = 0._kind_phys + rice(:ncol) = 0._kind_phys + +! +! initialize convective tendencies +! + prec(:ncol) = 0._kind_phys + do k = 1,pver + do i = 1,ncol + dqdt(i,k) = 0._kind_phys + dsdt(i,k) = 0._kind_phys + dudt(i,k) = 0._kind_phys + dvdt(i,k) = 0._kind_phys + cme(i,k) = 0._kind_phys + rprd(i,k) = 0._kind_phys + zdu(i,k) = 0._kind_phys + ql(i,k) = 0._kind_phys + qlg(i,k) = 0._kind_phys + dlf(i,k) = 0._kind_phys + dlg(i,k) = 0._kind_phys + qldeg(i,k) = 0._kind_phys + eurt(i,k) = 0._kind_phys !+tht entr.rate (full) + dif(i,k) = 0._kind_phys + end do + end do + + do i = 1,ncol + pblt(i) = pver + dsubcld(i) = 0._kind_phys + end do + +! +! calculate local pressure (mbs) and height (m) for both interface +! and mid-layer locations. +! + do i = 1,ncol + zs(i) = geos(i)*rgrav + pf(i,pver+1) = paph(i,pver+1)*0.01_kind_phys + zf(i,pver+1) = zi(i,pver+1) + zs(i) + end do + do k = 1,pver + do i = 1,ncol + p(i,k) = pap(i,k)*0.01_kind_phys + pf(i,k) = paph(i,k)*0.01_kind_phys + z(i,k) = zm(i,k) + zs(i) + zf(i,k) = zi(i,k) + zs(i) + end do + end do + + do k = pver - 1,msg + 1,-1 + do i = 1,ncol + if (abs(z(i,k)-zs(i)-pblh(i)) < (zf(i,k)-zf(i,k+1))*0.5_kind_phys) pblt(i) = k + end do + end do +! +! store incoming specific humidity field for subsequent calculation +! of precipitation (through change in storage). +! define dry static energy (normalized by cp). +! + do k = 1,pver + do i = 1,ncol + q(i,k) = qh(i,k) +!+tht moist thermo + s(i,k) = t(i,k) + (grav/((1._kind_phys+zv*q(i,k))*cpres))*z(i,k) +!-tht + tp(i,k)=0.0_kind_phys + shat(i,k) = s(i,k) + qhat(i,k) = q(i,k) + end do + end do + + do i = 1,ncol + capeg(i) = 0._kind_phys + lclg(i) = 1 + lelg(i) = pver + maxg(i) = 1 + tlg(i) = 400._kind_phys + dsubcld(i) = 0._kind_phys + end do + + + ! Evaluate Tparcel, qs(Tparcel), buoyancy and CAPE, + ! lcl, lel, parcel launch level at index maxi()=hmax + + call buoyan_dilute(ncol ,pver , & + cpliq ,latice ,cpwv ,rh2o ,& + q ,t ,p ,z ,pf , & + tp ,qstp ,tl ,rl ,cape , & !tht + pblt ,lcl ,lel ,lon ,maxi , & + rgas ,grav ,cpres ,msg , & + zi ,zs ,tpert ,landfrac,dmpdz, & !tht + lat ,long ,errmsg ,errflg) + +! +! determine whether grid points will undergo some deep convection +! (ideep=1) or not (ideep=0), based on values of cape,lcl,lel +! (require cape.gt. 0 and lel capelmt) then + !if (.not.use_cin .or. cin(i).lt.cape(i)*cin_threshd) then !+tht: disabled + lengath = lengath + 1 + ideep(lengath) = i + indxd(lengath) = i !+tht sub-index + !endif + end if + end do + +! do ii=1,lengath +! i=indxd(ii) +! ideep(ii)=i !+tht keeping ideep and indxd distinguished for possible different use of CIN +! end do + + if (lengath.eq.0) return +! +! obtain gathered arrays necessary for ensuing calculations. +! + do k = 1,pver + do i = 1,lengath + dp(i,k) = 0.01_kind_phys*dpp(ideep(i),k) + qg(i,k) = q(ideep(i),k) + tg(i,k) = t(ideep(i),k) + pg(i,k) = p(ideep(i),k) + zg(i,k) = z(ideep(i),k) + sg(i,k) = s(ideep(i),k) + tpg(i,k) = tp(ideep(i),k) + zfg(i,k) = zf(ideep(i),k) + qstpg(i,k) = qstp(ideep(i),k) + ug(i,k) = 0._kind_phys + vg(i,k) = 0._kind_phys + end do + end do + +! + do i = 1,lengath + zfg(i,pver+1) = zf(ideep(i),pver+1) + end do + do i = 1,lengath + capeg(i) = cape(ideep(i)) + lclg(i) = lcl(ideep(i)) + lelg(i) = lel(ideep(i)) + maxg(i) = maxi(ideep(i)) + tlg(i) = tl(ideep(i)) + landfracg(i) = landfrac(ideep(i)) + end do +! +! calculate sub-cloud layer pressure "thickness" for use in +! closure and tendency routines. +! + do k = msg + 1,pver + do i = 1,lengath + if (k >= maxg(i)) then + dsubcld(i) = dsubcld(i) + dp(i,k) + end if + end do + end do +! +! define array of factors (alpha) which defines interfacial +! values, as well as interfacial values for (q,s) used in +! subsequent routines. +! + do k = msg + 2,pver + do i = 1,lengath + sdifr = 0._kind_phys + qdifr = 0._kind_phys + if (sg(i,k) > 0._kind_phys .or. sg(i,k-1) > 0._kind_phys) & + sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) + if (qg(i,k) > 0._kind_phys .or. qg(i,k-1) > 0._kind_phys) & + qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) + if (sdifr > 1.E-6_kind_phys) then + shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) + else + shat(i,k) = 0.5_kind_phys* (sg(i,k)+sg(i,k-1)) + end if + if (qdifr > 1.E-6_kind_phys) then + qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) + else + qhat(i,k) = 0.5_kind_phys* (qg(i,k)+qg(i,k-1)) + end if + end do + end do +! +! obtain cloud properties. +! + + call cldprp(ncol ,pver ,pverp ,cpliq , & + latice ,cpwv ,rh2o ,& + qg ,tg ,ug ,vg ,pg , & + zg ,sg ,mu ,eu ,du , & + md ,ed ,sd ,qd ,mc , & + qu ,su ,zfg ,qs ,hmn , & + hsat ,shat ,qlg , & + cmeg ,maxg ,lelg ,jt ,jlcl , & + maxg ,j0 ,jd ,rl ,lengath , & + rgas ,grav ,cpres ,msg , & + evpg ,cug ,rprdg ,limcnv ,landfracg , & + qldeg ,qhat ) + +!=================================================================================== +!!++tht second call to buoyan_dilute for new CAPE using entrainment rate from CLDPRP + if (second_call) then + + do i = 1,lengath + hk=0._kind_phys + dmpdz(ideep(i),:) = 1._kind_phys ! large value 3D + dmsm(i)=0._kind_phys + do k = pver,msg+1,-1 + if (eu(i,k).gt.0_kind_phys) then + dmsm(i) = dmsm(i)-eu(i,k) + hk=hk+1._kind_phys + endif + enddo + if (hk.gt.0) then + dmsm(i) = dmsm(i)/hk + dmpdz(ideep(i),:) = dmsm(i) + endif + enddo + + call buoyan_dilute(ncol ,pver , & + cpliq ,latice ,cpwv ,rh2o ,& + q ,t ,p ,z ,pf , & + tp ,qstp ,tl ,rl ,cape , & + pblt ,lcl ,lel ,lon ,maxi , & + rgas ,grav ,cpres ,msg , & + zi ,zs ,tpert ,landfrac,dmpdz, & !tht + lat ,long ,errmsg ,errflg) + + !------------------------------------------------------------------------------- + !+tht: retrigger? + if (retrigger) then + lengath = 0 + ideep(:)= 0 + indxd(:)= 0 + do i=1,ncol + if (cape(i) > capelmt) then + !if (.not.use_cin .or. cin(i).lt.cape(i)*cin_threshd) then !+tht: disabled + lengath = lengath + 1 + indxd(lengath) = i !+tht sub-index + !endif + end if + end do + if (lengath.eq.0) return + do ii=1,lengath + i=indxd(ii) + ideep(ii)=i !+tht keeping ideep and indxd distinguished for possible different use of CIN + end do + !---- + ! shorten all gathered arrays to new triggered subset + do k = 1,pver + do i = 1,lengath + dp(i,k) = 0.01_kind_phys*dpp(ideep(i),k) + qg(i,k) = q(ideep(i),k) + tg(i,k) = t(ideep(i),k) + pg(i,k) = p(ideep(i),k) + zg(i,k) = z(ideep(i),k) + sg(i,k) = s(ideep(i),k) + tpg(i,k) = tp(ideep(i),k) + zfg(i,k) = zf(ideep(i),k) + qstpg(i,k) = qstp(ideep(i),k) + ug(i,k) = 0._kind_phys + vg(i,k) = 0._kind_phys + end do + end do + do i = 1,lengath + zfg(i,pver+1) = zf(ideep(i),pver+1) + end do + do i = 1,lengath + capeg(i) = cape(ideep(i)) + lclg(i) = lcl(ideep(i)) + lelg(i) = lel(ideep(i)) + maxg(i) = maxi(ideep(i)) + tlg(i) = tl(ideep(i)) + landfracg(i) = landfrac(ideep(i)) + dsubcld(i) = 0._kind_phys + end do + do k = msg + 1,pver + do i = 1,lengath + if (k >= maxg(i)) then + dsubcld(i) = dsubcld(i) + dp(i,k) + end if + end do + end do + do k = msg + 2,pver + do i = 1,lengath + sdifr = 0._kind_phys + qdifr = 0._kind_phys + if (sg(i,k) > 0._kind_phys .or. sg(i,k-1) > 0._kind_phys) & + sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) + if (qg(i,k) > 0._kind_phys .or. qg(i,k-1) > 0._kind_phys) & + qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) + if (sdifr > 1.E-6_kind_phys) then + shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) + else + shat(i,k) = 0.5_kind_phys* (sg(i,k)+sg(i,k-1)) + end if + if (qdifr > 1.E-6_kind_phys) then + qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) + else + qhat(i,k) = 0.5_kind_phys* (qg(i,k)+qg(i,k-1)) + end if + end do + end do + ! tesbus dereggirt wen ot syarra derethag lla netrosh + !---- + else ! end retrigger=T + do k = 1,pver + do i = 1,lengath + tpg(i,k) = tp(ideep(i),k) + zfg(i,k) = zf(ideep(i),k) + qstpg(i,k) = qstp(ideep(i),k) + end do + end do + do i = 1,lengath + capeg(i) = cape(ideep(i)) + lclg(i) = lcl(ideep(i)) + lelg(i) = lel(ideep(i)) + maxg(i) = maxi(ideep(i)) + tlg(i) = tl(ideep(i)) + end do + endif ! end retrigger=F + !------------------------------------------------------------------------------- + + call cldprp(ncol ,pver ,pverp ,cpliq , & + latice ,cpwv ,rh2o ,& + qg ,tg ,ug ,vg ,pg , & + zg ,sg ,mu ,eu ,du , & + md ,ed ,sd ,qd ,mc , & + qu ,su ,zfg ,qs ,hmn , & + hsat ,shat ,qlg , & + cmeg ,maxg ,lelg ,jt ,jlcl , & + maxg ,j0 ,jd ,rl ,lengath , & + rgas ,grav ,cpres ,msg , & + evpg ,cug ,rprdg ,limcnv ,landfracg , & + qldeg ,qhat ) + + endif ! end second_call=F +!!--tht +!=================================================================================== + +!+tht + do k = msg + 1,pver + do i = 1,lengath + eurt (ideep(i),k)=-dmpdz(ideep(i),k) !+tht entr.rate 3D + enddo + enddo +!-tht + +! +! convert detrainment from units of "1/m" to "1/mb". +! + + do k = msg + 1,pver + do i = 1,lengath + du (i,k) = du (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + eu (i,k) = eu (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + ed (i,k) = ed (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + cug (i,k) = cug (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + cmeg (i,k) = cmeg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + rprdg(i,k) = rprdg(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + evpg (i,k) = evpg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + end do + end do + + call closure(ncol ,pver , & + qg ,tg ,pg ,zg ,sg , & + tpg ,qs ,qu ,su ,mc , & + du ,mu ,md ,qd ,sd , & + qhat ,shat ,dp ,qstpg ,zfg , & + qlg ,dsubcld ,mb ,capeg ,tlg , & + lclg ,lelg ,jt ,maxg ,1 , & + lengath ,rgas ,grav ,cpres ,rl , & + msg ,capelmt ) +! +! limit cloud base mass flux to theoretical upper bound. +! + do i=1,lengath + mumax(i) = 0 + end do + do k=msg + 2,pver + do i=1,lengath + mumax(i) = max(mumax(i), mu(i,k)/dp(i,k)) + end do + end do + + do i=1,lengath + if (mumax(i) > 0._kind_phys) then + mb(i) = min(mb(i),1._kind_phys/(delt*mumax(i))) + else + mb(i) = 0._kind_phys + endif + end do + ! If no_deep_pbl = .true., don't allow convection entirely + ! within PBL (suggestion of Bjorn Stevens, 8-2000) + + if (no_deep_pbl) then + do i=1,lengath + if (zm(ideep(i),jt(i)) < pblh(ideep(i))) mb(i) = 0 + end do + end if + + do k=msg+1,pver + do i=1,lengath + mu (i,k) = mu (i,k)*mb(i) + md (i,k) = md (i,k)*mb(i) + mc (i,k) = mc (i,k)*mb(i) + du (i,k) = du (i,k)*mb(i) + eu (i,k) = eu (i,k)*mb(i) + ed (i,k) = ed (i,k)*mb(i) + cmeg (i,k) = cmeg (i,k)*mb(i) + rprdg(i,k) = rprdg(i,k)*mb(i) + cug (i,k) = cug (i,k)*mb(i) + evpg (i,k) = evpg (i,k)*mb(i) + + end do + end do +! +! compute temperature and moisture changes due to convection. +! + call q1q2_pjr(ncol ,pver ,latice , & + dqdt ,dsdt ,qg ,qs ,qu , & + su ,du ,qhat ,shat ,dp , & + mu ,md ,sd ,qd ,qldeg , & + dsubcld ,jt ,maxg ,1 ,lengath , & + cpres ,rl ,msg , & + dlg ,evpg ,cug) + +! +! gather back temperature and mixing ratio. +! + + do k = msg + 1,pver + do i = 1,lengath +! +! q is updated to compute net precip. +! + q(ideep(i),k) = qh(ideep(i),k) + delt*dqdt(i,k) + qtnd(ideep(i),k) = dqdt (i,k) + cme (ideep(i),k) = cmeg (i,k) + rprd(ideep(i),k) = rprdg(i,k) + zdu (ideep(i),k) = du (i,k) + mcon(ideep(i),k) = mc (i,k) + heat(ideep(i),k) = dsdt (i,k)*cpres + dlf (ideep(i),k) = dlg (i,k) + ql (ideep(i),k) = qlg (i,k) + end do + end do + +! Compute precip by integrating change in water vapor minus detrained cloud water + do k = pver,msg + 1,-1 + do i = 1,ncol + prec(i) = prec(i) - dpp(i,k)* (q(i,k)-qh(i,k)) - dpp(i,k)*(dlf(i,k)+dif(i,k))*delt + end do + end do + +! obtain final precipitation rate in m/s. + do i = 1,ncol + prec(i) = rgrav*max(prec(i),0._kind_phys)/ delt/1000._kind_phys + end do + +! Compute reserved liquid (not yet in cldliq) for energy integrals. +! Treat rliq as flux out bottom, to be added back later. + do k = 1, pver + do i = 1, ncol + rliq(i) = rliq(i) + (dlf(i,k)+dif(i,k))*dpp(i,k)/gravit + rice(i) = rice(i) + dif(i,k)*dpp(i,k)/gravit + end do + end do + rliq(:ncol) = rliq(:ncol) /1000._kind_phys + rice(:ncol) = rice(:ncol) /1000._kind_phys + +! Convert mass flux from reported mb s-1 to kg m-2 s-1 + mcon(:ncol,:pverp) = mcon(:ncol,:pverp) * 100._kind_phys / gravit + + return +end subroutine zm_convr_run + +!========================================================================================= + +subroutine buoyan_dilute( ncol ,pver , & + cpliq ,latice ,cpwv ,rh2o ,& + q ,t ,p ,z ,pf , & + tp ,qstp ,tl ,rl ,cape , & + pblt ,lcl ,lel ,lon ,mx , & + rd ,grav ,cp ,msg , & + zi ,zs ,tpert ,landfrac,dmpdz , & !tht + lat ,long ,errmsg ,errflg) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculates CAPE the lifting condensation level and the convective top +! where buoyancy is first -ve. +! +! Method: Calculates the parcel temperature based on a simple constant +! entraining plume model. CAPE is integrated from buoyancy. +! 09/09/04 - Simplest approach using an assumed entrainment rate for +! testing (dmpdp). +! 08/04/05 - Swap to convert dmpdz to dmpdp +! +! SCAM Logical Switches - DILUTE:RBN - Now Disabled +! --------------------- +! switch(1) = .T. - Uses the dilute parcel calculation to obtain tendencies. +! switch(2) = .T. - Includes entropy/q changes due to condensate loss and freezing. +! switch(3) = .T. - Adds the PBL Tpert for the parcel temperature at all levels. +! +! References: +! Raymond and Blythe (1992) JAS +! +! Author: +! Richard Neale - September 2004 +! +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! +! input arguments +! + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pver + real(kind_phys), intent(in) :: cpliq + real(kind_phys), intent(in) :: latice + real(kind_phys), intent(in) :: cpwv + real(kind_phys), intent(in) :: rh2o + + real(kind_phys), intent(in) :: q(ncol,pver) ! spec. humidity + real(kind_phys), intent(in) :: t(ncol,pver) ! temperature + real(kind_phys), intent(in) :: p(ncol,pver) ! pressure + real(kind_phys), intent(in) :: z(ncol,pver) ! height + real(kind_phys), intent(in) :: pf(ncol,pver+1) ! pressure at interfaces + real(kind_phys), intent(in) :: pblt(ncol) ! index of pbl depth + real(kind_phys), intent(in) :: tpert(ncol) ! perturbation temperature by pbl processes + real(kind_phys), intent(inout) :: dmpdz(ncol,pver) !tht: fractional mass entrainment rate (/m) + +! Use z interface/surface relative values for PBL parcel calculations. + real(kind_phys), intent(in) :: zi(ncol,pver+1) + real(kind_phys), intent(in) :: zs(ncol) + + real(kind_phys), intent(in) :: lat(:) + real(kind_phys), intent(in) :: long(:) + +! +! output arguments +! + + real(kind_phys), intent(out) :: tp(ncol,pver) ! parcel temperature + real(kind_phys), intent(out) :: qstp(ncol,pver) ! saturation mixing ratio of parcel (only above lcl, just q below). + real(kind_phys), intent(out) :: tl(ncol) ! parcel temperature at lcl + real(kind_phys), intent(out) :: cape(ncol) ! convective aval. pot. energy. + integer lcl(ncol) ! + integer lel(ncol) ! + integer lon(ncol) ! level of onset of deep convection + integer mx(ncol) ! level of max moist static energy + + real(kind_phys), intent(in) :: landfrac(ncol) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + +! +!--------------------------Local Variables------------------------------ +! + real(kind_phys) capeten(ncol,5) ! provisional value of cape + real(kind_phys) tv(ncol,pver) ! + real(kind_phys) tpv(ncol,pver) ! + real(kind_phys) buoy(ncol,pver) + + real(kind_phys) a1(ncol) + real(kind_phys) a2(ncol) + real(kind_phys) estp(ncol) + real(kind_phys) pl(ncol) + real(kind_phys) plexp(ncol) + real(kind_phys) hmax(ncol) + real(kind_phys) hmn(ncol) + real(kind_phys) y(ncol) + + logical plge600(ncol) + integer knt(ncol) + integer lelten(ncol,5) + +! Parcel property variables + + real(kind_phys) :: hmn_lev(ncol,pver) ! Vertical profile of moist static energy for each column + real(kind_phys) :: dp_lev(ncol,pver) ! Level dpressure between interfaces + real(kind_phys) :: hmn_zdp(ncol,pver) ! Integrals of hmn_lev*dp_lev at each level + real(kind_phys) :: q_zdp(ncol,pver) ! Integrals of q*dp_lev at each level + real(kind_phys) :: dp_zfrac ! Fraction of vertical grid box below mixing top (usually pblt) + real(kind_phys) :: parcel_dz(ncol) ! Depth of parcel mixing (usually parcel_hscale*parcel_dz) + real(kind_phys) :: parcel_ztop(ncol) ! Height of parcel mixing (usually parcel_ztop+zm(nlev)) + real(kind_phys) :: parcel_dp(ncol) ! Pressure integral over parcel mixing depth (usually pblt) + real(kind_phys) :: parcel_hdp(ncol) ! Pressure*MSE integral over parcel mixing depth (usually pblt) + real(kind_phys) :: parcel_qdp(ncol) ! Pressure*q integral over parcel mixing depth (usually pblt) + real(kind_phys) :: pbl_dz(ncol) ! Previously diagnosed PBL height + real(kind_phys) :: hpar(ncol) ! Initial MSE of the parcel + real(kind_phys) :: qpar(ncol) ! Initial humidity of the parcel + real(kind_phys) :: ql(ncol) ! Initial parcel humidity (for ientropy routine) + real(kind_phys) :: zl(ncol) !tht Initial parcel GPH (for ienthalpy routine) + integer :: ipar ! Index for top of parcel mixing/launch level. + + real(kind_phys) cp + real(kind_phys) e + real(kind_phys) grav + + integer i + integer k + integer msg + integer n + + real(kind_phys) rd + real(kind_phys) rl + +!----------------------------------------------------------------------- +! + do n = 1,5 + do i = 1,ncol + lelten(i,n) = pver + capeten(i,n) = 0._kind_phys + end do + end do + + do i = 1,ncol +!tht: n.b.: with new test parcel calculation that includes parcel kinetic energy, +! the use of PBLT-dependent launch level and of CIN may be re-assessed + if(tht_tweaks) then + if (lparcel_pbl) then + lon(i) = pver ! re-assess + else + lon(i) = min(pver,nint(pblt(i))+2) + endif + else + lon(i) = pver + endif + knt(i) = 0 + lel(i) = pver + mx(i) = lon(i) + cape(i) = 0._kind_phys + hmax(i) = 0._kind_phys + pbl_dz(i) = z(i,nint(pblt(i)))-zs(i) ! mid-point z (zm) reference to PBL depth + parcel_dz(i) = max(zi(i,pver),parcel_hscale*pbl_dz(i)) ! PBL mixing depth [parcel_hscale*Boundary, but no thinner than zi(i,pver)] + parcel_ztop(i) = parcel_dz(i)+zs(i) ! PBL mixing height ztop this is wrt zs=0 + parcel_hdp(i) = 0._kind_phys + parcel_dp(i) = 0._kind_phys + parcel_qdp(i) = 0._kind_phys + hpar(i) = 0._kind_phys + qpar(i) = 0._kind_phys + end do + + tp(:ncol,:) = t(:ncol,:) + qstp(:ncol,:) = q(:ncol,:) + hmn_lev(:ncol,:) = 0._kind_phys + +!!! Initialize tv and buoy for output. +!!! tv=tv : tpv=tpv : qstp=q : buoy=0. + if (tht_tweaks) then ! use system constants + tv(:ncol,:) = t(:ncol,:) *(1._kind_phys+q(:ncol,:)/eps1) / (1._kind_phys+q(:ncol,:)) + else + tv(:ncol,:) = t(:ncol,:) *(1._kind_phys+1.608_kind_phys*q(:ncol,:))/ (1._kind_phys+q(:ncol,:)) + endif + tpv(:ncol,:) = tv(:ncol,:) + buoy(:ncol,:) = 0._kind_phys + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Mix the parcel over a certain dp or dz and take the launch level as the top level +! of this mixing region and the parcel properties as this mixed value +! Should be well mixed by other processes in the very near PBL. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +if (lparcel_pbl) then + +! Vertical profile of MSE and pressure weighted of the same. + if(tht_thermo) then + hmn_lev(:ncol,1:pver) =(cp+q(:ncol,1:pver)*cpliq)*t(:ncol,1:pver)/(1._kind_phys+q(:ncol,1:pver)) & + +(1._kind_phys+q(:ncol,1:pver)/eps1)/(1._kind_phys+q(:ncol,1:pver))*grav*z(:ncol,1:pver) & + +(rl-(cpliq-cpwv)*(t(:ncol,1:pver)-tfreez))*q(:ncol,1:pver) + else + hmn_lev(:ncol,1:pver) = cp*t(:ncol,1:pver) + grav*z(:ncol,1:pver) + rl*q(:ncol,1:pver) + endif + dp_lev(:ncol,1:pver) = pf(:ncol,2:pver+1)-pf(:ncol,1:pver) + hmn_zdp(:ncol,1:pver) = hmn_lev(:ncol,1:pver)*dp_lev(:ncol,1:pver) + q_zdp(:ncol,1:pver) = q(:ncol,1:pver)*dp_lev(:ncol,1:pver) + +! Mix profile over vertical length scale of 0.5*PBLH. + do i = 1,ncol ! Loop columns + do k = pver,msg + 1,-1 + + if (zi(i,k+1)<= parcel_dz(i)) then ! Has to be relative to near-surface layer center elevation + ipar = k + + if (k == pver) then ! Always at least the full depth of lowest model layer. + dp_zfrac = 1._kind_phys + else + ! Fraction of grid cell depth (mostly 1, except when parcel_ztop is in between levels. + dp_zfrac = min(1._kind_phys,(parcel_dz(i)-zi(i,k+1))/(zi(i,k)-zi(i,k+1))) + end if + + parcel_hdp(i) = parcel_hdp(i)+hmn_zdp(i,k)*dp_zfrac ! Sum parcel profile up to a certain level. + parcel_qdp(i) = parcel_qdp(i)+q_zdp(i,k)*dp_zfrac ! Sum parcel profile up to a certain level. + parcel_dp(i) = parcel_dp(i)+dp_lev(i,k)*dp_zfrac ! SUM dp's for weighting of parcel_hdp + + end if + end do + hpar(i) = parcel_hdp(i)/parcel_dp(i) + qpar(i) = parcel_qdp(i)/parcel_dp(i) + mx(i) = ipar + end do + +else ! Default method finding level of MSE maximum (nlev sensitive though) + ! + ! set "launching" level(mx) to be at maximum moist static energy. + ! search for this level stops at planetary boundary layer top. + ! + do k = pver,msg + 1,-1 + do i = 1,ncol + if(tht_thermo) then + hmn(i) =(cp+q(i,k)*cpliq)*t(i,k)/(1._kind_phys+q(i,k)) & + +(1._kind_phys+q(i,k)/eps1)/(1._kind_phys+q(i,k))*grav*z(i,k) & + +(rl-(cpliq-cpwv)*(t(i,k)-tfreez))*q(i,k) + else + hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) + endif + if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then + hmax(i) = hmn(i) + mx(i) = k + end if + end do + end do + +end if ! Default method of determining parcel launch properties. + +! LCL dilute calculation - initialize to mx(i) +! Determine lcl in parcel_dilute and get pl,tl after parcel_dilute +! Original code actually sets LCL as level above wher condensate forms. +! Therefore in parcel_dilute lcl(i) will be at first level where qsmix < qtmix. + +if (lparcel_pbl) then + +! For parcel dilute need to invert hpar and qpar. +! Now need to supply ql(i) as it is mixed parcel version, just q(i,max(i)) in default + + do i = 1,ncol ! Initialise LCL variables. + lcl(i) = mx(i) + tl(i) = (hpar(i)-rl*qpar(i)-grav*parcel_ztop(i))/cp + ql(i) = qpar(i) + if(tht_thermo) & !tht: not exact but should be good enough + tl(i) = (hpar(i)-(rl-(cpliq-cpwv)*(tl(i)-tfreez))*ql(i) & + -(1._kind_phys+ql(i)/eps1)/(1._kind_phys+ql(i))*grav*parcel_ztop(i)) & + /((cp+qpar(i)*cpliq)/(1._kind_phys+ql(i))) + pl(i) = p(i,mx(i)) + zl(i) = parcel_ztop(i) + end do + +else + do i = 1,ncol + lcl(i) = mx(i) + tl(i) = t(i,mx(i)) + zl(i) = z(i,mx(i)) + ql(i) = q(i,mx(i)) + pl(i) = p(i,mx(i)) + end do + +end if ! Mixed parcel properties + +! +! dilute plume buoyancy calculation without exclamation marks. +! + call parcel_dilute(ncol, pver, cpliq, cpwv, rh2o, latice, msg, mx, p, z, t, q, & !tht + tpert, tp, tpv, qstp, pl, tl, zl, ql, lcl, & !tht + landfrac, dmpdz, lat, long, errmsg, errflg) !tht + +! If lcl is above the nominal level of non-divergence (600 mbs), +! no deep convection is permitted (ensuing calculations +! skipped and cape retains initialized value of zero). +! + do i = 1,ncol + plge600(i) = pl(i).ge.plclmin ! Just change to always allow buoy calculation. + end do + +! +! Main buoyancy calculation. +! + do k = pver,msg + 1,-1 + do i=1,ncol + if (k <= mx(i) .and. plge600(i)) then ! Define buoy from launch level to cloud top. + if (tht_tweaks) then + tv(i,k) = t(i,k)* (1._kind_phys+q(i,k)/eps1)/ (1._kind_phys+q(i,k)) + buoy(i,k) = tpv(i,k) - tv(i,k) +(tiedke_add*(1._kind_phys-landfrac(i))+tiedke_lnd*landfrac(i)) + else + tv(i,k) = t(i,k)* (1._kind_phys+1.608_kind_phys*q(i,k))/ (1._kind_phys+q(i,k)) + buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add + endif + else + qstp(i,k) = q(i,k) + tp(i,k) = t(i,k) + tpv(i,k) = tv(i,k) + endif + end do + end do + + + +!------------------------------------------------------------------------------- +! beginning from one below top (first level p>40hPa, msg) check for at most +! num_cin levels of neutral buoyancy (LELten) and compute CAPEten between LCL +! and each of them (tht) + + do k = msg + 2,pver + do i = 1,ncol + if (k < lcl(i) .and. plge600(i)) then + if (buoy(i,k+1) > 0._kind_phys .and. buoy(i,k) <= 0._kind_phys) then + knt(i) = min(num_cin,knt(i) + 1) + lelten(i,knt(i)) = k + end if + end if + end do + end do +! +! calculate convective available potential energy (cape). +! + do n = 1,num_cin + do k = msg + 1,pver + do i = 1,ncol + if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then + capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k)) + end if + end do + end do + end do +! +! find maximum cape from all possible tentative capes from +! one sounding, +! and use it as the final cape, april 26, 1995 +! + do n = 1,num_cin + do i = 1,ncol + if (capeten(i,n) > cape(i)) then + cape(i) = capeten(i,n) + lel(i) = lelten(i,n) + end if + end do + end do +! +! put lower bound on cape for diagnostic purposes. +! + do i = 1,ncol + cape(i) = max(cape(i), 0._kind_phys) + end do +! + return +end subroutine buoyan_dilute + +subroutine parcel_dilute (ncol, pver, cpliq, cpwv, rh2o, latice, msg, klaunch, p, z, t, q, & !tht + tpert, tp, tpv, qstp, pl, tl, zl, ql, lcl, & !tht + landfrac,dmpdz,lat,long,errmsg,errflg) !tht + +! Routine to determine +! 1. Tp - Parcel temperature +! 2. qstp - Saturated mixing ratio at the parcel temperature. + +!-------------------- +implicit none +!-------------------- + +integer, intent(in) :: ncol +integer, intent(in) :: pver +real(kind_phys), intent(in) :: cpliq +real(kind_phys), intent(in) :: cpwv +real(kind_phys), intent(in) :: rh2o +real(kind_phys), intent(in) :: latice +integer, intent(in) :: msg + +integer, intent(in), dimension(ncol) :: klaunch(ncol) + +real(kind_phys), intent(in), dimension(ncol,pver) :: p +real(kind_phys), intent(in), dimension(ncol,pver) :: t +real(kind_phys), intent(in), dimension(ncol,pver) :: z !tht +real(kind_phys), intent(in), dimension(ncol,pver) :: q +real(kind_phys), intent(in), dimension(ncol) :: tpert ! PBL temperature perturbation. + +real(kind_phys), intent(in) :: lat(:) +real(kind_phys), intent(in) :: long(:) + +real(kind_phys), intent(inout), dimension(ncol,pver) :: tp ! Parcel temp. +real(kind_phys), intent(inout), dimension(ncol,pver) :: qstp ! Parcel water vapour (sat value above lcl). +real(kind_phys), intent(inout), dimension(ncol) :: tl ! Actual temp of LCL. +real(kind_phys), intent(inout), dimension(ncol) :: ql ! Actual humidity of LCL +real(kind_phys), intent(inout), dimension(ncol) :: pl ! Actual pressure of LCL. +real(kind_phys), intent(inout), dimension(ncol) :: zl !tht GPH of LCL. + +integer, intent(inout), dimension(ncol) :: lcl ! Lifting condesation level (first model level with saturation). + +real(kind_phys), intent(out), dimension(ncol,pver) :: tpv ! Define tpv within this routine. + +character(len=512), intent(out) :: errmsg +integer, intent(out) :: errflg + + + +real(kind_phys), intent(in), dimension(ncol) :: landfrac +real(kind_phys), intent(inout), dimension(ncol,pver) :: dmpdz !tht +!-------------------- + +! Have to be careful as s is also dry static energy. +!+tht +! in the mods below, s is used both as enthalpy (moist s.e.) and entropy +!-tht + +! If we are to retain the fact that CAM loops over grid-points in the internal +! loop then we need to dimension sp,atp,mp,xsh2o with ncol. + + +real(kind_phys) tmix(ncol,pver) ! Tempertaure of the entraining parcel. +real(kind_phys) qtmix(ncol,pver) ! Total water of the entraining parcel. +real(kind_phys) qsmix(ncol,pver) ! Saturated mixing ratio at the tmix. +real(kind_phys) smix(ncol,pver) ! Entropy of the entraining parcel. +real(kind_phys) xsh2o(ncol,pver) ! Precipitate lost from parcel. +real(kind_phys) ds_xsh2o(ncol,pver) ! Entropy change due to loss of condensate. +real(kind_phys) ds_freeze(ncol,pver) ! Entropy change sue to freezing of precip. + +real(kind_phys) mp(ncol) ! Parcel mass flux. +real(kind_phys) qtp(ncol) ! Parcel total water. +real(kind_phys) sp(ncol) ! Parcel entropy. + +real(kind_phys) sp0(ncol) ! Parcel launch entropy. +real(kind_phys) qtp0(ncol) ! Parcel launch total water. +real(kind_phys) mp0(ncol) ! Parcel launch relative mass flux. + +real(kind_phys) lwmax ! Maximum condesate that can be held in cloud before rainout. +real(kind_phys) dmpdp ! Parcel fractional mass entrainment rate (/mb). +!real(kind_phys) dmpdz ! Parcel fractional mass entrainment rate (/m) +real(kind_phys) dpdz,dzdp ! Hydrstatic relation and inverse of. +real(kind_phys) senv ! Environmental entropy at each grid point. +real(kind_phys) qtenv ! Environmental total water " " ". +real(kind_phys) penv ! Environmental total pressure " " ". +real(kind_phys) tenv ! Environmental total temperature " " ". +real(kind_phys) zenv !tht Environmental GPH +real(kind_phys) new_s ! Hold value for entropy after condensation/freezing adjustments. +real(kind_phys) new_q ! Hold value for total water after condensation/freezing adjustments. +real(kind_phys) dp ! Layer thickness (center to center) +real(kind_phys) tfguess ! First guess for entropy inversion - crucial for efficiency! +real(kind_phys) tscool ! Super cooled temperature offset (in degC) (eg -35). + +real(kind_phys) qxsk, qxskp1 ! LCL excess water (k, k+1) +real(kind_phys) dsdp, dqtdp, dqxsdp ! LCL s, qt, p gradients (k, k+1) +real(kind_phys) slcl,qtlcl,qslcl ! LCL s, qt, qs values. + +integer rcall ! Number of ientropy call for errors recording +integer nit_lheat ! Number of iterations for condensation/freezing loop. +integer i,k,ii ! Loop counters. + +real(kind_phys) est !tht + +!====================================================================== +! SUMMARY +! +! 9/9/04 - Assumes parcel is initiated from level of maxh (klaunch) +! and entrains at each level with a specified entrainment rate. +! +! 15/9/04 - Calculates lcl(i) based on k where qsmix is first < qtmix. +! +!====================================================================== +! +! Set some values that may be changed frequently. +! + +nit_lheat = 2 ! iterations for ds,dq changes from condensation freezing. +if (.not.tht_tweaks) dmpdz(:,:)=dmpdz_param ! Entrainment rate. (-ve for /m) + +lwmax = 1.e-3_kind_phys ! Need to put formula in for this. +tscool = 0.0_kind_phys ! Temp at which water loading freezes in the cloud. +!lwmax = 1.e10_kind_phys ! tht: don't precipitate +!tscool =-10._kind_phys ! tht: allow even just mild supercooling?! + +qtmix=0._kind_phys +smix=0._kind_phys + +qtenv = 0._kind_phys +senv = 0._kind_phys +tenv = 0._kind_phys +zenv = 0._kind_phys !tht +penv = 0._kind_phys + +qtp0 = 0._kind_phys +sp0 = 0._kind_phys +mp0 = 0._kind_phys + +qtp = 0._kind_phys +sp = 0._kind_phys +mp = 0._kind_phys + +new_q = 0._kind_phys +new_s = 0._kind_phys + +! **** Begin loops **** + +do k = pver, msg+1, -1 + do i=1,ncol + +! Initialize parcel values at launch level. + if (k == klaunch(i)) then + if (lparcel_pbl) then ! Modifcations to parcel properties if lparcel_pbl set. + qtp0(i) = ql(i) ! Parcel launch q (PBL mixed value). + if(tht_tweaks) then + sp0(i) = enthalpy(tl(i),pl(i),qtp0(i),zl(i),cpliq,cpwv,rh2o) + else + sp0(i) = entropy(tl(i),pl(i),qtp0(i),cpliq,cpwv,rh2o) ! Parcel launch entropy could be a mixed parcel. + endif + else + qtp0(i) = q(i,k) ! Parcel launch total water (assuming subsaturated) + if(tht_tweaks) then + sp0(i) = enthalpy(t(i,k),p(i,k),qtp0(i),z(i,k),cpliq,cpwv,rh2o) + else + sp0(i) = entropy(t(i,k),p(i,k),qtp0(i),cpliq,cpwv,rh2o) ! Parcel launch entropy. + endif + end if + mp0(i) = 1._kind_phys ! Parcel launch relative mass (i.e. 1 parcel stays 1 parcel for dmpdp=0, undilute). + smix(i,k) = sp0(i) + qtmix(i,k) = qtp0(i) + if(tht_tweaks) then + if (lparcel_pbl) then !+tht + tfguess = t(i,k) + rcall = 1 + call ienthalpy(rcall,i,smix(i,k),p(i,k),z(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,& + lat(i), long(i), errmsg,errflg) + else +!+tht: if .not.lparcel_pbl: since the function to invert for T is identical with +! sp0(i)=entropy(t), the result is t(i,k) (verified 21/2/2014) + tmix(i,k) = t(i,k) + call qsat_hPa(tmix(i,k),p(i,k), est, qsmix(i,k)) + endif + else + tfguess = t(i,k) + rcall = 1 + call ientropy (rcall,i,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,& + lat(i), long(i), errmsg,errflg) + endif + end if + +! Entraining levels + + if (k < klaunch(i)) then +! Set environmental values for this level. + dp = (p(i,k)-p(i,k+1)) ! In -ve mb as p decreasing with height - difference between center of layers. + qtenv = 0.5_kind_phys*(q(i,k)+q(i,k+1)) ! Total water of environment. + tenv = 0.5_kind_phys*(t(i,k)+t(i,k+1)) + penv = 0.5_kind_phys*(p(i,k)+p(i,k+1)) + zenv = 0.5_kind_phys*(z(i,k)+z(i,k+1)) !tht + + if (tht_tweaks) then + senv = enthalpy(tenv,penv,qtenv,zenv,cpliq,cpwv,rh2o) ! Enthalpy of environment. + else + senv = entropy(tenv,penv,qtenv,cpliq,cpwv,rh2o) ! Entropy of environment. + endif + +! Determine fractional entrainment rate /pa given value /m. + dpdz = -(penv*grav)/(rgas*tenv) ! in mb/m since p in mb. + dzdp = 1._kind_phys/dpdz ! in m/mb + dmpdp = dmpdz(i,k)*dzdp !tht + +! Sum entrainment to current level +! entrains q,s out of intervening dp layers, in which linear variation is assumed +! so really it entrains the mean of the 2 stored values. + sp(i) = sp(i) - dmpdp*dp*senv + qtp(i) = qtp(i) - dmpdp*dp*qtenv + mp(i) = mp(i) - dmpdp*dp + +! Entrain s and qt to next level. + smix(i,k) = (sp0(i) + sp(i)) / (mp0(i) + mp(i)) + qtmix(i,k) = (qtp0(i) + qtp(i)) / (mp0(i) + mp(i)) + +! Invert entropy from s and q to determine T and saturation-capped q of mixture. +! t(i,k) used as a first guess so that it converges faster. + tfguess = tmix(i,k+1) + rcall = 2 + if (tht_tweaks) then + call ienthalpy(rcall,i,smix(i,k),p(i,k),z(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,lat(i),& + long(i),errmsg,errflg) + else + call ientropy(rcall,i,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,lat(i),& + long(i),errmsg,errflg) + endif + +! Determine if this is lcl of this column if qsmix <= qtmix. +! FIRST LEVEL where this happens on ascending. + if (qsmix(i,k) <= qtmix(i,k) .and. qsmix(i,k+1) > qtmix(i,k+1)) then + lcl(i) = k + qxsk = qtmix(i,k) - qsmix(i,k) + qxskp1 = qtmix(i,k+1) - qsmix(i,k+1) + dqxsdp = (qxsk - qxskp1)/dp + pl(i) = p(i,k+1) - qxskp1/dqxsdp ! pressure level of actual lcl. + zl(i) = z(i,k+1) - qxskp1/dqxsdp *dzdp !tht + dsdp = (smix(i,k) - smix(i,k+1))/dp + dqtdp = (qtmix(i,k) - qtmix(i,k+1))/dp + slcl = smix(i,k+1) + dsdp* (pl(i)-p(i,k+1)) + qtlcl = qtmix(i,k+1) + dqtdp*(pl(i)-p(i,k+1)) + + tfguess = tmix(i,k) + rcall = 3 + if (tht_tweaks) then + call ienthalpy(rcall,i,slcl,pl(i),zl(i),qtlcl,tl(i),qslcl,tfguess,cpliq,cpwv,rh2o,lat(i), long(i), errmsg,errflg) + else + call ientropy (rcall,i,slcl,pl(i),qtlcl,tl(i),qslcl,tfguess,cpliq,cpwv,rh2o,lat(i), long(i), errmsg,errflg) + endif + + endif +! + end if ! k < klaunch + + + end do ! Levels loop +end do ! Columns loop + +! many lines of meaningless comment with bad orthography and lost of exclamation marks + +xsh2o = 0._kind_phys +ds_xsh2o = 0._kind_phys +ds_freeze = 0._kind_phys + +do k = pver, msg+1, -1 + do i=1,ncol + +! Initialize variables at k=klaunch + + if (k == klaunch(i)) then + +! Set parcel values at launch level assume no liquid water. + + tp(i,k) = tmix(i,k) + qstp(i,k) = q(i,k) + if (tht_tweaks) then + tpv(i,k) = (tp(i,k) + tpert(i)) * (1._kind_phys+qstp(i,k)/eps1) / (1._kind_phys+qstp(i,k)) + else + tpv(i,k) = (tp(i,k) + tpert(i)) * (1._kind_phys+1.608_kind_phys*qstp(i,k)) / (1._kind_phys+qstp(i,k)) + endif + + end if + + if (k < klaunch(i)) then + + if (tht_tweaks) then + smix(i,k)=entropy(tmix(i,k),p(i,k),qtmix(i,k),cpliq,cpwv,rh2o) !+tht make sure to use entropy here + endif + +! Iterate nit_lheat times for s,qt changes. + do ii=0,nit_lheat-1 + +! Rain (xsh2o) is excess condensate, bar LWMAX (Accumulated loss from qtmix). + xsh2o(i,k) = max (0._kind_phys, qtmix(i,k) - qsmix(i,k) - lwmax) + +! Contribution to ds from precip loss of condensate (Accumulated change from smix).(-ve) + ds_xsh2o(i,k) = ds_xsh2o(i,k+1) - cpliq * log (tmix(i,k)/tfreez) * max(0._kind_phys,(xsh2o(i,k)-xsh2o(i,k+1))) +! +! Entropy of freezing: latice times amount of water involved divided by T. + if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) == 0._kind_phys) then ! One off freezing of condensate. + ds_freeze(i,k) = (latice/tmix(i,k)) * max(0._kind_phys,qtmix(i,k)-qsmix(i,k)-xsh2o(i,k)) ! Gain of LH + end if + + if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) /= 0._kind_phys) then ! Continual freezing of additional condensate. + ds_freeze(i,k) = ds_freeze(i,k+1)+(latice/tmix(i,k)) * max(0._kind_phys,(qsmix(i,k+1)-qsmix(i,k))) + end if + +! Adjust entropy and accordingly to sum of ds (be careful of signs). + new_s = smix(i,k) + ds_xsh2o(i,k) + ds_freeze(i,k) + +! Adjust liquid water and accordingly to xsh2o. + new_q = qtmix(i,k) - xsh2o(i,k) + +! Invert entropy to get updated Tmix and qsmix of parcel. + tfguess = tmix(i,k) + rcall =4 + call ientropy (rcall,i,new_s, p(i,k), new_q, tmix(i,k), qsmix(i,k), tfguess,cpliq,cpwv,rh2o,& + lat(i), long(i), errmsg,errflg) + + end do ! Iteration loop for freezing processes. + +! tp - Parcel temp is temp of mixture. +! tpv - Parcel v. temp should be density temp with new_q total water. + tp(i,k) = tmix(i,k) + +! tpv = tprho in the presence of condensate (i.e. when new_q > qsmix) + if (new_q > qsmix(i,k)) then ! Super-saturated so condensate present - reduces buoyancy. + qstp(i,k) = qsmix(i,k) + else ! Just saturated/sub-saturated - no condensate virtual effects. + qstp(i,k) = new_q + end if + if (tht_tweaks) then + tpv(i,k) = (tp(i,k)+tpert(i))* (1._kind_phys+qstp(i,k)/eps1) / (1._kind_phys+ new_q) !+tht + else + tpv(i,k) = (tp(i,k)+tpert(i))* (1._kind_phys+1.608_kind_phys*qstp(i,k)) / (1._kind_phys+ new_q) + endif + + end if ! k < klaunch + + end do ! Loop for columns + +end do ! Loop for vertical levels. + + +return +end subroutine parcel_dilute + +!----------------------------------------------------------------------------------------- +real(kind_phys) function entropy(TK,p,qtot,cpliq,cpwv,rh2o) +!----------------------------------------------------------------------------------------- +! +! TK(K),p(mb),qtot(kg/kg) +! from Raymond and Blyth 1992 +! + real(kind_phys), intent(in) :: p,qtot,TK + real(kind_phys), intent(in) :: cpliq + real(kind_phys), intent(in) :: cpwv + real(kind_phys), intent(in) :: rh2o + + real(kind_phys) :: qv,qst,e,est,L + real(kind_phys), parameter :: pref = 1000._kind_phys + +L = rl - (cpliq - cpwv)*(TK-tfreez) ! T IN CENTIGRADE + +call qsat_hPa(TK, p, est, qst) + +qv = min(qtot,qst) ! Partition qtot into vapor part only. +e = qv*p / (eps1 +qv) + +entropy = (cpres + qtot*cpliq)*log( TK/tfreez) - rgas*log( (p-e)/pref ) + & + L*qv/TK - qv*rh2o*log(qv/qst) + +end FUNCTION entropy + +! +!----------------------------------------------------------------------------------------- +SUBROUTINE ientropy (rcall,icol,s,p,qt,T,qst,Tfg,cpliq,cpwv,rh2o,this_lat,this_lon,errmsg,errflg) +!----------------------------------------------------------------------------------------- +! +! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). +! Inverts entropy, pressure and total water qt +! for T and saturated vapor mixing ratio +! + + integer, intent(in) :: icol, rcall + real(kind_phys), intent(in) :: s, p, Tfg, qt + real(kind_phys), intent(in) :: cpliq + real(kind_phys), intent(in) :: cpwv + real(kind_phys), intent(in) :: rh2o + + real(kind_phys), intent(in) :: this_lat + real(kind_phys), intent(in) :: this_lon + + real(kind_phys), intent(out) :: qst, T + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys) :: est + real(kind_phys) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol + integer :: i + + logical :: converged + + ! Max number of iteration loops. + integer, parameter :: LOOPMAX = 100 + real(kind_phys), parameter :: EPS = 3.e-8_kind_phys + + converged = .false. + + ! Invert the entropy equation -- use Brent's method + ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. + + T = Tfg ! Better first guess based on Tprofile from conv. + + a = Tfg-10 !low bracket + b = Tfg+10 !high bracket + + fa = entropy(a, p, qt,cpliq,cpwv,rh2o) - s + fb = entropy(b, p, qt,cpliq,cpwv,rh2o) - s + + c=b + fc=fb + tol=0.001_kind_phys + + converge: do i=0, LOOPMAX + if ((fb > 0.0_kind_phys .and. fc > 0.0_kind_phys) .or. & + (fb < 0.0_kind_phys .and. fc < 0.0_kind_phys)) then + c=a + fc=fa + d=b-a + ebr=d + end if + if (abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + tol1=2.0_kind_phys*EPS*abs(b)+0.5_kind_phys*tol + xm=0.5_kind_phys*(c-b) + converged = (abs(xm) <= tol1 .or. fb == 0.0_kind_phys) + if (converged) exit converge + + if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then + sbr=fb/fa + if (a == c) then + pbr=2.0_kind_phys*xm*sbr + qbr=1.0_kind_phys-sbr + else + qbr=fa/fc + rbr=fb/fc + pbr=sbr*(2.0_kind_phys*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_kind_phys)) + qbr=(qbr-1.0_kind_phys)*(rbr-1.0_kind_phys)*(sbr-1.0_kind_phys) + end if + if (pbr > 0.0_kind_phys) qbr=-qbr + pbr=abs(pbr) + if (2.0_kind_phys*pbr < min(3.0_kind_phys*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then + ebr=d + d=pbr/qbr + else + d=xm + ebr=d + end if + else + d=xm + ebr=d + end if + a=b + fa=fb + b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) + + fb = entropy(b, p, qt,cpliq,cpwv,rh2o) - s + + end do converge + + T = b + call qsat_hPa(T, p, est, qst) + + if (.not. converged) then + write(errmsg,100) ' ZM_CONV: IENTROPY. Details: call#,icol= ',rcall,icol, & + ' lat: ',this_lat,' lon: ',this_lon, & + ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._kind_phys*qt, & + ' qst(g/kg) = ', 1000._kind_phys*qst,', s(J/kg) = ',s + errflg=1 + end if + +100 format (A,I4,I4,7(A,F6.2)) + +end SUBROUTINE ientropy + +!----------------------------------------------------------------------------------------- +real(kind_phys) function enthalpy(TK,p,qtot,z,cpliq,cpwv,rh2o) +!----------------------------------------------------------------------------------------- +! +! TK(K),p(mb),qtot(kg/kg) +! + real(kind_phys), intent(in) :: p,qtot,TK,z + real(kind_phys), intent(in) :: cpliq + real(kind_phys), intent(in) :: cpwv + real(kind_phys), intent(in) :: rh2o + real(kind_phys) :: qv,qst,e,est,L + +L = rl - (cpliq - cpwv)*(TK-tfreez) + +call qsat_hPa(TK, p, est, qst) +qv = min(qtot,qst) ! Partition qtot into vapor part only. + + enthalpy = (cpres + qtot*cpliq)* TK + L*qv + (1._kind_phys+qtot)*grav*z + +return +end FUNCTION enthalpy + +!----------------------------------------------------------------------------------------- +SUBROUTINE ienthalpy (rcall,icol,s,p,z,qt,T,qst,Tfg,cpliq,cpwv,rh2o,this_lat,this_lon,errmsg,errflg) +!----------------------------------------------------------------------------------------- +! +! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). +! Inverts enthalpy, pressure and total water qt +! for T and saturated vapor mixing ratio +! + + integer, intent(in) :: icol, rcall + real(kind_phys), intent(in) :: s, p, z, Tfg, qt + real(kind_phys), intent(in) :: cpliq + real(kind_phys), intent(in) :: cpwv + real(kind_phys), intent(in) :: rh2o + + real(kind_phys), intent(in) :: this_lat + real(kind_phys), intent(in) :: this_lon + + real(kind_phys), intent(out) :: qst, T + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys) :: est + real(kind_phys) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol + integer :: i + + logical :: converged + + ! Max number of iteration loops. + integer, parameter :: LOOPMAX = 100 + real(kind_phys), parameter :: EPS = 3.e-8_kind_phys + + converged = .false. + + ! Invert the enthalpy equation -- use Brent's method + ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. + + T = Tfg ! Better first guess based on Tprofile from conv. + + a = Tfg-10 !low bracket + b = Tfg+10 !high bracket + + fa = enthalpy(a, p, qt, z, cpliq,cpwv,rh2o) - s + fb = enthalpy(b, p, qt, z, cpliq,cpwv,rh2o) - s + + c=b + fc=fb + tol=0.001_kind_phys + + converge: do i=0, LOOPMAX + if ((fb > 0.0_kind_phys .and. fc > 0.0_kind_phys) .or. & + (fb < 0.0_kind_phys .and. fc < 0.0_kind_phys)) then + c=a + fc=fa + d=b-a + ebr=d + end if + if (abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + tol1=2.0_kind_phys*EPS*abs(b)+0.5_kind_phys*tol + xm=0.5_kind_phys*(c-b) + converged = (abs(xm) <= tol1 .or. fb == 0.0_kind_phys) + if (converged) exit converge + + if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then + sbr=fb/fa + if (a == c) then + pbr=2.0_kind_phys*xm*sbr + qbr=1.0_kind_phys-sbr + else + qbr=fa/fc + rbr=fb/fc + pbr=sbr*(2.0_kind_phys*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_kind_phys)) + qbr=(qbr-1.0_kind_phys)*(rbr-1.0_kind_phys)*(sbr-1.0_kind_phys) + end if + if (pbr > 0.0_kind_phys) qbr=-qbr + pbr=abs(pbr) + if (2.0_kind_phys*pbr < min(3.0_kind_phys*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then + ebr=d + d=pbr/qbr + else + d=xm + ebr=d + end if + else + d=xm + ebr=d + end if + a=b + fa=fb + b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) + + fb = enthalpy(b, p, qt, z, cpliq,cpwv,rh2o) - s + + end do converge + + T = b + call qsat_hPa(T, p, est, qst) + + if (.not. converged) then + write(errmsg,101) ' ZM_CONV: IENTHALPY. Details: call#,icol= ',rcall,icol, & + ' lat: ',this_lat,' lon: ',this_lon, & + ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._kind_phys*qt, & + ' qst(g/kg) = ', 1000._kind_phys*qst,', s(J/kg) = ',s + errflg=1 + end if + +101 format (A,I4,I4,7(A,F6.2)) + +end SUBROUTINE ienthalpy + +subroutine cldprp(ncol ,pver ,pverp ,cpliq , & + latice ,cpwv ,rh2o ,& + q ,t ,u ,v ,p , & + z ,s ,mu ,eu ,du , & + md ,ed ,sd ,qd ,mc , & + qu ,su ,zf ,qst ,hmn , & + hsat ,shat ,ql , & + cmeg ,jb ,lel ,jt ,jlcl , & + mx ,j0 ,jd ,rl ,il2g , & + rd ,grav ,cp ,msg , & + evp ,cu ,rprd ,limcnv ,landfrac, & + qcde ,qhat ) + +!----------------------------------------------------------------------- +! (meaningless comment here) +!----------------------------------------------------------------------- + + implicit none + +!------------------------------------------------------------------------------ +! +! Input arguments +! + integer, intent(in) :: ncol + integer, intent(in) :: pver + integer, intent(in) :: pverp + + real(kind_phys), intent(in) :: cpliq + real(kind_phys), intent(in) :: latice + real(kind_phys), intent(in) :: cpwv + real(kind_phys), intent(in) :: rh2o + + real(kind_phys), intent(in) :: q(ncol,pver) ! spec. humidity of env + real(kind_phys), intent(in) :: t(ncol,pver) ! temp of env + real(kind_phys), intent(in) :: p(ncol,pver) ! pressure of env + real(kind_phys), intent(in) :: z(ncol,pver) ! height of env + real(kind_phys), intent(in) :: s(ncol,pver) ! normalized dry static energy of env + real(kind_phys), intent(in) :: zf(ncol,pverp) ! height of interfaces + real(kind_phys), intent(in) :: u(ncol,pver) ! zonal velocity of env + real(kind_phys), intent(in) :: v(ncol,pver) ! merid. velocity of env + + real(kind_phys), intent(in) :: landfrac(ncol) ! RBN Landfrac + + integer, intent(in) :: jb(ncol) ! updraft base level + integer, intent(in) :: lel(ncol) ! updraft launch level + integer, intent(in) :: mx(ncol) ! updraft base level (same is jb) + integer, intent(out) :: jt(ncol) ! updraft plume top + integer, intent(out) :: jlcl(ncol) ! updraft lifting cond level + integer, intent(out) :: j0(ncol) ! level where updraft begins detraining + integer, intent(out) :: jd(ncol) ! level of downdraft + integer, intent(in) :: limcnv ! convection limiting level + integer, intent(in) :: il2g !CORE GROUP REMOVE + integer, intent(in) :: msg ! missing moisture vals (always 0) + real(kind_phys), intent(in) :: rl ! latent heat of vap + real(kind_phys), intent(in) :: shat(ncol,pver) ! interface values of dry stat energy + real(kind_phys), intent(in) :: qhat(ncol,pver) ! wg grid slice of upper interface mixing ratio. + +! +! output +! + real(kind_phys), intent(out) :: rprd(ncol,pver) ! rate of production of precip at that layer + real(kind_phys), intent(out) :: du(ncol,pver) ! detrainement rate of updraft + real(kind_phys), intent(out) :: ed(ncol,pver) ! entrainment rate of downdraft + real(kind_phys), intent(out) :: eu(ncol,pver) ! entrainment rate of updraft + real(kind_phys), intent(out) :: hmn(ncol,pver) ! moist stat energy of env + real(kind_phys), intent(out) :: hsat(ncol,pver) ! sat moist stat energy of env + real(kind_phys), intent(out) :: mc(ncol,pver) ! net mass flux + real(kind_phys), intent(out) :: md(ncol,pver) ! downdraft mass flux + real(kind_phys), intent(out) :: mu(ncol,pver) ! updraft mass flux + real(kind_phys), intent(out) :: qd(ncol,pver) ! spec humidity of downdraft + real(kind_phys), intent(out) :: ql(ncol,pver) ! liq water of updraft + real(kind_phys), intent(out) :: qst(ncol,pver) ! saturation mixing ratio of env. + real(kind_phys), intent(out) :: qu(ncol,pver) ! spec hum of updraft + real(kind_phys), intent(out) :: sd(ncol,pver) ! normalized dry stat energy of downdraft + real(kind_phys), intent(out) :: su(ncol,pver) ! normalized dry stat energy of updraft + real(kind_phys), intent(out) :: qcde(ncol,pver) ! cloud water mixing ratio for detrainment (kg/kg) + + real(kind_phys) rd ! gas constant for dry air + real(kind_phys) grav ! gravity + real(kind_phys) cp ! heat capacity of dry air + +! +! Local workspace +! + real(kind_phys) gamma(ncol,pver) + real(kind_phys) dz(ncol,pver) + real(kind_phys) iprm(ncol,pver) + real(kind_phys) hu(ncol,pver) + real(kind_phys) hd(ncol,pver) + real(kind_phys) eps(ncol,pver) + real(kind_phys) f(ncol,pver) + real(kind_phys) k1(ncol,pver) + real(kind_phys) i2(ncol,pver) + real(kind_phys) ihat(ncol,pver) + real(kind_phys) i3(ncol,pver) + real(kind_phys) idag(ncol,pver) + real(kind_phys) i4(ncol,pver) + real(kind_phys) qsthat(ncol,pver) + real(kind_phys) hsthat(ncol,pver) + real(kind_phys) gamhat(ncol,pver) + real(kind_phys) cu(ncol,pver) + real(kind_phys) evp(ncol,pver) + real(kind_phys) cmeg(ncol,pver) + real(kind_phys) qds(ncol,pver) + real(kind_phys) c0mask(ncol) + +!tht For tiedke_lnd + real(kind_phys) tiedke_msk(ncol) + !vars for tht_thermo + real(kind_phys), dimension(ncol,pver) :: mcp,mrd,mrl,tu,td +!-tht + + real(kind_phys) hmin(ncol) + real(kind_phys) expdif(ncol) + real(kind_phys) expnum(ncol) + real(kind_phys) ftemp(ncol) + real(kind_phys) eps0(ncol) + real(kind_phys) rmue(ncol) + real(kind_phys) zuef(ncol) + real(kind_phys) zdef(ncol) + real(kind_phys) epsm(ncol) + real(kind_phys) ratmjb(ncol) + real(kind_phys) est(ncol) + real(kind_phys) totpcp(ncol) + real(kind_phys) totevp(ncol) + real(kind_phys) alfa(ncol) + real(kind_phys) ql1 + real(kind_phys) estu + real(kind_phys) qstu + + real(kind_phys) small + real(kind_phys) mdt + + !real(kind_phys) fice(ncol,pver) ! ice fraction in precip production + real(kind_phys) tug(ncol,pver) + + real(kind_phys) tvuo(ncol,pver) ! updraft virtual T w/o freezing heating + real(kind_phys) tvu(ncol,pver) ! updraft virtual T with freezing heating + real(kind_phys) totfrz(ncol) + real(kind_phys) frz (ncol,pver) ! rate of freezing + integer jto(ncol) ! updraft plume old top + integer tmplel(ncol) + + integer iter, itnum + integer m + + integer khighest + integer klowest + integer kount + integer i,k + + logical doit(ncol) + logical done(ncol) +! +!------------------------------------------------------------------------------ +! + do i = 1,il2g + ftemp(i) = 0._kind_phys + expnum(i) = 0._kind_phys + expdif(i) = 0._kind_phys + c0mask(i) = c0_ocn * (1._kind_phys-landfrac(i)) + c0_lnd * landfrac(i) + if(tht_tweaks) then + tiedke_msk(i)=tiedke_add* (1._kind_phys-landfrac(i)) + tiedke_lnd* landfrac(i) + else + tiedke_msk(i)=tiedke_add + endif + end do +! +!jr Change from msg+1 to 1 to prevent blowup +! + do k = 1,pver + do i = 1,il2g + dz(i,k) = zf(i,k) - zf(i,k+1) + end do + end do + +! +! initialize many output and work variables to zero +! + !pflx(:il2g,1) = 0 + + do k = 1,pver + do i = 1,il2g + k1(i,k) = 0._kind_phys + i2(i,k) = 0._kind_phys + i3(i,k) = 0._kind_phys + i4(i,k) = 0._kind_phys + mu(i,k) = 0._kind_phys + f(i,k) = 0._kind_phys + eps(i,k) = 0._kind_phys + eu(i,k) = 0._kind_phys + du(i,k) = 0._kind_phys + ql(i,k) = 0._kind_phys + cu(i,k) = 0._kind_phys + evp(i,k) = 0._kind_phys + cmeg(i,k) = 0._kind_phys + qds(i,k) = q(i,k) + md(i,k) = 0._kind_phys + ed(i,k) = 0._kind_phys + sd(i,k) = s(i,k) + qd(i,k) = q(i,k) + mc(i,k) = 0._kind_phys + qu(i,k) = q(i,k) + su(i,k) = s(i,k) + call qsat_hPa(t(i,k), p(i,k), est(i), qst(i,k)) + + if ( p(i,k)-est(i) <= 0._kind_phys ) then + qst(i,k) = 1.0_kind_phys + end if +!tht moist thermo + mrd(i,k) = (1._kind_phys+zv*q(i,k))*rd + mcp(i,k) = (1._kind_phys+cpv*q(i,k))*cp + mrl(i,k) = (1._kind_phys-dcol*(t(i,k)-tfreez))*rl + gamma(i,k) = qst(i,k)*(1._kind_phys + qst(i,k)/eps1)*eps1*mrl(i,k)/(mrd(i,k)*t(i,k)**2)*mrl(i,k)/mcp(i,k) + hmn (i,k) = mcp(i,k)*t(i,k) + grav*z(i,k) + mrl(i,k)*q(i,k) + hsat (i,k) = mcp(i,k)*t(i,k) + grav*z(i,k) + mrl(i,k)*qst(i,k) +!-tht + hu(i,k) = hmn(i,k) + hd(i,k) = hmn(i,k) + rprd(i,k) = 0._kind_phys + + !fice(i,k) = 0._kind_phys + tug(i,k) = 0._kind_phys + qcde(i,k) = 0._kind_phys +!+tht moist thermo + if(tht_tweaks) then + tvuo(i,k) = (shat(i,k) - grav/mcp(i,k)*zf(i,k))*(1._kind_phys+(1._kind_phys/eps1-1._kind_phys)*qhat(i,k)) + else + tvuo(i,k) = (shat(i,k) - grav/cp*zf(i,k))*(1._kind_phys + 0.608_kind_phys*qhat(i,k)) + endif +!-tht + tvu(i,k) = tvuo(i,k) + frz(i,k) = 0._kind_phys +!+tht moist thermo + td(i,k) = (hd(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qds(i,k)) & + /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qds(i,k) )) +!-tht + end do + end do +! +!jr Set to zero things which make this routine blow up +! + do k=1,msg + do i=1,il2g + rprd(i,k) = 0._kind_phys + end do + end do +! +! interpolate the layer values of qst, hsat and gamma to +! layer interfaces +! + do k = 1, msg+1 + do i = 1,il2g + hsthat(i,k) = hsat(i,k) + qsthat(i,k) = qst(i,k) + gamhat(i,k) = gamma(i,k) + end do + end do + do i = 1,il2g + totpcp(i) = 0._kind_phys + totevp(i) = 0._kind_phys + end do + do k = msg + 2,pver + do i = 1,il2g + if (abs(qst(i,k-1)-qst(i,k)) > 1.E-6_kind_phys) then + qsthat(i,k) = log(qst(i,k-1)/qst(i,k))*qst(i,k-1)*qst(i,k)/ (qst(i,k-1)-qst(i,k)) + else + qsthat(i,k) = qst(i,k) + end if +!+tht moist thermo + hsthat(i,k) = mcp(i,k)*shat(i,k) +mrl(i,k)*qsthat(i,k) +!-tht + if (abs(gamma(i,k-1)-gamma(i,k)) > 1.E-6_kind_phys) then + gamhat(i,k) = log(gamma(i,k-1)/gamma(i,k))*gamma(i,k-1)*gamma(i,k)/ & + (gamma(i,k-1)-gamma(i,k)) + else + gamhat(i,k) = gamma(i,k) + end if + end do + end do +! +! initialize cloud top to highest plume top. +!jr changed hard-wired 4 to limcnv+1 (not to exceed pver) +! + jt(:) = pver + do i = 1,il2g + jt(i) = max(lel(i),limcnv+1) + jt(i) = min(jt(i),pver) + jd(i) = pver + jlcl(i) = lel(i) + hmin(i) = 1.E6_kind_phys + end do +! +! find the level of minimum hsat, where detrainment starts +! + + do k = msg + 1,pver + do i = 1,il2g + if (hsat(i,k) <= hmin(i) .and. k >= jt(i) .and. k <= jb(i)) then + hmin(i) = hsat(i,k) + j0(i) = k + end if + end do + end do + do i = 1,il2g + j0(i) = min(j0(i),jb(i)-2) + j0(i) = max(j0(i),jt(i)+2) +! +! Fix from Guang Zhang to address out of bounds array reference +! + j0(i) = min(j0(i),pver) + end do +! +! Initialize certain arrays inside cloud +! + do k = msg + 1,pver + do i = 1,il2g + if (k >= jt(i) .and. k <= jb(i)) then +!+tht moist thermo - uniform perturbation either in h or in s + hu(i,k) = hmn(i,mx(i)) + mcp(i,k)*tiedke_msk(i) + su(i,k) = s(i,mx(i)) + tiedke_msk(i)/(1._kind_phys+cpv*qu(i,k)) +!-tht + end if + end do + end do +! +! ********************************************************* +! compute taylor series for approximate eps(z) below +! ********************************************************* +! + do k = pver - 1,msg + 1,-1 + do i = 1,il2g + if (k < jb(i) .and. k >= jt(i)) then + k1(i,k) = k1(i,k+1) + (hmn(i,mx(i))-hmn(i,k))*dz(i,k) + ihat(i,k) = 0.5_kind_phys* (k1(i,k+1)+k1(i,k)) + i2(i,k) = i2(i,k+1) + ihat(i,k)*dz(i,k) + idag(i,k) = 0.5_kind_phys* (i2(i,k+1)+i2(i,k)) + i3(i,k) = i3(i,k+1) + idag(i,k)*dz(i,k) + iprm(i,k) = 0.5_kind_phys* (i3(i,k+1)+i3(i,k)) + i4(i,k) = i4(i,k+1) + iprm(i,k)*dz(i,k) + end if + end do + end do +! +! re-initialize hmin array for ensuing calculation. +! + do i = 1,il2g + hmin(i) = 1.E6_kind_phys + end do + do k = msg + 1,pver + do i = 1,il2g + if (k >= j0(i) .and. k <= jb(i) .and. hmn(i,k) <= hmin(i)) then + hmin(i) = hmn(i,k) + expdif(i) = hmn(i,mx(i)) - hmin(i) + end if + end do + end do +! +! ********************************************************* +! compute approximate eps(z) using above taylor series +! ********************************************************* +! + do k = msg + 2,pver + do i = 1,il2g + expnum(i) = 0._kind_phys + ftemp(i) = 0._kind_phys + if (k < jt(i) .or. k >= jb(i)) then + k1(i,k) = 0._kind_phys + expnum(i) = 0._kind_phys + else + expnum(i) = hmn(i,mx(i)) - (hsat(i,k-1)*(zf(i,k)-z(i,k)) + & + hsat(i,k)* (z(i,k-1)-zf(i,k)))/(z(i,k-1)-z(i,k)) + end if + if ((expdif(i) > 100._kind_phys .and. expnum(i) > 0._kind_phys) .and. & + k1(i,k) > expnum(i)*dz(i,k)) then + ftemp(i) = expnum(i)/k1(i,k) + f(i,k) = ftemp(i) + i2(i,k)/k1(i,k)*ftemp(i)**2 + & + (2._kind_phys*i2(i,k)**2-k1(i,k)*i3(i,k))/k1(i,k)**2* & + ftemp(i)**3 + (-5._kind_phys*k1(i,k)*i2(i,k)*i3(i,k)+ & + 5._kind_phys*i2(i,k)**3+k1(i,k)**2*i4(i,k))/ & + k1(i,k)**3*ftemp(i)**4 + f(i,k) = max(f(i,k),0._kind_phys) + f(i,k) = min(f(i,k),entrmn) !tht: maximum entr. rate (lambda_0 in paper) + end if + end do + end do + do i = 1,il2g + if (j0(i) < jb(i)) then + if (f(i,j0(i)) < 1.E-6_kind_phys .and. f(i,j0(i)+1) > f(i,j0(i))) j0(i) = j0(i) + 1 + end if + end do + do k = msg + 2,pver + do i = 1,il2g + if (k >= jt(i) .and. k <= j0(i)) then + f(i,k) = max(f(i,k),f(i,k-1)) + end if + end do + end do + do i = 1,il2g + eps0(i) = f(i,j0(i)) + eps(i,jb(i)) = eps0(i) + end do +! +! This is set to match the Rasch and Kristjansson paper +! + do k = pver,msg + 1,-1 + do i = 1,il2g + if (k >= j0(i) .and. k <= jb(i)) then + eps(i,k) = f(i,j0(i)) + end if + end do + end do + do k = pver,msg + 1,-1 + do i = 1,il2g + if (k < j0(i) .and. k >= jt(i)) eps(i,k) = f(i,k) + end do + end do + + itnum = 1 + do iter=1, itnum + +! +! specify the updraft mass flux mu, entrainment eu, detrainment du +! and moist static energy hu. +! here and below mu, eu,du, md and ed are all normalized by mb +! + do i = 1,il2g + if (eps0(i) > 0._kind_phys) then + mu(i,jb(i)) = 1._kind_phys + eu(i,jb(i)) = mu(i,jb(i))/dz(i,jb(i)) + end if + tmplel(i) = jt(i) + end do + do k = pver,msg + 1,-1 + do i = 1,il2g + if (eps0(i) > 0._kind_phys .and. (k >= tmplel(i) .and. k < jb(i))) then + zuef(i) = zf(i,k) - zf(i,jb(i)) + rmue(i) = (1._kind_phys/eps0(i))* (exp(eps(i,k+1)*zuef(i))-1._kind_phys)/zuef(i) + mu(i,k) = (1._kind_phys/eps0(i))* (exp(eps(i,k )*zuef(i))-1._kind_phys)/zuef(i) + eu(i,k) = (rmue(i)-mu(i,k+1))/dz(i,k) + du(i,k) = (rmue(i)-mu(i,k))/dz(i,k) + end if + end do + end do + + khighest = pverp + klowest = 1 + do i=1,il2g + khighest = min(khighest,lel(i)) + klowest = max(klowest,jb(i)) + end do + do k = klowest-1,khighest,-1 + do i = 1,il2g + if (k <= jb(i)-1 .and. k >= lel(i) .and. eps0(i) > 0._kind_phys) then + if (mu(i,k) < 0.02_kind_phys) then + hu(i,k) = hmn(i,k) + mu(i,k) = 0._kind_phys + eu(i,k) = 0._kind_phys + du(i,k) = mu(i,k+1)/dz(i,k) + else + hu(i,k) = mu(i,k+1)/mu(i,k)*hu(i,k+1) + & + dz(i,k)/mu(i,k)* (eu(i,k)*hmn(i,k)- du(i,k)*hsat(i,k)) + end if + end if + end do + end do +! +! reset cloud top index beginning from two layers above the +! cloud base (i.e. if cloud is only one layer thick, top is not reset +! + do i=1,il2g + doit(i) = .true. + totfrz(i)= 0._kind_phys + do k = pver,msg + 1,-1 + totfrz(i)= totfrz(i)+ frz(i,k)*dz(i,k) + end do + end do + do k=klowest-2,khighest-1,-1 + do i=1,il2g + if (doit(i) .and. k <= jb(i)-2 .and. k >= lel(i)-1) then + if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & + .and. mu(i,k) >= 0.02_kind_phys) then + if (hu(i,k)-hsthat(i,k) < -2000._kind_phys) then + jt(i) = k + 1 + doit(i) = .false. + else + jt(i) = k + doit(i) = .false. + end if + else if ( (hu(i,k) > hu(i,jb(i)) .and. totfrz(i)<=0._kind_phys) .or. mu(i,k) < 0.02_kind_phys) then + jt(i) = k + 1 + doit(i) = .false. + end if + end if + end do + end do + + if (iter == 1) jto(:) = jt(:) + + do k = pver,msg + 1,-1 + do i = 1,il2g + if (k >= lel(i) .and. k <= jt(i) .and. eps0(i) > 0._kind_phys) then + mu(i,k) = 0._kind_phys + eu(i,k) = 0._kind_phys + du(i,k) = 0._kind_phys + hu(i,k) = hmn(i,k) + end if + if (k == jt(i) .and. eps0(i) > 0._kind_phys) then + du(i,k) = mu(i,k+1)/dz(i,k) + eu(i,k) = 0._kind_phys + mu(i,k) = 0._kind_phys + end if + end do + end do + +!+tht initialise tu (moist thermo) + do k = pver,msg + 2,-1 + do i = 1,il2g + tu(i,k) = (hu(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qu(i,k)) & + /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qu(i,k) )) + end do + end do +!-tht + do i = 1,il2g + done(i) = .false. + end do + kount = 0 + do k = pver,msg + 2,-1 + do i = 1,il2g + if (k == jb(i) .and. eps0(i) > 0._kind_phys) then + qu(i,k) = q(i,mx(i)) +!+tht moist thermo + tu(i,k) = (hu(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qu(i,k)) & + /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qu(i,k) )) + su(i,k) = (hu(i,k)-(1._kind_phys-dcol*(tu(i,k)-tfreez))*rl*qu(i,k)) & + /((1._kind_phys+cpv*qu(i,k))*cp) +!-tht + end if + if (( .not. done(i) .and. k > jt(i) .and. k < jb(i)) .and. eps0(i) > 0._kind_phys) then + su(i,k) = mu(i,k+1)/mu(i,k)*su(i,k+1) + & + dz(i,k)/mu(i,k)* (eu(i,k)-du(i,k))*s(i,k) + qu(i,k) = mu(i,k+1)/mu(i,k)*qu(i,k+1) + dz(i,k)/mu(i,k)* (eu(i,k)*q(i,k)- & + du(i,k)*qst(i,k)) +!+tht moist thermo + tu(i,k) = su(i,k) - grav/((1._kind_phys+cpv*qu(i,k))*cp)*zf(i,k) + call qsat_hPa(tu(i,k), (p(i,k)+p(i,k-1))/2._kind_phys, estu, qstu) +!-tht + if (qu(i,k) >= qstu) then + jlcl(i) = k + kount = kount + 1 + done(i) = .true. + end if + end if + end do + if (kount >= il2g) goto 690 + end do +690 continue + do k = msg + 2,pver + do i = 1,il2g + if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._kind_phys) then +!+tht moist thermo + qu(i,k) = qsthat(i,k) + gamhat(i,k)*(hu(i,k)-hsthat(i,k))/ & + ((1._kind_phys-dcol*(tu(i,k)-tfreez))*rl* (1._kind_phys+gamhat(i,k))) + su(i,k) = shat(i,k) + (hu(i,k)-hsthat(i,k))/((1._kind_phys+cpv*qu(i,k))*cp* (1._kind_phys+gamhat(i,k))) + tu(i,k) = su(i,k) - grav/((1._kind_phys+cpv*qu(i,k))*cp)*zf(i,k) +!-tht + end if + end do + end do + +! compute condensation in updraft + tmplel(:il2g) = jb(:il2g) + + do k = pver,msg + 2,-1 + do i = 1,il2g + if (k >= jt(i) .and. k < tmplel(i) .and. eps0(i) > 0._kind_phys) then +!+tht moist thermo + cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ & + dz(i,k)- (eu(i,k)-du(i,k))*s(i,k))/(rl/cp) & + *((1._kind_phys+cpv*qu(i,k))/(1._kind_phys-dcol*(tu(i,k)-tfreez))) +!-tht + if (k == jt(i)) cu(i,k) = 0._kind_phys + cu(i,k) = max(0._kind_phys,cu(i,k)) + end if + end do + end do + + +! compute condensed liquid, rain production rate +! accumulate total precipitation (condensation - detrainment of liquid) +! Note ql1 = ql(k) + rprd(k)*dz(k)/mu(k) +! The differencing is somewhat strange (e.g. du(i,k)*ql(i,k+1)) but is +! consistently applied. +! mu, ql are interface quantities +! cu, du, eu, rprd are midpoint quantites + + do k = pver,msg + 2,-1 + do i = 1,il2g + rprd(i,k) = 0._kind_phys + if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._kind_phys .and. mu(i,k) >= 0.0_kind_phys) then + if (mu(i,k) > 0._kind_phys) then + ql1 = 1._kind_phys/mu(i,k)* (mu(i,k+1)*ql(i,k+1)- & + dz(i,k)*du(i,k)*ql(i,k+1)+dz(i,k)*cu(i,k)) + ql(i,k) = ql1/ (1._kind_phys+dz(i,k)*c0mask(i)) + else + ql(i,k) = 0._kind_phys + end if + totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*ql(i,k+1)) + rprd(i,k) = c0mask(i)*mu(i,k)*ql(i,k) + qcde(i,k) = ql(i,k) + end if + end do + end do +! + end do !iter +! +! specify downdraft properties (no downdrafts if jd.ge.jb). +! scale down downward mass flux profile so that net flux +! (up-down) at cloud base in not negative. +! + do i = 1,il2g +! +! in normal downdraft strength run alfa=0.2. In test4 alfa=0.1 +! + alfa(i) = alfadet !tht: detrainment proportionality factor (alpha in paper) + jt(i) = min(jt(i),jb(i)-1) + jd(i) = max(j0(i),jt(i)+1) + jd(i) = min(jd(i),jb(i)) + hd(i,jd(i)) = hmn(i,jd(i)-1) + if (jd(i) < jb(i) .and. eps0(i) > 0._kind_phys) then + epsm(i) = eps0(i) + md(i,jd(i)) = -alfa(i)*epsm(i)/eps0(i) + end if + end do + do k = msg + 1,pver + do i = 1,il2g + if ((k > jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._kind_phys) then + zdef(i) = zf(i,jd(i)) - zf(i,k) +!tht: why the factor 2 here? + md(i,k) = -alfa(i)/ (2._kind_phys*eps0(i))*(exp(2._kind_phys*epsm(i)*zdef(i))-1._kind_phys)/zdef(i) + end if + end do + end do + + do k = msg + 1,pver + do i = 1,il2g + if ((k >= jt(i) .and. k <= jb(i)) .and. eps0(i) > 0._kind_phys .and. jd(i) < jb(i)) then + ratmjb(i) = min(abs(mu(i,jb(i))/md(i,jb(i))),1._kind_phys) + md(i,k) = md(i,k)*ratmjb(i) + end if + end do + end do + + small = 1.e-20_kind_phys + do k = msg + 1,pver + do i = 1,il2g + if ((k >= jt(i) .and. k <= pver) .and. eps0(i) > 0._kind_phys) then + ed(i,k-1) = (md(i,k-1)-md(i,k))/dz(i,k-1) + mdt = min(md(i,k),-small) + hd(i,k) = (md(i,k-1)*hd(i,k-1) - dz(i,k-1)*ed(i,k-1)*hmn(i,k-1))/mdt + end if + end do + end do +! +! calculate updraft and downdraft properties. +! + do k = msg + 2,pver + do i = 1,il2g + if ((k >= jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._kind_phys .and. jd(i) < jb(i)) then + qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & + (rl*(1._kind_phys + gamhat(i,k))) +!+tht moist thermo + td(i,k) = (hd(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qds(i,k)) & + /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qds(i,k) )) + qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & + ((1._kind_phys-dcol*(td(i,k)-tfreez))*rl*(1._kind_phys + gamhat(i,k))) +!-tht + end if + end do + end do + + do i = 1,il2g + qd(i,jd(i)) = qds(i,jd(i)) +!+tht moist thermo + k=jd(i) + sd(i,k) = (hd(i,k) - (1._kind_phys-dcol*(td(i,k)-tfreez))*rl*qd(i,k))/((1._kind_phys+cpv*qd(i,k))*cp) + td(i,k) = sd(i,k) - grav/((1._kind_phys+cpv*qd(i,k))*cp)*zf(i,k) +!-tht + end do +! + do k = msg + 2,pver + do i = 1,il2g + if (k >= jd(i) .and. k < jb(i) .and. eps0(i) > 0._kind_phys) then + qd(i,k+1) = qds(i,k+1) + evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k)-md(i,k+1)*qd(i,k+1))/dz(i,k) + evp(i,k) = max(evp(i,k),0._kind_phys) + mdt = min(md(i,k+1),-small) +!+tht moist thermo + sd(i,k+1) = (((1._kind_phys-dcol*(td(i,k)-tfreez))*rl/((1._kind_phys+cpv*qd(i,k))*cp)*evp(i,k) & + -ed(i,k)*s(i,k))*dz(i,k) + md(i,k)*sd(i,k))/mdt +!-tht + totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) + end if + end do + end do + do i = 1,il2g + totevp(i) = totevp(i) + md(i,jd(i))*qd(i,jd(i)) - md(i,jb(i))*qd(i,jb(i)) + end do +!!$ if (.true.) then + if (.false.) then + do i = 1,il2g + k = jb(i) + if (eps0(i) > 0._kind_phys) then + evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k))/dz(i,k) + evp(i,k) = max(evp(i,k),0._kind_phys) + totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) + end if + end do + endif + + do i = 1,il2g + totpcp(i) = max(totpcp(i),0._kind_phys) + totevp(i) = max(totevp(i),0._kind_phys) + end do +! + do k = msg + 2,pver + do i = 1,il2g + if (totevp(i) > 0._kind_phys .and. totpcp(i) > 0._kind_phys) then + md(i,k) = md (i,k)*min(1._kind_phys, totpcp(i)/(totevp(i)+totpcp(i))) + ed(i,k) = ed (i,k)*min(1._kind_phys, totpcp(i)/(totevp(i)+totpcp(i))) + evp(i,k) = evp(i,k)*min(1._kind_phys, totpcp(i)/(totevp(i)+totpcp(i))) + else + md(i,k) = 0._kind_phys + ed(i,k) = 0._kind_phys + evp(i,k) = 0._kind_phys + end if +! cmeg is the cloud water condensed - rain water evaporated +! rprd is the cloud water converted to rain - (rain evaporated) + cmeg(i,k) = cu(i,k) - evp(i,k) + rprd(i,k) = rprd(i,k)-evp(i,k) + end do + end do + +! + do k = msg + 1,pver + do i = 1,il2g + mc(i,k) = mu(i,k) + md(i,k) + end do + end do +! + return +end subroutine cldprp + +subroutine closure(ncol ,pver, & + q ,t ,p ,z ,s , & + tp ,qs ,qu ,su ,mc , & + du ,mu ,md ,qd ,sd , & + qhat ,shat ,dp ,qstp ,zf , & + ql ,dsubcld ,mb ,cape ,tl , & + lcl ,lel ,jt ,mx ,il1g , & + il2g ,rd ,grav ,cp ,rl , & + msg ,capelmt ) +! +!-----------------------------Arguments--------------------------------- +! + integer, intent(in) :: ncol + integer, intent(in) :: pver + + real(kind_phys), intent(inout) :: q(ncol,pver) ! spec humidity + real(kind_phys), intent(inout) :: t(ncol,pver) ! temperature + real(kind_phys), intent(inout) :: p(ncol,pver) ! pressure (mb) + real(kind_phys), intent(inout) :: mb(ncol) ! cloud base mass flux + real(kind_phys), intent(in) :: z(ncol,pver) ! height (m) + real(kind_phys), intent(in) :: s(ncol,pver) ! normalized dry static energy + real(kind_phys), intent(in) :: tp(ncol,pver) ! parcel temp + real(kind_phys), intent(in) :: qs(ncol,pver) ! sat spec humidity + real(kind_phys), intent(in) :: qu(ncol,pver) ! updraft spec. humidity + real(kind_phys), intent(in) :: su(ncol,pver) ! normalized dry stat energy of updraft + real(kind_phys), intent(in) :: mc(ncol,pver) ! net convective mass flux + real(kind_phys), intent(in) :: du(ncol,pver) ! detrainment from updraft + real(kind_phys), intent(in) :: mu(ncol,pver) ! mass flux of updraft + real(kind_phys), intent(in) :: md(ncol,pver) ! mass flux of downdraft + real(kind_phys), intent(in) :: qd(ncol,pver) ! spec. humidity of downdraft + real(kind_phys), intent(in) :: sd(ncol,pver) ! dry static energy of downdraft + real(kind_phys), intent(in) :: qhat(ncol,pver) ! environment spec humidity at interfaces + real(kind_phys), intent(in) :: shat(ncol,pver) ! env. normalized dry static energy at intrfcs + real(kind_phys), intent(in) :: dp(ncol,pver) ! pressure thickness of layers + real(kind_phys), intent(in) :: qstp(ncol,pver) ! spec humidity of parcel + real(kind_phys), intent(in) :: zf(ncol,pver+1) ! height of interface levels + real(kind_phys), intent(in) :: ql(ncol,pver) ! liquid water mixing ratio + + real(kind_phys), intent(in) :: cape(ncol) ! available pot. energy of column + real(kind_phys), intent(in) :: tl(ncol) + real(kind_phys), intent(in) :: dsubcld(ncol) ! thickness of subcloud layer + + integer, intent(in) :: lcl(ncol) ! index of lcl + integer, intent(in) :: lel(ncol) ! index of launch leve + integer, intent(in) :: jt(ncol) ! top of updraft + integer, intent(in) :: mx(ncol) ! base of updraft +! +!--------------------------Local variables------------------------------ +! + real(kind_phys) dtpdt(ncol,pver) + real(kind_phys) dqsdtp(ncol,pver) + real(kind_phys) dtmdt(ncol,pver) + real(kind_phys) dqmdt(ncol,pver) + real(kind_phys) dboydt(ncol,pver) + real(kind_phys) thetavp(ncol,pver) + real(kind_phys) thetavm(ncol,pver) + + real(kind_phys) dtbdt(ncol),dqbdt(ncol),dtldt(ncol) + real(kind_phys) beta + real(kind_phys) capelmt + real(kind_phys) cp + real(kind_phys) dadt(ncol) + real(kind_phys) debdt + real(kind_phys) dltaa + real(kind_phys) eb + real(kind_phys) grav + + integer i + integer il1g + integer il2g + integer k, kmin, kmax + integer msg + + real(kind_phys) rd + real(kind_phys) rl + !real(kind_phys) rltp !tht + +! change of subcloud layer properties due to convection is +! related to cumulus updrafts and downdrafts. +! mc(z)=f(z)*mb, mub=betau*mb, mdb=betad*mb are used +! to define betau, betad and f(z). +! note that this implies all time derivatives are in effect +! time derivatives per unit cloud-base mass flux, i.e. they +! have units of 1/mb instead of 1/sec. +! + do i = il1g,il2g + mb(i) = 0._kind_phys + eb = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i))) + dtbdt(i) = (1._kind_phys/dsubcld(i))* (mu(i,mx(i))*(shat(i,mx(i))-su(i,mx(i)))+ & + md(i,mx(i))* (shat(i,mx(i))-sd(i,mx(i)))) + dqbdt(i) = (1._kind_phys/dsubcld(i))* (mu(i,mx(i))*(qhat(i,mx(i))-qu(i,mx(i)))+ & + md(i,mx(i))* (qhat(i,mx(i))-qd(i,mx(i)))) + debdt = eps1*p(i,mx(i))/ (eps1+q(i,mx(i)))**2*dqbdt(i) + dtldt(i) = -2840._kind_phys* (3.5_kind_phys/t(i,mx(i))*dtbdt(i)-debdt/eb)/ & + (3.5_kind_phys*log(t(i,mx(i)))-log(eb)-4.805_kind_phys)**2 + end do +! +! dtmdt and dqmdt are cumulus heating and drying. +! + do k = msg + 1,pver + do i = il1g,il2g + dtmdt(i,k) = 0._kind_phys + dqmdt(i,k) = 0._kind_phys + end do + end do +! + do k = msg + 1,pver - 1 + do i = il1g,il2g + if (k == jt(i)) then + dtmdt(i,k) = (1._kind_phys/dp(i,k))*(mu(i,k+1)* (su(i,k+1)-shat(i,k+1)- & + rl/cp*ql(i,k+1))+md(i,k+1)* (sd(i,k+1)-shat(i,k+1))) + dqmdt(i,k) = (1._kind_phys/dp(i,k))*(mu(i,k+1)* (qu(i,k+1)- & + qhat(i,k+1)+ql(i,k+1))+md(i,k+1)*(qd(i,k+1)-qhat(i,k+1))) + end if + end do + end do +! + beta = 0._kind_phys + do k = msg + 1,pver - 1 + do i = il1g,il2g + if (k > jt(i) .and. k < mx(i)) then + dtmdt(i,k) = (mc(i,k)* (shat(i,k)-s(i,k))+mc(i,k+1)* (s(i,k)-shat(i,k+1)))/ & + dp(i,k) - rl/cp*du(i,k)*(beta*ql(i,k)+ (1-beta)*ql(i,k+1)) + + dqmdt(i,k) = (mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)+cp/rl* (su(i,k+1)-s(i,k)))- & + mu(i,k)* (qu(i,k)-qhat(i,k)+cp/rl*(su(i,k)-s(i,k)))+md(i,k+1)* & + (qd(i,k+1)-qhat(i,k+1)+cp/rl*(sd(i,k+1)-s(i,k)))-md(i,k)* & + (qd(i,k)-qhat(i,k)+cp/rl*(sd(i,k)-s(i,k))))/dp(i,k) + & + du(i,k)* (beta*ql(i,k)+(1-beta)*ql(i,k+1)) + end if + end do + end do +! + do k = msg + 1,pver + do i = il1g,il2g + if (k >= lel(i) .and. k <= lcl(i)) then + thetavp(i,k) = tp(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+1.608_kind_phys*qstp(i,k)-q(i,mx(i))) + thetavm(i,k) = t(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+0.608_kind_phys*q(i,k)) + dqsdtp(i,k) = qstp(i,k)* (1._kind_phys+qstp(i,k)/eps1)*eps1*rl/(rd*tp(i,k)**2) +! +! dtpdt is the parcel temperature change due to change of +! subcloud layer properties during convection. +! + dtpdt(i,k) = tp(i,k)/ (1._kind_phys+rl/cp* (dqsdtp(i,k)-qstp(i,k)/tp(i,k)))* & + (dtbdt(i)/t(i,mx(i))+rl/cp* (dqbdt(i)/tl(i)-q(i,mx(i))/ & + tl(i)**2*dtldt(i))) +! +! dboydt is the integrand of cape change. +! + dboydt(i,k) = ((dtpdt(i,k)/tp(i,k)+1._kind_phys/(1._kind_phys+1.608_kind_phys*qstp(i,k)-q(i,mx(i)))* & + (1.608_kind_phys * dqsdtp(i,k) * dtpdt(i,k) -dqbdt(i))) - (dtmdt(i,k)/t(i,k)+0.608_kind_phys/ & + (1._kind_phys+0.608_kind_phys*q(i,k))*dqmdt(i,k)))*grav*thetavp(i,k)/thetavm(i,k) + end if + end do + end do +! + do k = msg + 1,pver + do i = il1g,il2g + if (k > lcl(i) .and. k < mx(i)) then + thetavp(i,k) = tp(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+0.608_kind_phys*q(i,mx(i))) + thetavm(i,k) = t(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+0.608_kind_phys*q(i,k)) +! +! dboydt is the integrand of cape change. +! + dboydt(i,k) = (dtbdt(i)/t(i,mx(i))+0.608_kind_phys/ (1._kind_phys+0.608_kind_phys*q(i,mx(i)))*dqbdt(i)- & + dtmdt(i,k)/t(i,k)-0.608_kind_phys/ (1._kind_phys+0.608_kind_phys*q(i,k))*dqmdt(i,k))* & + grav*thetavp(i,k)/thetavm(i,k) + end if + end do + end do + +! +! buoyant energy change is set to 2/3*excess cape per 3 hours +! + dadt(il1g:il2g) = 0._kind_phys + kmin = minval(lel(il1g:il2g)) + kmax = maxval(mx(il1g:il2g)) - 1 + do k = kmin, kmax + do i = il1g,il2g + if ( k >= lel(i) .and. k <= mx(i) - 1) then + dadt(i) = dadt(i) + dboydt(i,k)* (zf(i,k)-zf(i,k+1)) + endif + end do + end do + do i = il1g,il2g + dltaa = -1._kind_phys* (cape(i)-capelmt) + if (dadt(i) /= 0._kind_phys) mb(i) = max(dltaa/tau/dadt(i),0._kind_phys) + end do +! + return +end subroutine closure + +subroutine q1q2_pjr(ncol ,pver ,latice ,& + dqdt ,dsdt ,q ,qs ,qu , & + su ,du ,qhat ,shat ,dp , & + mu ,md ,sd ,qd ,ql , & + dsubcld ,jt ,mx ,il1g ,il2g , & + cp ,rl ,msg , & + dl ,evp ,cu) + + implicit none + +!----------------------------------------------------------------------- +! Purpose: +! compute temperature and moisture changes due to convection. +!----------------------------------------------------------------------- + + + real(kind_phys), intent(in) :: cp + + integer, intent(in) :: ncol + integer, intent(in) :: pver + real(kind_phys), intent(in) :: latice + integer, intent(in) :: il1g + integer, intent(in) :: il2g + integer, intent(in) :: msg + + real(kind_phys), intent(in) :: q(ncol,pver) + real(kind_phys), intent(in) :: qs(ncol,pver) + real(kind_phys), intent(in) :: qu(ncol,pver) + real(kind_phys), intent(in) :: su(ncol,pver) + real(kind_phys), intent(in) :: du(ncol,pver) + real(kind_phys), intent(in) :: qhat(ncol,pver) + real(kind_phys), intent(in) :: shat(ncol,pver) + real(kind_phys), intent(in) :: dp(ncol,pver) + real(kind_phys), intent(in) :: mu(ncol,pver) + real(kind_phys), intent(in) :: md(ncol,pver) + real(kind_phys), intent(in) :: sd(ncol,pver) + real(kind_phys), intent(in) :: qd(ncol,pver) + real(kind_phys), intent(in) :: ql(ncol,pver) + real(kind_phys), intent(in) :: evp(ncol,pver) + real(kind_phys), intent(in) :: cu(ncol,pver) + real(kind_phys), intent(in) :: dsubcld(ncol) + + real(kind_phys),intent(out) :: dqdt(ncol,pver),dsdt(ncol,pver) + real(kind_phys),intent(out) :: dl(ncol,pver) + + integer kbm + integer ktm + integer jt(ncol) + integer mx(ncol) +! +! work fields: +! + integer i + integer k + + real(kind_phys) emc + real(kind_phys) rl +!------------------------------------------------------------------- + do k = msg + 1,pver + do i = il1g,il2g + dsdt(i,k) = 0._kind_phys + dqdt(i,k) = 0._kind_phys + dl(i,k) = 0._kind_phys + end do + end do + +! +! find the highest level top and bottom levels of convection +! + ktm = pver + kbm = pver + do i = il1g, il2g + ktm = min(ktm,jt(i)) + kbm = min(kbm,mx(i)) + end do + + do k = ktm,pver-1 + do i = il1g,il2g + emc = -cu (i,k) & ! condensation in updraft + +evp(i,k) ! evaporating rain in downdraft + + dsdt(i,k) = -rl/cp*emc & + + (+mu(i,k+1)* (su(i,k+1)-shat(i,k+1)) & + -mu(i,k)* (su(i,k)-shat(i,k)) & + +md(i,k+1)* (sd(i,k+1)-shat(i,k+1)) & + -md(i,k)* (sd(i,k)-shat(i,k)) & + )/dp(i,k) + + dqdt(i,k) = emc + & + (+mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)) & + -mu(i,k)* (qu(i,k)-qhat(i,k)) & + +md(i,k+1)* (qd(i,k+1)-qhat(i,k+1)) & + -md(i,k)* (qd(i,k)-qhat(i,k)) & + )/dp(i,k) + + dl(i,k) = du(i,k)*ql(i,k+1) + + end do + end do + +! + do k = kbm,pver + do i = il1g,il2g + if (k == mx(i)) then + dsdt(i,k) = (1._kind_phys/dsubcld(i))* & + (-mu(i,k)* (su(i,k)-shat(i,k)) & + -md(i,k)* (sd(i,k)-shat(i,k)) & + ) + dqdt(i,k) = (1._kind_phys/dsubcld(i))* & + (-mu(i,k)*(qu(i,k)-qhat(i,k)) & + -md(i,k)*(qd(i,k)-qhat(i,k)) & + ) + else if (k > mx(i)) then + dsdt(i,k) = dsdt(i,k-1) + dqdt(i,k) = dqdt(i,k-1) + end if + end do + end do +! + return +end subroutine q1q2_pjr + + +! Wrapper for qsat_water that does translation between Pa and hPa +! qsat_water uses Pa internally, so get it right, need to pass in Pa. +! Afterward, set es back to hPa. +subroutine qsat_hPa(t, p, es, qm) + use wv_saturation, only: qsat_water + + ! Inputs + real(kind_phys), intent(in) :: t ! Temperature (K) + real(kind_phys), intent(in) :: p ! Pressure (hPa) + ! Outputs + real(kind_phys), intent(out) :: es ! Saturation vapor pressure (hPa) + real(kind_phys), intent(out) :: qm ! Saturation mass mixing ratio + ! (vapor mass over dry mass, kg/kg) + + call qsat_water(t, p*100._kind_phys, es, qm) + + es = es*0.01_kind_phys + +end subroutine qsat_hPa + +end module zm_convr From b37fff02807a30da67db4834c54cbe24c4abedda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=98yvind=20Seland?= Date: Sun, 15 Jun 2025 10:01:58 +0200 Subject: [PATCH 02/78] Bug correction for enthalpy update --- .../camnor_phys/physics/check_energy.F90 | 93 ++++++++----------- 1 file changed, 38 insertions(+), 55 deletions(-) diff --git a/src/physics/camnor_phys/physics/check_energy.F90 b/src/physics/camnor_phys/physics/check_energy.F90 index 427452e6b1..12e0ac3c99 100644 --- a/src/physics/camnor_phys/physics/check_energy.F90 +++ b/src/physics/camnor_phys/physics/check_energy.F90 @@ -18,8 +18,6 @@ module check_energy ! Modifications: ! 03.03.29 Boville Add global energy check and fixer. ! -! 25.06.14 Added formulation of enthalpy adjustment created by Peter Lauritzen (NCAR) and Thomas Toniazzo (Bjerknes Centre / NORCE) -! !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 @@ -979,6 +977,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, real(r8), parameter :: eps=1.E-10_r8 logical, parameter :: debug=.true. + logical, parameter :: use_nonlinear_evap_fraction=.false. integer :: i, k real(r8):: tot, wgt_bc, wgt_ac @@ -1011,21 +1010,25 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, if (minval(cam_in%ts(:ncol)).gt.0._r8) then hevap_atm(:ncol) = cam_in%cflx (:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm !tht: add non-linear terms? using evap_ocn, sst - nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) - where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large - hevap_atm(:ncol)= hevap_atm(:ncol) & - + cpwv & - *(1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & - *(cam_in%cflx(:ncol,1)-cam_in%evap_ocn(:ncol)) & - *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) - tevp (:ncol)= cam_in%ts(:ncol) & - + (1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & - *(1._r8-cam_in%evap_ocn(:ncol)/cam_in%cflx(:ncol,1))& - *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) - elsewhere - tevp (:ncol)= cam_in%ts(:ncol) - endwhere - !tht: for ocean-only mat.enthalpy flux (passed to ocean) + if (use_nonlinear_evap_fraction) then + nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) + where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large + hevap_atm(:ncol)= hevap_atm(:ncol) & + + cpwv & + *(1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & + *(cam_in%cflx(:ncol,1)-cam_in%evap_ocn(:ncol)) & + *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) + tevp (:ncol)= cam_in%ts(:ncol) & + + (1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & + *(1._r8-cam_in%evap_ocn(:ncol)/cam_in%cflx(:ncol,1))& + *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) + elsewhere + tevp (:ncol)= cam_in%ts(:ncol) + endwhere + else + tevp (:ncol)= cam_in%ts(:ncol) + endif + !tht: for ocean-only mat.enthalpy flux (passed to ocean) hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) else ! not great but better than zeros hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm @@ -1034,6 +1037,24 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, endif call pbuf_set_field(pbuf, enthalpy_evop_idx, hevap_ocn) + if (use_nonlinear_evap_fraction) then + if(maxval(tevp(:ncol)).gt.350._r8 .or. minval(tevp(:ncol)).lt.150._r8)then + i=maxloc(tevp(:ncol),1) + k=minloc(tevp(:ncol),1) + print*,'Bad Tevap' + print*,'min ts=',minval(cam_in%ts(:ncol)),maxval(cam_in%ts(:ncol)) + print*,'state%t',minval(state%t(:ncol,pver)),maxval(state%t(:ncol,pver)) + print*,'tevp =',tevp(k),tevp(i) + print*,'ts =',cam_in%ts (k),cam_in%ts (i) + print*,'sst =',cam_in%sst(k),cam_in%sst(i) + print*,'cflx =',cam_in%cflx(k,1),cam_in%cflx(i,1) + print*,'evop =',cam_in%evap_ocn(k),cam_in%evap_ocn(i) + print*,'corr =',(1._r8-nocnfrc(k))/nocnfrc(k) *(1._r8-cam_in%evap_ocn(k)/cam_in%cflx(k,1)) *(cam_in%ts(k)-cam_in%sst(k)) & + ,(1._r8-nocnfrc(i))/nocnfrc(i) *(1._r8-cam_in%evap_ocn(i)/cam_in%cflx(i,1)) *(cam_in%ts(i)-cam_in%sst(i)) + call endrun('stopping in enthalpy_adjustment') + endif + endif + !------------------------------------------------------------------ ! compute precipitation fluxes and set associated physics buffers !------------------------------------------------------------------ @@ -1128,31 +1149,8 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, , pdel_rf=pdel_rf ) call outfld('IETEND_DME', dsema , pcols, lchnk) - call outfld('EFLX' , enthalpy_flux_atm , pcols, lchnk) - !call outfld('EFLX_out' , eflx_out , pcols, lchnk) ! test - call outfld('MFLX' , water_flux_bc+water_flux_ac , pcols, lchnk) - !call outfld('MFLX_out' ,-mflx_out , pcols, lchnk) ! test - - !! check energy must be called with "physics" temps to compensate for internal rescaling - !! call unnecessary, only for testing. te_cur is updated below. - !do k = 1, pver - ! do i = 1, ncol - ! scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) - ! state%T (i,k) = state%temp_ini(i,k)+(state%T(i,k)- state%temp_ini(i,k))/scale_cpdry_cpdycore(i,k) - ! tend%dtdt(i,k) = tend%dtdt(i,k)/scale_cpdry_cpdycore(i,k) - ! end do - !end do - !call check_energy_cam_chng(state, tend, "enthalpy_ac+bc_tend", nstep, ztodt, zero, zero, zero, dsema) - !! ...aand scale temperature back - !do k = 1, pver - ! do i = 1, ncol - ! scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) - ! state%T (i,k) = state%temp_ini(i,k)+scale_cpdry_cpdycore(i,k)*(state%T(i,k)- state%temp_ini(i,k)) - ! tend%dtdt(i,k) = scale_cpdry_cpdycore(i,k)*tend%dtdt(i,k) - ! end do - !end do ! compute and store new column-integrated enthalpy and associated tendency call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & @@ -1162,14 +1160,8 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, te = te(:ncol), se=se(:ncol), po=po(:ncol), ke=ke(:ncol)) ! Save final energy for use with global fixer in next timestep -- note sign conventions, and coupling-dependent options state%te_cur(:ncol,dyn_te_idx) = te(:ncol) & ! *subtract* from this the h flux (sign: into atm) that is *not* passed to surface components - !- 0._r8 ! A. pass hmat to all (test atm conservation via TFIX) - !-ztodt*(enthalpy_flux_atm(:ncol)-enthalpy_flux_ocn(:ncol)) ! B. pass hmat to ocean only, fix the rest in atmo -ztodt*(enthalpy_flux_atm(:ncol)-enthalpy_flux_ocn(:ncol)-cam_in%hrof(:ncol)) ! also remove enthalpy of run-off (if added to BLOM) - !-ztodt* enthalpy_flux_atm(:ncol) ! C. don't use hmat, fix everything in atmo - !tend%te_tnd(:ncol)=tend%te_tnd(:ncol) + enthalpy_flux_atm(:ncol) ! A. - !tend%te_tnd(:ncol)=tend%te_tnd(:ncol) + enthalpy_flux_ocn(:ncol) ! B. tend%te_tnd(:ncol)=tend%te_tnd(:ncol) +(enthalpy_flux_ocn(:ncol)+cam_in%hrof(:ncol)) ! B. with run-off - !tend%te_tnd(:ncol)=tend%te_tnd(:ncol) + 0._r0 ! C. if (thermo_budget_history) then call tot_energy_phys(state, 'phAM') @@ -1181,15 +1173,6 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, dEdt_efix(:ncol) = (state%te_cur(:ncol,dyn_te_idx)-te (:ncol))/ztodt call outfld("dEdt_efix_physics" , dEdt_efix , pcols ,lchnk ) - ! xxx diagnostics - ! compute latent heat fluxes - !tht: correct for reference T of latent heats! (ice reference state here) - !variable_latent_heat_surface_cpice_term(:ncol)=(cam_in%cflx(:ncol,1)-fliq_tot(:ncol))* cpice * state%temp_ini(:ncol,pver) ! +0. - !variable_latent_heat_surface_ls_term (:ncol)= cam_in%cflx(:ncol,1) *((cpwv -cpice)*(state%temp_ini(:ncol,pver)-t00a)+cpice*t00a) - !variable_latent_heat_surface_lf_term (:ncol)= -fliq_tot(:ncol) *((cpliq-cpice)*(state%temp_ini(:ncol,pver)-t00a)+cpice*t00a) - !call outfld ('cpice_srf', variable_latent_heat_surface_cpice_term, pcols, lchnk) !xxx diags will remove - !call outfld ('ls_srf' , variable_latent_heat_surface_ls_term , pcols, lchnk) !xxx diags will remove - !call outfld ('lf_srf' , variable_latent_heat_surface_lf_term , pcols, lchnk) !xxx diags will remove end subroutine enthalpy_adjustment end module check_energy From 7882dcaff8c7d425fa2dd48ee78d705b664c2fe0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=98yvind=20Seland?= Date: Tue, 17 Jun 2025 11:15:48 +0200 Subject: [PATCH 03/78] Moved micro_pumas_cam.F90 to cam7 directory to better facilitate merging --- src/physics/cam7/micro_pumas_cam.F90 | 17 +- .../camnor_phys/physics/micro_pumas_cam.F90 | 3908 ----------------- 2 files changed, 16 insertions(+), 3909 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/micro_pumas_cam.F90 diff --git a/src/physics/cam7/micro_pumas_cam.F90 b/src/physics/cam7/micro_pumas_cam.F90 index d6f9a2ebb1..b627f7d0a9 100644 --- a/src/physics/cam7/micro_pumas_cam.F90 +++ b/src/physics/cam7/micro_pumas_cam.F90 @@ -219,7 +219,7 @@ module micro_pumas_cam qrain_idx=-1, qsnow_idx=-1, & nrain_idx=-1, nsnow_idx=-1, & qcsedten_idx=-1, qrsedten_idx=-1, & - qisedten_idx=-1, qssedten_idx=-1, & + qisedten_idx=-1, qssedten_idx=-1, qgsedten_idx=-1, & !+tht vtrmc_idx=-1, umr_idx=-1, & vtrmi_idx=-1, ums_idx=-1, & qcsevap_idx=-1, qisevap_idx=-1 @@ -816,6 +816,14 @@ subroutine micro_pumas_cam_register call pbuf_add_field('UMS', 'physpkg', dtype_r8, (/pcols,pver/), ums_idx) call pbuf_add_field('QCSEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qcsevap_idx) call pbuf_add_field('QISEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qisevap_idx) +!+tht + else + call pbuf_add_field('QCSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qcsedten_idx) + call pbuf_add_field('QRSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qrsedten_idx) + call pbuf_add_field('QISEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qisedten_idx) + call pbuf_add_field('QSSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qssedten_idx) + call pbuf_add_field('QGSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qgsedten_idx) +!-tht end if end subroutine micro_pumas_cam_register @@ -1448,6 +1456,7 @@ subroutine micro_pumas_cam_init(pbuf2d) if (qrsedten_idx > 0) call pbuf_set_field(pbuf2d, qrsedten_idx, 0._r8) if (qisedten_idx > 0) call pbuf_set_field(pbuf2d, qisedten_idx, 0._r8) if (qssedten_idx > 0) call pbuf_set_field(pbuf2d, qssedten_idx, 0._r8) + if (qgsedten_idx > 0) call pbuf_set_field(pbuf2d, qgsedten_idx, 0._r8) !+tht if (vtrmc_idx > 0) call pbuf_set_field(pbuf2d, vtrmc_idx, 0._r8) if (umr_idx > 0) call pbuf_set_field(pbuf2d, umr_idx, 0._r8) if (vtrmi_idx > 0) call pbuf_set_field(pbuf2d, vtrmi_idx, 0._r8) @@ -1855,6 +1864,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8) :: qrsedtenout_grid(pcols,pver) real(r8) :: qisedtenout_grid(pcols,pver) real(r8) :: qssedtenout_grid(pcols,pver) + real(r8) :: qgsedtenout_grid(pcols,pver)!+tht real(r8) :: vtrmcout_grid(pcols,pver) real(r8) :: umrout_grid(pcols,pver) real(r8) :: vtrmiout_grid(pcols,pver) @@ -1929,6 +1939,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8), pointer :: qrsedtenout_grid_ptr(:,:) real(r8), pointer :: qisedtenout_grid_ptr(:,:) real(r8), pointer :: qssedtenout_grid_ptr(:,:) + real(r8), pointer :: qgsedtenout_grid_ptr(:,:) !+tht real(r8), pointer :: vtrmcout_grid_ptr(:,:) real(r8), pointer :: umrout_grid_ptr(:,:) real(r8), pointer :: vtrmiout_grid_ptr(:,:) @@ -2194,6 +2205,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) if (qrsedten_idx > 0) call pbuf_get_field(pbuf, qrsedten_idx, qrsedtenout_grid_ptr) if (qisedten_idx > 0) call pbuf_get_field(pbuf, qisedten_idx, qisedtenout_grid_ptr) if (qssedten_idx > 0) call pbuf_get_field(pbuf, qssedten_idx, qssedtenout_grid_ptr) + if (qgsedten_idx > 0) call pbuf_get_field(pbuf, qgsedten_idx, qgsedtenout_grid_ptr) !+tht if (vtrmc_idx > 0) call pbuf_get_field(pbuf, vtrmc_idx, vtrmcout_grid_ptr) if (umr_idx > 0) call pbuf_get_field(pbuf, umr_idx, umrout_grid_ptr) if (vtrmi_idx > 0) call pbuf_get_field(pbuf, vtrmi_idx, vtrmiout_grid_ptr) @@ -2923,6 +2935,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) qisevapout_grid(:ncol,:top_lev-1) = 0._r8 qrsedtenout_grid(:ncol,:top_lev-1) = 0._r8 qssedtenout_grid(:ncol,:top_lev-1) = 0._r8 + qgsedtenout_grid(:ncol,:top_lev-1) = 0._r8 !+tht umrout_grid(:ncol,:top_lev-1) = 0._r8 umsout_grid(:ncol,:top_lev-1) = 0._r8 psacro_grid(:ncol,:top_lev-1) = 0._r8 @@ -3013,6 +3026,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) ns_grid = state_loc%q(:,:,ixnumsnow) qrsedtenout_grid(:ncol,top_lev:) = proc_rates%qrsedten qssedtenout_grid(:ncol,top_lev:) = proc_rates%qssedten + qgsedtenout_grid(:ncol,top_lev:) = proc_rates%qgsedten !+tht umrout_grid(:ncol,top_lev:) = proc_rates%umr umsout_grid(:ncol,top_lev:) = proc_rates%ums @@ -3505,6 +3519,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) if (qrsedten_idx > 0) qrsedtenout_grid_ptr = qrsedtenout_grid if (qisedten_idx > 0) qisedtenout_grid_ptr = qisedtenout_grid if (qssedten_idx > 0) qssedtenout_grid_ptr = qssedtenout_grid + if (qgsedten_idx > 0) qgsedtenout_grid_ptr = qgsedtenout_grid !+tht if (vtrmc_idx > 0) vtrmcout_grid_ptr = vtrmcout_grid if (umr_idx > 0) umrout_grid_ptr = umrout_grid if (vtrmi_idx > 0) vtrmiout_grid_ptr = vtrmiout_grid diff --git a/src/physics/camnor_phys/physics/micro_pumas_cam.F90 b/src/physics/camnor_phys/physics/micro_pumas_cam.F90 deleted file mode 100644 index b627f7d0a9..0000000000 --- a/src/physics/camnor_phys/physics/micro_pumas_cam.F90 +++ /dev/null @@ -1,3908 +0,0 @@ -module micro_pumas_cam - -!--------------------------------------------------------------------------------- -! -! CAM Interfaces for MG microphysics -! -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use shr_kind_mod, only: cl=>shr_kind_cl -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp, psubcols -use physconst, only: gravit, rair, tmelt, cpair, rh2o, rhoh2o, & - latvap, latice, mwh2o -use phys_control, only: phys_getopts, use_hetfrz_classnuc - -use shr_const_mod, only: pi => shr_const_pi -use time_manager, only: get_curr_date, get_curr_calday -use phys_grid, only: get_rlat_all_p, get_rlon_all_p -use orbit, only: zenith - -use physics_types, only: physics_state, physics_ptend, & - physics_ptend_init, physics_state_copy, & - physics_update, physics_state_dealloc, & - physics_ptend_sum, physics_ptend_scale - -use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dyn_time_lvls, & - pbuf_old_tim_idx, pbuf_get_index, dtype_r8, dtype_i4, & - pbuf_get_field, pbuf_set_field, col_type_subcol, & - pbuf_register_subcol -use constituents, only: cnst_add, cnst_get_ind, & - cnst_name, cnst_longname, sflxnam, apcnst, bpcnst, pcnst - -use cldfrc2m, only: rhmini=>rhmini_const - -use cam_history, only: addfld, add_default, outfld, horiz_only - -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use error_messages, only: handle_errmsg -use ref_pres, only: top_lev=>trop_cloud_top_lev - -use micro_pumas_diags, only: proc_rates_type - -use subcol_utils, only: subcol_get_scheme - -implicit none -private -save - -public :: & - micro_pumas_cam_readnl, & - micro_pumas_cam_register, & - micro_pumas_cam_init_cnst, & - micro_pumas_cam_implements_cnst, & - micro_pumas_cam_init, & - micro_pumas_cam_tend, & - micro_mg_version, & - massless_droplet_destroyer - -integer :: micro_mg_version = 1 ! Version number for MG. -integer :: micro_mg_sub_version = 0 ! Second part of version number. - -real(r8) :: micro_mg_dcs = -1._r8 -real(r8), target, allocatable :: trop_levs(:) - -logical :: microp_uniform = .false. -logical :: micro_mg_adjust_cpt = .false. - -logical :: micro_do_massless_droplet_destroyer ! turn on/off destruction of massless droplets - -character(len=16) :: micro_mg_precip_frac_method = 'max_overlap' ! type of precipitation fraction method - -real(r8), parameter :: unset_r8 = huge(1.0_r8) - -! Tunable namelist parameters (set in atm_in) -real(r8) :: micro_mg_berg_eff_factor = unset_r8 ! berg efficiency factor -real(r8) :: micro_mg_accre_enhan_fact = unset_r8 ! accretion enhancment factor -real(r8) :: micro_mg_autocon_fact = unset_r8 ! autoconversion prefactor -real(r8) :: micro_mg_autocon_nd_exp = unset_r8 ! autoconversion nd exponent -real(r8) :: micro_mg_autocon_lwp_exp = unset_r8 ! autoconversion lwp exponent -real(r8) :: micro_mg_homog_size = unset_r8 ! size of freezing homogeneous ice -real(r8) :: micro_mg_vtrmi_factor = unset_r8 ! ice fall speed factor -real(r8) :: micro_mg_vtrms_factor = unset_r8 ! snow fall speed factor -real(r8) :: micro_mg_effi_factor = unset_r8 ! ice effective radius factor -real(r8) :: micro_mg_iaccr_factor = unset_r8 ! ice accretion of cloud droplet -real(r8) :: micro_mg_max_nicons = unset_r8 ! max allowed ice number concentration - - -logical, public :: do_cldliq ! Prognose cldliq flag -logical, public :: do_cldice ! Prognose cldice flag - -integer :: num_steps ! Number of MG substeps - -integer :: ncnst = 4 ! Number of constituents - -! Namelist variables for option to specify constant cloud droplet/ice number -logical :: micro_mg_nccons = .false. ! set .true. to specify constant cloud droplet number -logical :: micro_mg_nicons = .false. ! set .true. to specify constant cloud ice number -logical :: micro_mg_ngcons = .false. ! set .true. to specify constant graupel/hail number -logical :: micro_mg_nrcons = .false. ! set .true. to specify constant rain number -logical :: micro_mg_nscons = .false. ! set .true. to specify constant snow number - -! parameters for specified ice and droplet number concentration -! note: these are local in-cloud values, not grid-mean -real(r8) :: micro_mg_ncnst = 50.e6_r8 ! constant liquid droplet num concentration (m-3) -real(r8) :: micro_mg_ninst = 0.05e6_r8 ! ice num concentration when nicons=.true. (m-3) -real(r8) :: micro_mg_nrnst = 0.2e6_r8 ! rain num concentration when nrcons=.true. (m-3) -real(r8) :: micro_mg_nsnst = 0.005e6_r8 ! snow num concentration when nscons=.true. (m-3) -real(r8) :: micro_mg_ngnst = 0.0005e6_r8 ! graupel/hail num concentration when ngcons=.true. (m-3) - -logical, public :: micro_mg_do_graupel -logical, public :: micro_mg_do_hail - -! switches for IFS like behavior -logical :: micro_mg_evap_sed_off = .false. ! Turn off evaporation/sublimation based on cloud fraction for sedimenting condensate -logical :: micro_mg_icenuc_rh_off = .false. ! Remove RH conditional from ice nucleation -logical :: micro_mg_icenuc_use_meyers = .false. ! Meyers Ice Nucleation -logical :: micro_mg_evap_scl_ifs = .false. ! Scale evaporation as IFS does -logical :: micro_mg_evap_rhthrsh_ifs = .false. ! Evap RH threhold following IFS -logical :: micro_mg_rainfreeze_ifs = .false. ! Rain freezing at 0C following IFS -logical :: micro_mg_ifs_sed = .false. ! Snow sedimentation = 1 m/s following IFS -logical :: micro_mg_precip_fall_corr = .false. ! Precip fall speed following IFS (does not go to zero) - -logical :: micro_mg_implicit_fall = .false. !Implicit fall speed (sedimentation) for hydrometeors - -logical :: micro_mg_accre_sees_auto = .false. !Accretion sees autoconverted rain - -character(len=10), parameter :: & ! Constituent names - cnst_names(10) = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE', & - 'RAINQM', 'SNOWQM','NUMRAI','NUMSNO','GRAUQM','NUMGRA'/) - -integer :: & - ixq = -1, &! water vapor - ixcldliq = -1, &! cloud liquid amount index - ixcldice = -1, &! cloud ice amount index - ixnumliq = -1, &! cloud liquid number index - ixnumice = -1, &! cloud ice water index - ixrain = -1, &! rain index - ixsnow = -1, &! snow index - ixnumrain = -1, &! rain number index - ixnumsnow = -1, &! snow number index - ixgraupel = -1, &! graupel index - ixnumgraupel = -1 ! graupel number index - -! Physics buffer indices for fields registered by this module -integer :: & - cldo_idx, & - qme_idx, & - prain_idx, & - nevapr_idx, & - wsedl_idx, & - rei_idx, & - sadice_idx, & - sadsnow_idx, & - rel_idx, & - dei_idx, & - mu_idx, & - prer_evap_idx, & - lambdac_idx, & - iciwpst_idx, & - iclwpst_idx, & - des_idx, & - icswp_idx, & - cldfsnow_idx, & - degrau_idx = -1, & - icgrauwp_idx = -1, & - cldfgrau_idx = -1, & - rate1_cw2pr_st_idx = -1, & - ls_flxprc_idx, & - ls_flxsnw_idx, & - relvar_idx, & - cmeliq_idx, & - accre_enhan_idx - -! Fields for UNICON -integer :: & - am_evp_st_idx, &! Evaporation area of stratiform precipitation - evprain_st_idx, &! Evaporation rate of stratiform rain [kg/kg/s]. >= 0. - evpsnow_st_idx ! Evaporation rate of stratiform snow [kg/kg/s]. >= 0. - -! Fields needed as inputs to COSP -integer :: & - ls_mrprc_idx, ls_mrsnw_idx, & - ls_reffrain_idx, ls_reffsnow_idx, & - cv_reffliq_idx, cv_reffice_idx - -! Fields needed by Park macrophysics -integer :: & - cc_t_idx, cc_qv_idx, & - cc_ql_idx, cc_qi_idx, & - cc_nl_idx, cc_ni_idx, & - cc_qlst_idx - -! Used to replace aspects of MG microphysics -! (e.g. by CARMA) -integer :: & - tnd_qsnow_idx = -1, & - tnd_nsnow_idx = -1, & - re_ice_idx = -1 - -! Index fields for precipitation efficiency. -integer :: & - acpr_idx = -1, & - acgcme_idx = -1, & - acnum_idx = -1 - -! Physics buffer indices for fields registered by other modules -integer :: & - ast_idx = -1, & - cld_idx = -1, & - concld_idx = -1, & - prec_dp_idx = -1, & - prec_sh_idx = -1, & - qsatfac_idx = -1 - -! Pbuf fields needed for subcol_SILHS -integer :: & - qrain_idx=-1, qsnow_idx=-1, & - nrain_idx=-1, nsnow_idx=-1, & - qcsedten_idx=-1, qrsedten_idx=-1, & - qisedten_idx=-1, qssedten_idx=-1, qgsedten_idx=-1, & !+tht - vtrmc_idx=-1, umr_idx=-1, & - vtrmi_idx=-1, ums_idx=-1, & - qcsevap_idx=-1, qisevap_idx=-1 - -integer :: & - naai_idx = -1, & - naai_hom_idx = -1, & - npccn_idx = -1, & - rndst_idx = -1, & - nacon_idx = -1, & - prec_str_idx = -1, & - snow_str_idx = -1, & - prec_pcw_idx = -1, & - snow_pcw_idx = -1, & - prec_sed_idx = -1, & - snow_sed_idx = -1 - -! pbuf fields for heterogeneous freezing -integer :: & - frzimm_idx = -1, & - frzcnt_idx = -1, & - frzdep_idx = -1 - -logical :: allow_sed_supersat ! allow supersaturated conditions after sedimentation loop -character(len=16) :: micro_mg_warm_rain= 'kk2000' ! 'tau', 'emulated', 'sb2001' and ' kk2000' - -integer :: bergso_idx = -1 - -!=============================================================================== -contains -!=============================================================================== - -subroutine micro_pumas_cam_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_real8, & - mpi_logical, mpi_character - - use stochastic_emulated_cam, only: stochastic_emulated_readnl - use stochastic_tau_cam, only: stochastic_tau_readnl - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Namelist variables - logical :: micro_mg_do_cldice = .true. ! do_cldice = .true., MG microphysics is prognosing cldice - logical :: micro_mg_do_cldliq = .true. ! do_cldliq = .true., MG microphysics is prognosing cldliq - integer :: micro_mg_num_steps = 1 ! Number of substepping iterations done by MG (1.5 only for now). - - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: sub = 'micro_pumas_cam_readnl' - - namelist /micro_mg_nl/ micro_mg_version, micro_mg_sub_version, & - micro_mg_do_cldice, micro_mg_do_cldliq, micro_mg_num_steps, & - microp_uniform, micro_mg_dcs, micro_mg_precip_frac_method, & - micro_mg_berg_eff_factor, micro_mg_warm_rain, micro_mg_adjust_cpt, & - micro_mg_do_hail, micro_mg_do_graupel, micro_mg_ngcons, micro_mg_ngnst, & - micro_mg_vtrmi_factor, micro_mg_vtrms_factor, micro_mg_effi_factor, & - micro_mg_iaccr_factor, micro_mg_max_nicons, micro_mg_accre_enhan_fact, & - micro_mg_autocon_fact, micro_mg_autocon_nd_exp, micro_mg_autocon_lwp_exp, micro_mg_homog_size, & - micro_mg_nccons, micro_mg_nicons, micro_mg_ncnst, micro_mg_ninst, & - micro_mg_nrcons, micro_mg_nscons, micro_mg_nrnst, micro_mg_nsnst, & - micro_do_massless_droplet_destroyer, & - micro_mg_evap_sed_off, micro_mg_icenuc_rh_off, micro_mg_icenuc_use_meyers, & - micro_mg_evap_scl_ifs, micro_mg_evap_rhthrsh_ifs, & - micro_mg_rainfreeze_ifs, micro_mg_ifs_sed, micro_mg_precip_fall_corr, & - micro_mg_accre_sees_auto, micro_mg_implicit_fall - - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'micro_mg_nl', status=ierr) - if (ierr == 0) then - read(unitn, micro_mg_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - - ! set local variables - do_cldice = micro_mg_do_cldice - do_cldliq = micro_mg_do_cldliq - num_steps = micro_mg_num_steps - - ! Verify that version numbers are valid. - select case (micro_mg_version) - case (2) - select case (micro_mg_sub_version) - case(0) - ! MG version 2.0 - case default - call bad_version_endrun() - end select - case (3) - select case (micro_mg_sub_version) - case(0) - ! MG version 3.0 - case default - call bad_version_endrun() - end select - case default - call bad_version_endrun() - end select - - if (micro_mg_dcs < 0._r8) call endrun( "micro_pumas_cam_readnl: & - µ_mg_dcs has not been set to a valid value.") - - if (micro_mg_version < 3) then - - if(micro_mg_do_graupel .or. micro_mg_do_hail ) then - call endrun ("micro_pumas_cam_readnl: Micro_mg_do_graupel and micro_mg_do_hail & - &must be false for MG versions before MG3.") - end if - - else ! micro_mg_version = 3 or greater - - if(micro_mg_do_graupel .and. micro_mg_do_hail ) then - call endrun ("micro_pumas_cam_readnl: Only one of micro_mg_do_graupel or & - µ_mg_do_hail may be true at a time.") - end if - - end if - - end if - - ! Broadcast namelist variables - call mpi_bcast(micro_mg_version, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_version") - - call mpi_bcast(micro_mg_sub_version, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_sub_version") - - call mpi_bcast(do_cldice, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_cldice") - - call mpi_bcast(do_cldliq, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_cldliq") - - call mpi_bcast(num_steps, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: num_steps") - - call mpi_bcast(microp_uniform, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: microp_uniform") - - call mpi_bcast(micro_mg_dcs, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_dcs") - - call mpi_bcast(micro_mg_berg_eff_factor, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_berg_eff_factor") - - call mpi_bcast(micro_mg_accre_enhan_fact, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_accre_enhan_fact") - - call mpi_bcast(micro_mg_autocon_fact, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_autocon_fact") - - call mpi_bcast(micro_mg_autocon_nd_exp, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_autocon_nd_exp") - - call mpi_bcast(micro_mg_autocon_lwp_exp, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_autocon_lwp_exp") - - call mpi_bcast(micro_mg_homog_size, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_homog_size") - - call mpi_bcast(micro_mg_vtrmi_factor, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_vtrmi_factor") - - call mpi_bcast(micro_mg_vtrms_factor, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_vtrms_factor") - - call mpi_bcast(micro_mg_effi_factor, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_effi_factor") - - call mpi_bcast(micro_mg_iaccr_factor, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_iaccr_factor") - - call mpi_bcast(micro_mg_max_nicons, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_max_nicons") - - call mpi_bcast(micro_mg_precip_frac_method, 16, mpi_character, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_precip_frac_method") - - call mpi_bcast(micro_mg_warm_rain, 16, mpi_character, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_warm_rain") - - call mpi_bcast(micro_mg_adjust_cpt, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_adjust_cpt") - - call mpi_bcast(micro_mg_nccons, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nccons") - - call mpi_bcast(micro_mg_nicons, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nicons") - - call mpi_bcast(micro_mg_nrcons, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nrcons") - - call mpi_bcast(micro_mg_nscons, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nscons") - - call mpi_bcast(micro_mg_ncnst, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ncnst") - - call mpi_bcast(micro_mg_ninst, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ninst") - - call mpi_bcast(micro_mg_nrnst, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nrnst") - - call mpi_bcast(micro_mg_nsnst, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nsnst") - - call mpi_bcast(micro_mg_do_hail, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_do_hail") - - call mpi_bcast(micro_mg_do_graupel, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_do_graupel") - - call mpi_bcast(micro_mg_ngcons, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ngcons") - - call mpi_bcast(micro_mg_ngnst, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ngnst") - - call mpi_bcast(micro_do_massless_droplet_destroyer, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_do_massless_droplet_destroyer") - - call mpi_bcast(micro_mg_evap_sed_off, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_evap_sed_off") - - call mpi_bcast(micro_mg_icenuc_rh_off, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_icenuc_rh_off") - - call mpi_bcast(micro_mg_icenuc_use_meyers, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_icenuc_use_meyers") - - call mpi_bcast(micro_mg_evap_scl_ifs, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_evap_scl_ifs") - - call mpi_bcast(micro_mg_evap_rhthrsh_ifs, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_evap_rhthrsh_ifs") - - call mpi_bcast(micro_mg_rainfreeze_ifs, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_rainfreeze_ifs") - - call mpi_bcast(micro_mg_ifs_sed, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ifs_sed") - - call mpi_bcast(micro_mg_precip_fall_corr, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_precip_fall_corr") - - call mpi_bcast(micro_mg_implicit_fall, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_implicit_fall") - - call mpi_bcast(micro_mg_accre_sees_auto, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_accre_sees_auto") - - if(micro_mg_berg_eff_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_berg_eff_factor is not set") - if(micro_mg_accre_enhan_fact == unset_r8) call endrun(sub//": FATAL: micro_mg_accre_enhan_fact is not set") - if(micro_mg_autocon_fact == unset_r8) call endrun(sub//": FATAL: micro_mg_autocon_fact is not set") - if(micro_mg_autocon_nd_exp == unset_r8) call endrun(sub//": FATAL: micro_mg_autocon_nd_exp is not set") - if(micro_mg_autocon_lwp_exp == unset_r8) call endrun(sub//": FATAL: micro_mg_autocon_lwp_exp is not set") - if(micro_mg_homog_size == unset_r8) call endrun(sub//": FATAL: micro_mg_homog_size is not set") - if(micro_mg_vtrmi_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_vtrmi_factor is not set") - if(micro_mg_vtrms_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_vtrms_factor is not set") - if(micro_mg_effi_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_effi_factor is not set") - if(micro_mg_iaccr_factor == unset_r8) call endrun(sub//": FATAL: micro_mg_iaccr_factor is not set") - if(micro_mg_max_nicons == unset_r8) call endrun(sub//": FATAL: micro_mg_max_nicons is not set") - - if (masterproc) then - - write(iulog,*) 'MG microphysics namelist:' - write(iulog,*) ' micro_mg_version = ', micro_mg_version - write(iulog,*) ' micro_mg_sub_version = ', micro_mg_sub_version - write(iulog,*) ' micro_mg_do_cldice = ', do_cldice - write(iulog,*) ' micro_mg_do_cldliq = ', do_cldliq - write(iulog,*) ' micro_mg_num_steps = ', num_steps - write(iulog,*) ' microp_uniform = ', microp_uniform - write(iulog,*) ' micro_mg_dcs = ', micro_mg_dcs - write(iulog,*) ' micro_mg_berg_eff_factor = ', micro_mg_berg_eff_factor - write(iulog,*) ' micro_mg_accre_enhan_fact = ', micro_mg_accre_enhan_fact - write(iulog,*) ' micro_mg_autocon_fact = ' , micro_mg_autocon_fact - write(iulog,*) ' micro_mg_autocon_nd_exp = ' , micro_mg_autocon_nd_exp - write(iulog,*) ' micro_mg_autocon_lwp_exp = ' , micro_mg_autocon_lwp_exp - write(iulog,*) ' micro_mg_homog_size = ', micro_mg_homog_size - write(iulog,*) ' micro_mg_vtrmi_factor = ', micro_mg_vtrmi_factor - write(iulog,*) ' micro_mg_vtrms_factor = ', micro_mg_vtrms_factor - write(iulog,*) ' micro_mg_effi_factor = ', micro_mg_effi_factor - write(iulog,*) ' micro_mg_iaccr_factor = ', micro_mg_iaccr_factor - write(iulog,*) ' micro_mg_max_nicons = ', micro_mg_max_nicons - write(iulog,*) ' micro_mg_precip_frac_method = ', micro_mg_precip_frac_method - write(iulog,*) ' micro_mg_warm_rain = ', micro_mg_warm_rain - write(iulog,*) ' micro_mg_adjust_cpt = ', micro_mg_adjust_cpt - write(iulog,*) ' micro_mg_nccons = ', micro_mg_nccons - write(iulog,*) ' micro_mg_nicons = ', micro_mg_nicons - write(iulog,*) ' micro_mg_ncnst = ', micro_mg_ncnst - write(iulog,*) ' micro_mg_ninst = ', micro_mg_ninst - write(iulog,*) ' micro_mg_ngcons = ', micro_mg_ngcons - write(iulog,*) ' micro_mg_ngnst = ', micro_mg_ngnst - write(iulog,*) ' micro_mg_do_hail = ', micro_mg_do_hail - write(iulog,*) ' micro_mg_do_graupel = ', micro_mg_do_graupel - write(iulog,*) ' micro_do_massless_droplet_destroyer = ', micro_do_massless_droplet_destroyer - write(iulog,*) ' micro_mg_nrcons = ', micro_mg_nrcons - write(iulog,*) ' micro_mg_nscons = ', micro_mg_nscons - write(iulog,*) ' micro_mg_nrnst = ', micro_mg_nrnst - write(iulog,*) ' micro_mg_nsnst = ', micro_mg_nsnst - write(iulog,*) ' micro_mg_evap_sed_off = ', micro_mg_evap_sed_off - write(iulog,*) ' micro_mg_icenuc_rh_off = ', micro_mg_icenuc_rh_off - write(iulog,*) ' micro_mg_icenuc_use_meyers = ', micro_mg_icenuc_use_meyers - write(iulog,*) ' micro_mg_evap_scl_ifs = ', micro_mg_evap_scl_ifs - write(iulog,*) ' micro_mg_evap_rhthrsh_ifs = ', micro_mg_evap_rhthrsh_ifs - write(iulog,*) ' micro_mg_rainfreeze_ifs = ', micro_mg_rainfreeze_ifs - write(iulog,*) ' micro_mg_ifs_sed = ', micro_mg_ifs_sed - write(iulog,*) ' micro_mg_precip_fall_corr = ', micro_mg_precip_fall_corr - write(iulog,*) ' micro_mg_implicit_fall = ', micro_mg_implicit_fall - write(iulog,*) ' micro_mg_accre_sees_auto = ', micro_mg_accre_sees_auto - end if - - ! Read in the emulated or tau namelist if needed - if( trim(micro_mg_warm_rain) == 'emulated') then - call stochastic_emulated_readnl(nlfile) - else if (trim(micro_mg_warm_rain) == 'tau') then - call stochastic_tau_readnl(nlfile) - end if - -contains - - subroutine bad_version_endrun - ! Endrun wrapper with a more useful error message. - character(len=128) :: errstring - write(errstring,*) "Invalid version number specified for MG microphysics: ", & - micro_mg_version,".",micro_mg_sub_version - call endrun(errstring) - end subroutine bad_version_endrun - -end subroutine micro_pumas_cam_readnl - -!================================================================================================ - -subroutine micro_pumas_cam_register - use cam_history_support, only: add_vert_coord, hist_dimension_values - use cam_abortutils, only: handle_allocate_error - use carma_flags_mod, only: carma_model - - ! Register microphysics constituents and fields in the physics buffer. - !----------------------------------------------------------------------- - - logical :: prog_modal_aero - logical :: use_subcol_microp ! If true, then are using subcolumns in microphysics - logical :: found - - integer :: i, ierr - real(r8) :: all_levs(pver) - - allocate(trop_levs(pver-top_lev+1), stat=ierr) - call handle_allocate_error(ierr, 'micro_pumas_cam_register', 'trop_levs') - - call phys_getopts(use_subcol_microp_out = use_subcol_microp, & - prog_modal_aero_out = prog_modal_aero) - - ! Register microphysics constituents and save indices. - - call cnst_add(cnst_names(1), mwh2o, cpair, 0._r8, ixcldliq, & - longname='Grid box averaged cloud liquid amount', is_convtran1=.true.) - call cnst_add(cnst_names(2), mwh2o, cpair, 0._r8, ixcldice, & - longname='Grid box averaged cloud ice amount', is_convtran1=.true.) - - call cnst_add(cnst_names(3), mwh2o, cpair, 0._r8, ixnumliq, & - ndropmixed=prog_modal_aero.or.carma_model(:10)=='trop_strat', & - longname='Grid box averaged cloud liquid number', is_convtran1=.true.) - call cnst_add(cnst_names(4), mwh2o, cpair, 0._r8, ixnumice, & - longname='Grid box averaged cloud ice number', is_convtran1=.true.) - - ! Add history coordinate for DDT nlev - call hist_dimension_values('lev',all_levs, 1, pver, found) - - if (found) then - trop_levs(1:pver-top_lev+1) = all_levs(top_lev:pver) - call add_vert_coord('trop_cld_lev', pver-top_lev+1, & - 'troposphere hybrid level at midpoints (1000*(A+B))', 'hPa', trop_levs, & - positive='down' ) - else - call endrun( "micro_pumas_cam_register: unable to find dimension field 'lev'") - end if - - -! ---- Note is_convtran1 is set to .true. - call cnst_add(cnst_names(5), mwh2o, cpair, 0._r8, ixrain, & - longname='Grid box averaged rain amount', is_convtran1=.true.) - call cnst_add(cnst_names(6), mwh2o, cpair, 0._r8, ixsnow, & - longname='Grid box averaged snow amount', is_convtran1=.true.) - call cnst_add(cnst_names(7), mwh2o, cpair, 0._r8, ixnumrain, & - longname='Grid box averaged rain number', is_convtran1=.true.) - call cnst_add(cnst_names(8), mwh2o, cpair, 0._r8, ixnumsnow, & - longname='Grid box averaged snow number', is_convtran1=.true.) - - if (micro_mg_version > 2) then - call cnst_add(cnst_names(9), mwh2o, cpair, 0._r8, ixgraupel, & - longname='Grid box averaged graupel/hail amount', is_convtran1=.true.) - call cnst_add(cnst_names(10), mwh2o, cpair, 0._r8, ixnumgraupel, & - longname='Grid box averaged graupel/hail number', is_convtran1=.true.) - end if - - ! Request physics buffer space for fields that persist across timesteps. - - call pbuf_add_field('CLDO','global',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldo_idx) - - ! Physics buffer variables for convective cloud properties. - - call pbuf_add_field('QME', 'physpkg',dtype_r8,(/pcols,pver/), qme_idx) - call pbuf_add_field('PRAIN', 'physpkg',dtype_r8,(/pcols,pver/), prain_idx) - call pbuf_add_field('NEVAPR', 'physpkg',dtype_r8,(/pcols,pver/), nevapr_idx) - call pbuf_add_field('PRER_EVAP', 'global', dtype_r8,(/pcols,pver/), prer_evap_idx) - call pbuf_add_field('BERGSO', 'physpkg',dtype_r8,(/pcols,pver/), bergso_idx) - - call pbuf_add_field('WSEDL', 'physpkg',dtype_r8,(/pcols,pver/), wsedl_idx) - - call pbuf_add_field('REI', 'physpkg',dtype_r8,(/pcols,pver/), rei_idx) - call pbuf_add_field('SADICE', 'physpkg',dtype_r8,(/pcols,pver/), sadice_idx) - call pbuf_add_field('SADSNOW', 'physpkg',dtype_r8,(/pcols,pver/), sadsnow_idx) - call pbuf_add_field('REL', 'physpkg',dtype_r8,(/pcols,pver/), rel_idx) - - ! Mitchell ice effective diameter for radiation - call pbuf_add_field('DEI', 'physpkg',dtype_r8,(/pcols,pver/), dei_idx) - ! Size distribution shape parameter for radiation - call pbuf_add_field('MU', 'physpkg',dtype_r8,(/pcols,pver/), mu_idx) - ! Size distribution shape parameter for radiation - call pbuf_add_field('LAMBDAC', 'physpkg',dtype_r8,(/pcols,pver/), lambdac_idx) - - ! Stratiform only in cloud ice water path for radiation - call pbuf_add_field('ICIWPST', 'physpkg',dtype_r8,(/pcols,pver/), iciwpst_idx) - ! Stratiform in cloud liquid water path for radiation - call pbuf_add_field('ICLWPST', 'physpkg',dtype_r8,(/pcols,pver/), iclwpst_idx) - - ! Snow effective diameter for radiation - call pbuf_add_field('DES', 'physpkg',dtype_r8,(/pcols,pver/), des_idx) - ! In cloud snow water path for radiation - call pbuf_add_field('ICSWP', 'physpkg',dtype_r8,(/pcols,pver/), icswp_idx) - ! Cloud fraction for liquid drops + snow - call pbuf_add_field('CLDFSNOW ', 'physpkg',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldfsnow_idx) - - if (micro_mg_version > 2) then - ! Graupel effective diameter for radiation - call pbuf_add_field('DEGRAU', 'physpkg',dtype_r8,(/pcols,pver/), degrau_idx) - ! In cloud snow water path for radiation - call pbuf_add_field('ICGRAUWP', 'physpkg',dtype_r8,(/pcols,pver/), icgrauwp_idx) - ! Cloud fraction for liquid drops + graupel - call pbuf_add_field('CLDFGRAU', 'physpkg',dtype_r8,(/pcols,pver/), cldfgrau_idx) - end if - - if (prog_modal_aero) then - call pbuf_add_field('RATE1_CW2PR_ST','physpkg',dtype_r8,(/pcols,pver/), rate1_cw2pr_st_idx) - endif - - call pbuf_add_field('LS_FLXPRC', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxprc_idx) - call pbuf_add_field('LS_FLXSNW', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxsnw_idx) - - - ! Fields needed as inputs to COSP - call pbuf_add_field('LS_MRPRC', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrprc_idx) - call pbuf_add_field('LS_MRSNW', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrsnw_idx) - call pbuf_add_field('LS_REFFRAIN','physpkg',dtype_r8,(/pcols,pver/), ls_reffrain_idx) - call pbuf_add_field('LS_REFFSNOW','physpkg',dtype_r8,(/pcols,pver/), ls_reffsnow_idx) - call pbuf_add_field('CV_REFFLIQ', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffliq_idx) - call pbuf_add_field('CV_REFFICE', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffice_idx) - - ! CC_* Fields needed by Park macrophysics - call pbuf_add_field('CC_T', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_t_idx) - call pbuf_add_field('CC_qv', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qv_idx) - call pbuf_add_field('CC_ql', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ql_idx) - call pbuf_add_field('CC_qi', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qi_idx) - call pbuf_add_field('CC_nl', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_nl_idx) - call pbuf_add_field('CC_ni', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ni_idx) - call pbuf_add_field('CC_qlst', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qlst_idx) - - ! Fields for UNICON - call pbuf_add_field('am_evp_st', 'global', dtype_r8, (/pcols,pver/), am_evp_st_idx) - call pbuf_add_field('evprain_st', 'global', dtype_r8, (/pcols,pver/), evprain_st_idx) - call pbuf_add_field('evpsnow_st', 'global', dtype_r8, (/pcols,pver/), evpsnow_st_idx) - - ! Register subcolumn pbuf fields - if (use_subcol_microp) then - ! Global pbuf fields - call pbuf_register_subcol('CLDO', 'micro_pumas_cam_register', cldo_idx) - - ! CC_* Fields needed by Park macrophysics - call pbuf_register_subcol('CC_T', 'micro_pumas_cam_register', cc_t_idx) - call pbuf_register_subcol('CC_qv', 'micro_pumas_cam_register', cc_qv_idx) - call pbuf_register_subcol('CC_ql', 'micro_pumas_cam_register', cc_ql_idx) - call pbuf_register_subcol('CC_qi', 'micro_pumas_cam_register', cc_qi_idx) - call pbuf_register_subcol('CC_nl', 'micro_pumas_cam_register', cc_nl_idx) - call pbuf_register_subcol('CC_ni', 'micro_pumas_cam_register', cc_ni_idx) - call pbuf_register_subcol('CC_qlst', 'micro_pumas_cam_register', cc_qlst_idx) - - ! Physpkg pbuf fields - ! Physics buffer variables for convective cloud properties. - - call pbuf_register_subcol('QME', 'micro_pumas_cam_register', qme_idx) - call pbuf_register_subcol('PRAIN', 'micro_pumas_cam_register', prain_idx) - call pbuf_register_subcol('NEVAPR', 'micro_pumas_cam_register', nevapr_idx) - call pbuf_register_subcol('PRER_EVAP', 'micro_pumas_cam_register', prer_evap_idx) - call pbuf_register_subcol('BERGSO', 'micro_pumas_cam_register', bergso_idx) - - call pbuf_register_subcol('WSEDL', 'micro_pumas_cam_register', wsedl_idx) - - call pbuf_register_subcol('REI', 'micro_pumas_cam_register', rei_idx) - call pbuf_register_subcol('SADICE', 'micro_pumas_cam_register', sadice_idx) - call pbuf_register_subcol('SADSNOW', 'micro_pumas_cam_register', sadsnow_idx) - call pbuf_register_subcol('REL', 'micro_pumas_cam_register', rel_idx) - - ! Mitchell ice effective diameter for radiation - call pbuf_register_subcol('DEI', 'micro_pumas_cam_register', dei_idx) - ! Size distribution shape parameter for radiation - call pbuf_register_subcol('MU', 'micro_pumas_cam_register', mu_idx) - ! Size distribution shape parameter for radiation - call pbuf_register_subcol('LAMBDAC', 'micro_pumas_cam_register', lambdac_idx) - - ! Stratiform only in cloud ice water path for radiation - call pbuf_register_subcol('ICIWPST', 'micro_pumas_cam_register', iciwpst_idx) - ! Stratiform in cloud liquid water path for radiation - call pbuf_register_subcol('ICLWPST', 'micro_pumas_cam_register', iclwpst_idx) - - ! Snow effective diameter for radiation - call pbuf_register_subcol('DES', 'micro_pumas_cam_register', des_idx) - ! In cloud snow water path for radiation - call pbuf_register_subcol('ICSWP', 'micro_pumas_cam_register', icswp_idx) - ! Cloud fraction for liquid drops + snow - call pbuf_register_subcol('CLDFSNOW ', 'micro_pumas_cam_register', cldfsnow_idx) - - if (micro_mg_version > 2) then - ! Graupel effective diameter for radiation - call pbuf_register_subcol('DEGRAU', 'micro_pumas_cam_register', degrau_idx) - ! In cloud snow water path for radiation - call pbuf_register_subcol('ICGRAUWP', 'micro_pumas_cam_register', icgrauwp_idx) - ! Cloud fraction for liquid drops + snow - call pbuf_register_subcol('CLDFGRAU', 'micro_pumas_cam_register', cldfgrau_idx) - end if - - if (prog_modal_aero) then - call pbuf_register_subcol('RATE1_CW2PR_ST', 'micro_pumas_cam_register', rate1_cw2pr_st_idx) - end if - - call pbuf_register_subcol('LS_FLXPRC', 'micro_pumas_cam_register', ls_flxprc_idx) - call pbuf_register_subcol('LS_FLXSNW', 'micro_pumas_cam_register', ls_flxsnw_idx) - - ! Fields needed as inputs to COSP - call pbuf_register_subcol('LS_MRPRC', 'micro_pumas_cam_register', ls_mrprc_idx) - call pbuf_register_subcol('LS_MRSNW', 'micro_pumas_cam_register', ls_mrsnw_idx) - call pbuf_register_subcol('LS_REFFRAIN', 'micro_pumas_cam_register', ls_reffrain_idx) - call pbuf_register_subcol('LS_REFFSNOW', 'micro_pumas_cam_register', ls_reffsnow_idx) - call pbuf_register_subcol('CV_REFFLIQ', 'micro_pumas_cam_register', cv_reffliq_idx) - call pbuf_register_subcol('CV_REFFICE', 'micro_pumas_cam_register', cv_reffice_idx) - end if - - ! Additional pbuf for CARMA interface - if (.not. do_cldice) then - call pbuf_add_field('TND_QSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_qsnow_idx) - call pbuf_add_field('TND_NSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_nsnow_idx) - call pbuf_add_field('RE_ICE', 'physpkg',dtype_r8,(/pcols,pver/), re_ice_idx) - end if - - ! Precipitation efficiency fields across timesteps. - call pbuf_add_field('ACPRECL', 'global',dtype_r8,(/pcols/), acpr_idx) ! accumulated precip - call pbuf_add_field('ACGCME', 'global',dtype_r8,(/pcols/), acgcme_idx) ! accumulated condensation - call pbuf_add_field('ACNUM', 'global',dtype_i4,(/pcols/), acnum_idx) ! counter for accumulated # timesteps - - ! SGS variability -- These could be reset by CLUBB so they need to be grid only - call pbuf_add_field('RELVAR', 'global',dtype_r8,(/pcols,pver/), relvar_idx) - call pbuf_add_field('ACCRE_ENHAN','global',dtype_r8,(/pcols,pver/), accre_enhan_idx) - - ! Diagnostic fields needed for subcol_SILHS, need to be grid-only - if (subcol_get_scheme() == 'SILHS') then - call pbuf_add_field('QRAIN', 'global',dtype_r8,(/pcols,pver/), qrain_idx) - call pbuf_add_field('QSNOW', 'global',dtype_r8,(/pcols,pver/), qsnow_idx) - call pbuf_add_field('NRAIN', 'global',dtype_r8,(/pcols,pver/), nrain_idx) - call pbuf_add_field('NSNOW', 'global',dtype_r8,(/pcols,pver/), nsnow_idx) - - ! Fields for subcol_SILHS hole filling - ! Note -- hole filling is on the grid, so pbuf_register_setcols do not need to be called for these pbuf fields - call pbuf_add_field('QCSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qcsedten_idx) - call pbuf_add_field('QRSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qrsedten_idx) - call pbuf_add_field('QISEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qisedten_idx) - call pbuf_add_field('QSSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qssedten_idx) - call pbuf_add_field('VTRMC', 'physpkg', dtype_r8, (/pcols,pver/), vtrmc_idx) - call pbuf_add_field('UMR', 'physpkg', dtype_r8, (/pcols,pver/), umr_idx) - call pbuf_add_field('VTRMI', 'physpkg', dtype_r8, (/pcols,pver/), vtrmi_idx) - call pbuf_add_field('UMS', 'physpkg', dtype_r8, (/pcols,pver/), ums_idx) - call pbuf_add_field('QCSEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qcsevap_idx) - call pbuf_add_field('QISEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qisevap_idx) -!+tht - else - call pbuf_add_field('QCSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qcsedten_idx) - call pbuf_add_field('QRSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qrsedten_idx) - call pbuf_add_field('QISEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qisedten_idx) - call pbuf_add_field('QSSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qssedten_idx) - call pbuf_add_field('QGSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qgsedten_idx) -!-tht - end if - -end subroutine micro_pumas_cam_register - -!=============================================================================== - -function micro_pumas_cam_implements_cnst(name) - - ! Return true if specified constituent is implemented by the - ! microphysics package - - character(len=*), intent(in) :: name ! constituent name - logical :: micro_pumas_cam_implements_cnst ! return value - - !----------------------------------------------------------------------- - - micro_pumas_cam_implements_cnst = any(name == cnst_names) - -end function micro_pumas_cam_implements_cnst - -!=============================================================================== - -subroutine micro_pumas_cam_init_cnst(name, latvals, lonvals, mask, q) - - ! Initialize the microphysics constituents, if they are - ! not read from the initial file. - - character(len=*), intent(in) :: name ! constituent name - real(r8), intent(in) :: latvals(:) ! lat in degrees (ncol) - real(r8), intent(in) :: lonvals(:) ! lon in degrees (ncol) - logical, intent(in) :: mask(:) ! Only initialize where .true. - real(r8), intent(out) :: q(:,:) ! kg tracer/kg dry air (gcol, plev - !----------------------------------------------------------------------- - integer :: k - - if (micro_pumas_cam_implements_cnst(name)) then - do k = 1, size(q, 2) - where(mask) - q(:, k) = 0.0_r8 - end where - end do - end if - -end subroutine micro_pumas_cam_init_cnst - -!=============================================================================== - -subroutine micro_pumas_cam_init(pbuf2d) - use time_manager, only: is_first_step - use micro_pumas_utils, only: micro_pumas_utils_init - use micro_pumas_ccpp, only: micro_pumas_ccpp_init - use stochastic_tau_cam, only: stochastic_tau_init_cam - use stochastic_emulated_cam, only: stochastic_emulated_init_cam - - !----------------------------------------------------------------------- - ! - ! Initialization for MG microphysics - ! - !----------------------------------------------------------------------- - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - integer :: m, mm - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_budget ! Output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - logical :: use_subcol_microp - logical :: do_clubb_sgs - integer :: budget_histfile ! output history file number for budget fields - integer :: ierr - character(len=512) :: errstring ! return status (non-blank for error return) - - character(len=cl) :: stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, & - stochastic_emulated_filename_output_scale - - !----------------------------------------------------------------------- - - call phys_getopts(use_subcol_microp_out=use_subcol_microp, & - do_clubb_sgs_out =do_clubb_sgs) - - if (do_clubb_sgs) then - allow_sed_supersat = .false. - else - allow_sed_supersat = .true. - endif - - if (masterproc) then - write(iulog,"(A,I2,A,I2)") "Initializing MG version ",micro_mg_version,".",micro_mg_sub_version - if (.not. do_cldliq) & - write(iulog,*) "MG prognostic cloud liquid has been turned off via namelist." - if (.not. do_cldice) & - write(iulog,*) "MG prognostic cloud ice has been turned off via namelist." - write(iulog,*) "Number of microphysics substeps is: ",num_steps - end if - - ! Set constituent number for later loops. - if(micro_mg_version == 2) then - ncnst = 8 - else - ncnst = 10 - end if - - ! If Machine learning is turned on, perform its initializations - if (trim(micro_mg_warm_rain) == 'tau') then - call stochastic_tau_init_cam() - else if( trim(micro_mg_warm_rain) == 'emulated') then - call stochastic_emulated_init_cam(stochastic_emulated_filename_quantile, & - stochastic_emulated_filename_input_scale, & - stochastic_emulated_filename_output_scale) - end if - - call micro_pumas_ccpp_init(gravit, rair, rh2o, cpair, tmelt, latvap, latice, & - rhmini, iulog, micro_mg_do_hail, micro_mg_do_graupel, & - microp_uniform, do_cldice, use_hetfrz_classnuc, & - allow_sed_supersat, micro_mg_evap_sed_off, & - micro_mg_icenuc_rh_off, micro_mg_icenuc_use_meyers, & - micro_mg_evap_scl_ifs, micro_mg_evap_rhthrsh_ifs, & - micro_mg_rainfreeze_ifs, micro_mg_ifs_sed, & - micro_mg_precip_fall_corr, micro_mg_accre_sees_auto, & - micro_mg_implicit_fall, micro_mg_nccons, & - micro_mg_nicons, micro_mg_ngcons, micro_mg_nrcons, & - micro_mg_nscons, micro_mg_precip_frac_method, & - micro_mg_warm_rain, & - stochastic_emulated_filename_quantile, & - stochastic_emulated_filename_input_scale, & - stochastic_emulated_filename_output_scale, & - micro_mg_dcs, & - micro_mg_berg_eff_factor, micro_mg_accre_enhan_fact, & - micro_mg_autocon_fact, micro_mg_autocon_nd_exp, & - micro_mg_autocon_lwp_exp, micro_mg_homog_size, & - micro_mg_vtrmi_factor, micro_mg_vtrms_factor, & - micro_mg_effi_factor, micro_mg_iaccr_factor, & - micro_mg_max_nicons, micro_mg_ncnst, & - micro_mg_ninst, micro_mg_ngnst, micro_mg_nrnst, & - micro_mg_nsnst, errstring, ierr) - - call handle_errmsg(errstring, subname="micro_pumas_cam_init") - - ! Retrieve the index for water vapor - call cnst_get_ind('Q', ixq) - - ! Register history variables - do m = 1, ncnst - call cnst_get_ind(cnst_names(m), mm) - if ( any(mm == (/ ixcldliq, ixcldice, ixrain, ixsnow, ixgraupel /)) ) then - ! mass mixing ratios - call addfld(cnst_name(mm), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(mm), sampled_on_subcycle=.true.) - call addfld(sflxnam(mm), horiz_only, 'A', 'kg/m2/s', trim(cnst_name(mm))//' surface flux', sampled_on_subcycle=.true.) - else if ( any(mm == (/ ixnumliq, ixnumice, ixnumrain, ixnumsnow, ixnumgraupel /)) ) then - ! number concentrations - call addfld(cnst_name(mm), (/ 'lev' /), 'A', '1/kg', cnst_longname(mm), sampled_on_subcycle=.true.) - call addfld(sflxnam(mm), horiz_only, 'A', '1/m2/s', trim(cnst_name(mm))//' surface flux', sampled_on_subcycle=.true.) - else - call endrun( "micro_pumas_cam_init: & - &Could not call addfld for constituent with unknown units.") - endif - end do - - call addfld(apcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldliq))//' after physics', sampled_on_subcycle=.true.) - call addfld(apcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldice))//' after physics', sampled_on_subcycle=.true.) - call addfld(bpcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldliq))//' before physics', sampled_on_subcycle=.true.) - call addfld(bpcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldice))//' before physics', sampled_on_subcycle=.true.) - - call addfld(apcnst(ixrain), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixrain))//' after physics', sampled_on_subcycle=.true.) - call addfld(apcnst(ixsnow), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixsnow))//' after physics', sampled_on_subcycle=.true.) - call addfld(bpcnst(ixrain), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixrain))//' before physics', sampled_on_subcycle=.true.) - call addfld(bpcnst(ixsnow), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixsnow))//' before physics', sampled_on_subcycle=.true.) - - if (micro_mg_version > 2) then - call addfld(apcnst(ixgraupel), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixgraupel))//' after physics', sampled_on_subcycle=.true.) - call addfld(bpcnst(ixgraupel), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixgraupel))//' before physics', sampled_on_subcycle=.true.) - end if - - call addfld ('CME', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of cond-evap within the cloud', sampled_on_subcycle=.true.) - call addfld ('PRODPREC', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of conversion of condensate to precip', sampled_on_subcycle=.true.) - call addfld ('EVAPPREC', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling precip', sampled_on_subcycle=.true.) - call addfld ('EVAPSNOW', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling snow', sampled_on_subcycle=.true.) - call addfld ('HPROGCLD', (/ 'lev' /), 'A', 'W/kg' , 'Heating from prognostic clouds', sampled_on_subcycle=.true.) - call addfld ('FICE', (/ 'lev' /), 'A', 'fraction', 'Fractional ice content within cloud', sampled_on_subcycle=.true.) - call addfld ('CLDFSNOW', (/ 'lev' /), 'A', '1', 'Cloud fraction adjusted for snow', sampled_on_subcycle=.true.) - call addfld ('ICWMRST', (/ 'lev' /), 'A', 'kg/kg', 'Prognostic in-stratus water mixing ratio', sampled_on_subcycle=.true.) - call addfld ('ICIMRST', (/ 'lev' /), 'A', 'kg/kg', 'Prognostic in-stratus ice mixing ratio', sampled_on_subcycle=.true.) - - ! MG microphysics diagnostics - call addfld ('QCSEVAP', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling cloud water', sampled_on_subcycle=.true.) - call addfld ('QISEVAP', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of sublimation of falling cloud ice', sampled_on_subcycle=.true.) - call addfld ('QVRES', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of residual condensation term', sampled_on_subcycle=.true.) - call addfld ('CMEIOUT', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rate of deposition/sublimation of cloud ice',sampled_on_subcycle=.true.) - call addfld ('VTRMC', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted cloud water fallspeed', sampled_on_subcycle=.true.) - call addfld ('VTRMI', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted cloud ice fallspeed', sampled_on_subcycle=.true.) - call addfld ('QCSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Cloud water mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) - call addfld ('QISEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Cloud ice mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) - call addfld ('PRAO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud water by rain', sampled_on_subcycle=.true.) - call addfld ('PRCO', (/ 'lev' /), 'A', 'kg/kg/s', 'Autoconversion of cloud water', sampled_on_subcycle=.true.) - call addfld ('MNUCCCO', (/ 'lev' /), 'A', 'kg/kg/s', 'Immersion freezing of cloud water', sampled_on_subcycle=.true.) - call addfld ('MNUCCTO', (/ 'lev' /), 'A', 'kg/kg/s', 'Contact freezing of cloud water', sampled_on_subcycle=.true.) - call addfld ('MNUCCDO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Homogeneous and heterogeneous nucleation from vapor', sampled_on_subcycle=.true.) - call addfld ('MNUCCDOhet', (/ 'lev' /), 'A', 'kg/kg/s', 'Heterogeneous nucleation from vapor', sampled_on_subcycle=.true.) - call addfld ('MSACWIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water from rime-splintering', sampled_on_subcycle=.true.) - call addfld ('PSACWSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud water by snow', sampled_on_subcycle=.true.) - call addfld ('BERGSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water to snow from bergeron', sampled_on_subcycle=.true.) - call addfld ('BERGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water to cloud ice from bergeron',sampled_on_subcycle=.true.) - call addfld ('MELTO', (/ 'lev' /), 'A', 'kg/kg/s', 'Melting of cloud ice', sampled_on_subcycle=.true.) - call addfld ('MELTSTOT', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Melting of snow', sampled_on_subcycle=.true.) - call addfld ('MNUDEPO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Deposition Nucleation', sampled_on_subcycle=.true.) - call addfld ('HOMOO', (/ 'lev' /), 'A', 'kg/kg/s', 'Homogeneous freezing of cloud water', sampled_on_subcycle=.true.) - call addfld ('QCRESO', (/ 'lev' /), 'A', 'kg/kg/s', 'Residual condensation term for cloud water', sampled_on_subcycle=.true.) - call addfld ('PRCIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Autoconversion of cloud ice to snow', sampled_on_subcycle=.true.) - call addfld ('PRAIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud ice to snow', sampled_on_subcycle=.true.) - call addfld ('QIRESO', (/ 'lev' /), 'A', 'kg/kg/s', 'Residual deposition term for cloud ice', sampled_on_subcycle=.true.) - call addfld ('MNUCCRO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Heterogeneous freezing of rain to snow', sampled_on_subcycle=.true.) - call addfld ('MNUCCRIO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Heterogeneous freezing of rain to ice', sampled_on_subcycle=.true.) - call addfld ('PRACSO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Accretion of rain by snow', sampled_on_subcycle=.true.) - call addfld ('VAPDEPSO', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Vapor deposition onto snow', sampled_on_subcycle=.true.) - call addfld ('MELTSDT', (/ 'trop_cld_lev' /), 'A', 'W/kg', 'Latent heating rate due to melting of snow', sampled_on_subcycle=.true.) - call addfld ('FRZRDT', (/ 'trop_cld_lev' /), 'A', 'W/kg', 'Latent heating rate due to homogeneous freezing of rain', sampled_on_subcycle=.true.) - call addfld ('QRSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Rain mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) - call addfld ('QSSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Snow mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) - call addfld ('NNUCCCO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Immersion freezing of cloud water', sampled_on_subcycle=.true.) - call addfld ('NNUCCTO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Contact freezing of cloud water', sampled_on_subcycle=.true.) - call addfld ('NNUCCDO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Ice nucleation', sampled_on_subcycle=.true.) - call addfld ('NNUDEPO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Deposition Nucleation', sampled_on_subcycle=.true.) - call addfld ('NHOMO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Homogeneous freezing of cloud water', sampled_on_subcycle=.true.) - call addfld ('NNUCCRO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to heterogeneous freezing of rain to snow', sampled_on_subcycle=.true.) - call addfld ('NNUCCRIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Heterogeneous freezing of rain to ice', sampled_on_subcycle=.true.) - call addfld ('NSACWIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Ice Multiplication- Rime-splintering', sampled_on_subcycle=.true.) - call addfld ('NPRAO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of cloud water by rain', sampled_on_subcycle=.true.) - call addfld ('NPSACWSO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of cloud water by snow', sampled_on_subcycle=.true.) - call addfld ('NPRAIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of cloud ice to snow', sampled_on_subcycle=.true.) - call addfld ('NPRACSO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Accretion of rain by snow', sampled_on_subcycle=.true.) - call addfld ('NPRCO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Autoconversion of cloud water [to rain]', sampled_on_subcycle=.true.) - call addfld ('NPRCIO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Autoconversion of cloud ice to snow', sampled_on_subcycle=.true.) - call addfld ('NCSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to cloud liquid sedimentation', sampled_on_subcycle=.true.) - call addfld ('NISEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to cloud ice sedimentation', sampled_on_subcycle=.true.) - call addfld ('NRSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to rain sedimentation', sampled_on_subcycle=.true.) - call addfld ('NSSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to snow sedimentation', sampled_on_subcycle=.true.) - call addfld ('NMELTO', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Melting of cloud ice', sampled_on_subcycle=.true.) - call addfld ('NMELTS', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Melting of snow', sampled_on_subcycle=.true.) - - if (trim(micro_mg_warm_rain) == 'kk2000') then - call addfld ('qctend_KK2000', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'cloud liquid mass tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) - call addfld ('nctend_KK2000', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'cloud number mass tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) - call addfld ('qrtend_KK2000', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'rain mass tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) - call addfld ('nrtend_KK2000', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'rain number tendency due to autoconversion & accretion from KK2000', sampled_on_subcycle=.true.) - end if - if (trim(micro_mg_warm_rain) == 'sb2001') then - call addfld ('qctend_SB2001', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'cloud liquid mass tendency due to autoconversion & accretion from SB2001', sampled_on_subcycle=.true.) - call addfld ('nctend_SB2001', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'cloud liquid number tendency due to autoconversion & accretion from SB2001',sampled_on_subcycle=.true.) - call addfld ('qrtend_SB2001', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'rain mass tendency due to autoconversion & accretion from SB2001', sampled_on_subcycle=.true.) - call addfld ('nrtend_SB2001', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'rain number tendency due to autoconversion & accretion from SB2001', sampled_on_subcycle=.true.) - end if - call addfld ('LAMC', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter lambda for liquid', sampled_on_subcycle=.true. ) - call addfld ('LAMR', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter lambda for rain', sampled_on_subcycle=.true.) - call addfld ('PGAM', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter mu (pgam) for liquid', sampled_on_subcycle=.true.) - call addfld ('N0R', (/ 'trop_cld_lev' /), 'A', 'unitless', 'Size distribution parameter n0 for rain', sampled_on_subcycle=.true.) - - if (micro_mg_version > 2) then - call addfld ('NMELTG', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to Melting of graupel', sampled_on_subcycle=.true.) - call addfld ('NGSEDTEN', (/ 'trop_cld_lev' /), 'A', '#/kg/s', 'Number Tendency due to graupel sedimentation', sampled_on_subcycle=.true.) - call addfld ('PSACRO', (/ 'lev' /), 'A', 'kg/kg/s', 'Collisions between rain & snow (Graupel collecting snow)',sampled_on_subcycle=.true.) - call addfld ('PRACGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Change in q collection rain by graupel', sampled_on_subcycle=.true.) - call addfld ('PSACWGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Change in q collection droplets by graupel', sampled_on_subcycle=.true.) - call addfld ('PGSACWO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q conversion to graupel due to collection droplets by snow', sampled_on_subcycle=.true.) - call addfld ('PGRACSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q conversion to graupel due to collection rain by snow', sampled_on_subcycle=.true.) - call addfld ('PRDGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Deposition of graupel', sampled_on_subcycle=.true.) - call addfld ('QMULTGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q change due to ice mult droplets/graupel', sampled_on_subcycle=.true.) - call addfld ('QMULTRGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Q change due to ice mult rain/graupel', sampled_on_subcycle=.true.) - call addfld ('QGSEDTEN', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Graupel/Hail mixing ratio tendency from sedimentation', sampled_on_subcycle=.true.) - call addfld ('NPRACGO', (/ 'lev' /), 'A', '#/kg/s', 'Change N collection rain by graupel', sampled_on_subcycle=.true.) - call addfld ('NSCNGO', (/ 'lev' /), 'A', '#/kg/s', 'Change N conversion to graupel due to collection droplets by snow', sampled_on_subcycle=.true.) - call addfld ('NGRACSO', (/ 'lev' /), 'A', '#/kg/s', 'Change N conversion to graupel due to collection rain by snow', sampled_on_subcycle=.true.) - call addfld ('NMULTGO', (/ 'lev' /), 'A', '#/kg/s', 'Ice mult due to acc droplets by graupel', sampled_on_subcycle=.true.) - call addfld ('NMULTRGO', (/ 'lev' /), 'A', '#/kg/s', 'Ice mult due to acc rain by graupel', sampled_on_subcycle=.true.) - call addfld ('NPSACWGO', (/ 'lev' /), 'A', '#/kg/s', 'Change N collection droplets by graupel', sampled_on_subcycle=.true.) - call addfld ('CLDFGRAU', (/ 'lev' /), 'A', '1', 'Cloud fraction adjusted for graupel', sampled_on_subcycle=.true.) - call addfld ('MELTGTOT', (/ 'trop_cld_lev' /), 'A', 'kg/kg/s', 'Melting of graupel', sampled_on_subcycle=.true.) - - end if - - call addfld ('RBFRAC', horiz_only, 'A', 'Fraction', 'Fraction of sky covered by a potential rainbow', sampled_on_subcycle=.true.) - call addfld ('RBFREQ', horiz_only, 'A', 'Frequency', 'Potential rainbow frequency', sampled_on_subcycle=.true.) - call addfld( 'rbSZA', horiz_only, 'I', 'degrees', 'solar zenith angle', sampled_on_subcycle=.true.) - - ! History variables for CAM5 microphysics - call addfld ('MPDT', (/ 'lev' /), 'A', 'W/kg', 'Heating tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDLIQ tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDNLIQ', (/ 'lev' /), 'A', '1/kg/s', 'NUMLIQ tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDNICE', (/ 'lev' /), 'A', '1/kg/s', 'NUMICE tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDW2V', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Vapor tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDW2I', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Ice tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDW2P', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Precip tendency - Morrison microphysics',sampled_on_subcycle=.true.) - call addfld ('MPDI2V', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Vapor tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDI2W', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Water tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('MPDI2P', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Precip tendency - Morrison microphysics', sampled_on_subcycle=.true.) - call addfld ('ICWNC', (/ 'lev' /), 'A', 'm-3', 'Prognostic in-cloud water number conc', sampled_on_subcycle=.true.) - call addfld ('ICINC', (/ 'lev' /), 'A', 'm-3', 'Prognostic in-cloud ice number conc', sampled_on_subcycle=.true.) - call addfld ('EFFLIQ_IND', (/ 'lev' /), 'A','Micron', 'Prognostic droplet effective radius (indirect effect)', sampled_on_subcycle=.true.) - call addfld ('CDNUMC', horiz_only, 'A', '1/m2', 'Vertically-integrated droplet concentration', sampled_on_subcycle=.true.) - call addfld ('MPICLWPI', horiz_only, 'A', 'kg/m2', 'Vertically-integrated & - &in-cloud Initial Liquid WP (Before Micro)', sampled_on_subcycle=.true.) - call addfld ('MPICIWPI', horiz_only, 'A', 'kg/m2', 'Vertically-integrated & - &in-cloud Initial Ice WP (Before Micro)', sampled_on_subcycle=.true.) - - ! This is provided as an example on how to write out subcolumn output - ! NOTE -- only 'I' should be used for sub-column fields as subc-columns could shift from time-step to time-step - if (use_subcol_microp) then - call addfld('FICE_SCOL', (/'psubcols','lev '/), 'I', 'fraction', & - 'Sub-column fractional ice content within cloud', flag_xyfill=.true., fill_value=1.e30_r8, sampled_on_subcycle=.true.) - call addfld('MPDICE_SCOL', (/'psubcols','lev '/), 'I', 'kg/kg/s', & - 'Sub-column CLDICE tendency - Morrison microphysics', flag_xyfill=.true., fill_value=1.e30_r8, sampled_on_subcycle=.true.) - call addfld('MPDLIQ_SCOL', (/'psubcols','lev '/), 'I', 'kg/kg/s', & - 'Sub-column CLDLIQ tendency - Morrison microphysics', flag_xyfill=.true., fill_value=1.e30_r8, sampled_on_subcycle=.true.) - end if - - - ! This is only if the coldpoint temperatures are being adjusted. - ! NOTE: Some fields related to these and output later are added in tropopause.F90. - if (micro_mg_adjust_cpt) then - call addfld ('TROPF_TADJ', (/ 'lev' /), 'A', 'K', 'Temperatures after cold point adjustment', sampled_on_subcycle=.true.) - call addfld ('TROPF_RHADJ', (/ 'lev' /), 'A', 'K', 'Relative Hunidity after cold point adjustment', sampled_on_subcycle=.true.) - call addfld ('TROPF_CDT', horiz_only, 'A', 'K', 'Cold point temperature adjustment', sampled_on_subcycle=.true.) - call addfld ('TROPF_CDZ', horiz_only, 'A', 'm', 'Distance of coldpoint from coldest model level',sampled_on_subcycle=.true.) - end if - - - ! Averaging for cloud particle number and size - call addfld ('AWNC', (/ 'lev' /), 'A', 'm-3', 'Average cloud water number conc', sampled_on_subcycle=.true.) - call addfld ('AWNI', (/ 'lev' /), 'A', 'm-3', 'Average cloud ice number conc', sampled_on_subcycle=.true.) - call addfld ('AREL', (/ 'lev' /), 'A', 'Micron', 'Average droplet effective radius', sampled_on_subcycle=.true.) - call addfld ('AREI', (/ 'lev' /), 'A', 'Micron', 'Average ice effective radius', sampled_on_subcycle=.true.) - ! Frequency arrays for above - call addfld ('FREQL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of liquid', sampled_on_subcycle=.true.) - call addfld ('FREQI', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of ice', sampled_on_subcycle=.true.) - - ! Average cloud top particle size and number (liq, ice) and frequency - call addfld ('ACTREL', horiz_only, 'A', 'Micron', 'Average Cloud Top droplet effective radius', sampled_on_subcycle=.true.) - call addfld ('ACTREI', horiz_only, 'A', 'Micron', 'Average Cloud Top ice effective radius', sampled_on_subcycle=.true.) - call addfld ('ACTNL', horiz_only, 'A', 'm-3', 'Average Cloud Top droplet number', sampled_on_subcycle=.true.) - call addfld ('ACTNI', horiz_only, 'A', 'm-3', 'Average Cloud Top ice number', sampled_on_subcycle=.true.) - - call addfld ('FCTL', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top liquid', sampled_on_subcycle=.true.) - call addfld ('FCTI', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top ice', sampled_on_subcycle=.true.) - - ! New frequency arrays for mixed phase and supercooled liquid (only and mixed) for (a) Cloud Top and (b) everywhere.. - call addfld ('FREQM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of mixed phase', sampled_on_subcycle=.true.) - call addfld ('FREQSL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of only supercooled liquid', sampled_on_subcycle=.true.) - call addfld ('FREQSLM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of super cooled liquid with ice', sampled_on_subcycle=.true.) - call addfld ('FCTM', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top mixed phase', sampled_on_subcycle=.true.) - call addfld ('FCTSL', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top only supercooled liquid', sampled_on_subcycle=.true.) - call addfld ('FCTSLM', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top super cooled liquid with ice', sampled_on_subcycle=.true.) - - call addfld ('LS_FLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s', 'ls stratiform gbm interface rain+snow flux', sampled_on_subcycle=.true.) - call addfld ('LS_FLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s', 'ls stratiform gbm interface snow flux', sampled_on_subcycle=.true.) - - call addfld ('REL', (/ 'lev' /), 'A', 'micron', 'MG REL stratiform cloud effective radius liquid', sampled_on_subcycle=.true.) - call addfld ('REI', (/ 'lev' /), 'A', 'micron', 'MG REI stratiform cloud effective radius ice', sampled_on_subcycle=.true.) - call addfld ('LS_REFFRAIN', (/ 'lev' /), 'A', 'micron', 'ls stratiform rain effective radius', sampled_on_subcycle=.true.) - call addfld ('LS_REFFSNOW', (/ 'lev' /), 'A', 'micron', 'ls stratiform snow effective radius', sampled_on_subcycle=.true.) - call addfld ('CV_REFFLIQ', (/ 'lev' /), 'A', 'micron', 'convective cloud liq effective radius', sampled_on_subcycle=.true.) - call addfld ('CV_REFFICE', (/ 'lev' /), 'A', 'micron', 'convective cloud ice effective radius', sampled_on_subcycle=.true.) - call addfld ('MG_SADICE', (/ 'lev' /), 'A', 'cm2/cm3', 'MG surface area density ice', sampled_on_subcycle=.true.) - call addfld ('MG_SADSNOW', (/ 'lev' /), 'A', 'cm2/cm3', 'MG surface area density snow', sampled_on_subcycle=.true.) - - ! diagnostic precip - call addfld ('QRAIN', (/ 'lev' /), 'A', 'kg/kg', 'Diagnostic grid-mean rain mixing ratio', sampled_on_subcycle=.true.) - call addfld ('QSNOW', (/ 'lev' /), 'A', 'kg/kg', 'Diagnostic grid-mean snow mixing ratio', sampled_on_subcycle=.true.) - call addfld ('NRAIN', (/ 'lev' /), 'A', 'm-3', 'Diagnostic grid-mean rain number conc', sampled_on_subcycle=.true.) - call addfld ('NSNOW', (/ 'lev' /), 'A', 'm-3', 'Diagnostic grid-mean snow number conc', sampled_on_subcycle=.true.) - - ! size of precip - call addfld ('RERCLD', (/ 'lev' /), 'A', 'm', 'Diagnostic effective radius of Liquid Cloud and Rain', sampled_on_subcycle=.true.) - call addfld ('DSNOW', (/ 'lev' /), 'A', 'm', 'Diagnostic grid-mean snow diameter', sampled_on_subcycle=.true.) - - ! diagnostic radar reflectivity, cloud-averaged - call addfld ('REFL', (/ 'lev' /), 'A', 'DBz', '94 GHz radar reflectivity', sampled_on_subcycle=.true.) - call addfld ('AREFL', (/ 'lev' /), 'A', 'DBz', 'Average 94 GHz radar reflectivity', sampled_on_subcycle=.true.) - call addfld ('FREFL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of radar reflectivity', sampled_on_subcycle=.true.) - - call addfld ('CSRFL', (/ 'lev' /), 'A', 'DBz', '94 GHz radar reflectivity (CloudSat thresholds)', sampled_on_subcycle=.true.) - call addfld ('ACSRFL', (/ 'lev' /), 'A', 'DBz', 'Average 94 GHz radar reflectivity (CloudSat thresholds)', sampled_on_subcycle=.true.) - call addfld ('FCSRFL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of radar reflectivity (CloudSat thresholds)', sampled_on_subcycle=.true.) - - call addfld ('AREFLZ', (/ 'lev' /), 'A', 'mm^6/m^3', 'Average 94 GHz radar reflectivity', sampled_on_subcycle=.true.) - - ! 10cm (rain) radar reflectivity - call addfld ('REFL10CM', (/ 'lev' /), 'A', 'DBz', '10cm (Rain) radar reflectivity (Dbz)', sampled_on_subcycle=.true.) - call addfld ('REFLZ10CM', (/ 'lev' /), 'A', 'mm^6/m^3', '10cm (Rain) radar reflectivity (Z units)', sampled_on_subcycle=.true.) - - ! Aerosol information - call addfld ('NCAL', (/ 'lev' /), 'A', '1/m3', 'Number Concentation Activated for Liquid', sampled_on_subcycle=.true.) - call addfld ('NCAI', (/ 'lev' /), 'A', '1/m3', 'Number Concentation Activated for Ice', sampled_on_subcycle=.true.) - - ! Average rain and snow mixing ratio (Q), number (N) and diameter (D), with frequency - call addfld ('AQRAIN', (/ 'lev' /), 'A', 'kg/kg', 'Average rain mixing ratio', sampled_on_subcycle=.true.) - call addfld ('AQSNOW', (/ 'lev' /), 'A', 'kg/kg', 'Average snow mixing ratio', sampled_on_subcycle=.true.) - call addfld ('ANRAIN', (/ 'lev' /), 'A', 'm-3', 'Average rain number conc', sampled_on_subcycle=.true.) - call addfld ('ANSNOW', (/ 'lev' /), 'A', 'm-3', 'Average snow number conc', sampled_on_subcycle=.true.) - call addfld ('ADRAIN', (/ 'lev' /), 'A', 'm', 'Average rain effective Diameter', sampled_on_subcycle=.true.) - call addfld ('ADSNOW', (/ 'lev' /), 'A', 'm', 'Average snow effective Diameter', sampled_on_subcycle=.true.) - call addfld ('FREQR', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of rain', sampled_on_subcycle=.true.) - call addfld ('FREQS', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of snow', sampled_on_subcycle=.true.) - - ! precipitation efficiency & other diagnostic fields - call addfld('PE' , horiz_only, 'A', '1', 'Stratiform Precipitation Efficiency (precip/cmeliq)', sampled_on_subcycle=.true.) - call addfld('APRL' , horiz_only, 'A', 'm/s', 'Average Stratiform Precip Rate over efficiency calculation', sampled_on_subcycle=.true.) - call addfld('PEFRAC', horiz_only, 'A', '1', 'Fraction of timesteps precip efficiency reported', sampled_on_subcycle=.true.) - call addfld('VPRCO' , horiz_only, 'A', 'kg/kg/s', 'Vertical average of autoconversion rate', sampled_on_subcycle=.true.) - call addfld('VPRAO' , horiz_only, 'A', 'kg/kg/s', 'Vertical average of accretion rate', sampled_on_subcycle=.true.) - call addfld('RACAU' , horiz_only, 'A', 'kg/kg/s', 'Accretion/autoconversion ratio from vertical average', sampled_on_subcycle=.true.) - - call addfld('UMR', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted rain fallspeed', sampled_on_subcycle=.true.) - call addfld('UMS', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted snow fallspeed', sampled_on_subcycle=.true.) - - if (micro_mg_version > 2) then - call addfld('UMG', (/ 'trop_cld_lev' /), 'A', 'm/s', 'Mass-weighted graupel/hail fallspeed', sampled_on_subcycle=.true.) - call addfld ('FREQG', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of Graupel', sampled_on_subcycle=.true.) - call addfld ('LS_REFFGRAU', (/ 'lev' /), 'A', 'micron', 'ls stratiform graupel/hail effective radius', sampled_on_subcycle=.true.) - call addfld ('AQGRAU', (/ 'lev' /), 'A', 'kg/kg', 'Average graupel/hail mixing ratio', sampled_on_subcycle=.true.) - call addfld ('ANGRAU', (/ 'lev' /), 'A', 'm-3', 'Average graupel/hail number conc', sampled_on_subcycle=.true.) - end if - - - ! qc limiter (only output in versions 1.5 and later) - call addfld('QCRAT', (/ 'lev' /), 'A', 'fraction', 'Qc Limiter: Fraction of qc tendency applied', sampled_on_subcycle=.true.) - - ! determine the add_default fields - call phys_getopts(history_amwg_out = history_amwg , & - history_budget_out = history_budget , & - history_budget_histfile_num_out = budget_histfile) - - if (history_amwg) then - call add_default ('FICE ', 1, ' ') - call add_default ('AQRAIN ', 1, ' ') - call add_default ('AQSNOW ', 1, ' ') - call add_default ('ANRAIN ', 1, ' ') - call add_default ('ANSNOW ', 1, ' ') - call add_default ('ADRAIN ', 1, ' ') - call add_default ('ADSNOW ', 1, ' ') - call add_default ('AREI ', 1, ' ') - call add_default ('AREL ', 1, ' ') - call add_default ('AWNC ', 1, ' ') - call add_default ('AWNI ', 1, ' ') - call add_default ('CDNUMC ', 1, ' ') - call add_default ('FREQR ', 1, ' ') - call add_default ('FREQS ', 1, ' ') - call add_default ('FREQL ', 1, ' ') - call add_default ('FREQI ', 1, ' ') - do m = 1, ncnst - call cnst_get_ind(cnst_names(m), mm) - call add_default(cnst_name(mm), 1, ' ') - end do - end if - - if ( history_budget ) then - call add_default ('EVAPSNOW ', budget_histfile, ' ') - call add_default ('EVAPPREC ', budget_histfile, ' ') - call add_default ('QVRES ', budget_histfile, ' ') - call add_default ('QISEVAP ', budget_histfile, ' ') - call add_default ('QCSEVAP ', budget_histfile, ' ') - call add_default ('QISEDTEN ', budget_histfile, ' ') - call add_default ('QCSEDTEN ', budget_histfile, ' ') - call add_default ('QIRESO ', budget_histfile, ' ') - call add_default ('QCRESO ', budget_histfile, ' ') - call add_default ('QRSEDTEN ', budget_histfile, ' ') - call add_default ('QSSEDTEN ', budget_histfile, ' ') - call add_default ('PSACWSO ', budget_histfile, ' ') - call add_default ('PRCO ', budget_histfile, ' ') - call add_default ('PRCIO ', budget_histfile, ' ') - call add_default ('PRAO ', budget_histfile, ' ') - call add_default ('PRAIO ', budget_histfile, ' ') - call add_default ('PRACSO ', budget_histfile, ' ') - call add_default ('VAPDEPSO ', budget_histfile, ' ') - call add_default ('MSACWIO ', budget_histfile, ' ') - call add_default ('MPDW2V ', budget_histfile, ' ') - call add_default ('MPDW2P ', budget_histfile, ' ') - call add_default ('MPDW2I ', budget_histfile, ' ') - call add_default ('MPDT ', budget_histfile, ' ') - call add_default ('MPDQ ', budget_histfile, ' ') - call add_default ('MPDLIQ ', budget_histfile, ' ') - call add_default ('MPDICE ', budget_histfile, ' ') - call add_default ('MPDI2W ', budget_histfile, ' ') - call add_default ('MPDI2V ', budget_histfile, ' ') - call add_default ('MPDI2P ', budget_histfile, ' ') - call add_default ('MNUCCTO ', budget_histfile, ' ') - call add_default ('MNUCCRO ', budget_histfile, ' ') - call add_default ('MNUCCRIO ', budget_histfile, ' ') - call add_default ('MNUCCCO ', budget_histfile, ' ') - call add_default ('MELTSDT ', budget_histfile, ' ') - call add_default ('MELTO ', budget_histfile, ' ') - call add_default ('HOMOO ', budget_histfile, ' ') - call add_default ('FRZRDT ', budget_histfile, ' ') - call add_default ('CMEIOUT ', budget_histfile, ' ') - call add_default ('BERGSO ', budget_histfile, ' ') - call add_default ('BERGO ', budget_histfile, ' ') - call add_default ('MELTSTOT ', budget_histfile, ' ') - call add_default ('MNUDEPO ', budget_histfile, ' ') - call add_default ('NNUCCCO ', budget_histfile, ' ') - call add_default ('NNUCCTO ', budget_histfile, ' ') - call add_default ('NNUCCDO ', budget_histfile, ' ') - call add_default ('NNUDEPO ', budget_histfile, ' ') - call add_default ('NHOMO ', budget_histfile, ' ') - call add_default ('NNUCCRO ', budget_histfile, ' ') - call add_default ('NNUCCRIO ', budget_histfile, ' ') - call add_default ('NSACWIO ', budget_histfile, ' ') - call add_default ('NPRAO ', budget_histfile, ' ') - call add_default ('NPSACWSO ', budget_histfile, ' ') - call add_default ('NPRAIO ', budget_histfile, ' ') - call add_default ('NPRACSO ', budget_histfile, ' ') - call add_default ('NPRCO ', budget_histfile, ' ') - call add_default ('NPRCIO ', budget_histfile, ' ') - call add_default ('NCSEDTEN ', budget_histfile, ' ') - call add_default ('NISEDTEN ', budget_histfile, ' ') - call add_default ('NRSEDTEN ', budget_histfile, ' ') - call add_default ('NSSEDTEN ', budget_histfile, ' ') - call add_default ('NMELTO ', budget_histfile, ' ') - call add_default ('NMELTS ', budget_histfile, ' ') - call add_default ('NCAL ', budget_histfile, ' ') - if (micro_mg_version > 2) then - call add_default ('QGSEDTEN ', budget_histfile, ' ') - call add_default ('PSACRO ', budget_histfile, ' ') - call add_default ('PRACGO ', budget_histfile, ' ') - call add_default ('PSACWGO ', budget_histfile, ' ') - call add_default ('PGSACWO ', budget_histfile, ' ') - call add_default ('PGRACSO ', budget_histfile, ' ') - call add_default ('PRDGO ', budget_histfile, ' ') - call add_default ('QMULTGO ', budget_histfile, ' ') - call add_default ('QMULTRGO ', budget_histfile, ' ') - call add_default ('MELTGTOT ', budget_histfile, ' ') - call add_default ('NPRACGO ', budget_histfile, ' ') - call add_default ('NSCNGO ', budget_histfile, ' ') - call add_default ('NGRACSO ', budget_histfile, ' ') - call add_default ('NMULTGO ', budget_histfile, ' ') - call add_default ('NMULTRGO ', budget_histfile, ' ') - call add_default ('NPSACWGO ', budget_histfile, ' ') - call add_default ('NGSEDTEN ', budget_histfile, ' ') - call add_default ('NMELTG ', budget_histfile, ' ') - end if - call add_default(cnst_name(ixcldliq), budget_histfile, ' ') - call add_default(cnst_name(ixcldice), budget_histfile, ' ') - call add_default(apcnst (ixcldliq), budget_histfile, ' ') - call add_default(apcnst (ixcldice), budget_histfile, ' ') - call add_default(bpcnst (ixcldliq), budget_histfile, ' ') - call add_default(bpcnst (ixcldice), budget_histfile, ' ') - call add_default(cnst_name(ixrain), budget_histfile, ' ') - call add_default(cnst_name(ixsnow), budget_histfile, ' ') - call add_default(apcnst (ixrain), budget_histfile, ' ') - call add_default(apcnst (ixsnow), budget_histfile, ' ') - call add_default(bpcnst (ixrain), budget_histfile, ' ') - call add_default(bpcnst (ixsnow), budget_histfile, ' ') - - if (micro_mg_version > 2) then - call add_default(cnst_name(ixgraupel), budget_histfile, ' ') - call add_default(apcnst (ixgraupel), budget_histfile, ' ') - call add_default(bpcnst (ixgraupel), budget_histfile, ' ') - end if - - end if - - ! physics buffer indices - ast_idx = pbuf_get_index('AST') - cld_idx = pbuf_get_index('CLD') - concld_idx = pbuf_get_index('CONCLD') - prec_dp_idx = pbuf_get_index('PREC_DP') - prec_sh_idx = pbuf_get_index('PREC_SH') - - naai_idx = pbuf_get_index('NAAI') - naai_hom_idx = pbuf_get_index('NAAI_HOM') - npccn_idx = pbuf_get_index('NPCCN') - rndst_idx = pbuf_get_index('RNDST') - nacon_idx = pbuf_get_index('NACON') - - prec_str_idx = pbuf_get_index('PREC_STR') - snow_str_idx = pbuf_get_index('SNOW_STR') - prec_sed_idx = pbuf_get_index('PREC_SED') - snow_sed_idx = pbuf_get_index('SNOW_SED') - prec_pcw_idx = pbuf_get_index('PREC_PCW') - snow_pcw_idx = pbuf_get_index('SNOW_PCW') - - cmeliq_idx = pbuf_get_index('CMELIQ') - - ! These fields may have been added, so don't abort if they have not been - qsatfac_idx = pbuf_get_index('QSATFAC', ierr) - qrain_idx = pbuf_get_index('QRAIN', ierr) - qsnow_idx = pbuf_get_index('QSNOW', ierr) - nrain_idx = pbuf_get_index('NRAIN', ierr) - nsnow_idx = pbuf_get_index('NSNOW', ierr) - - ! fields for heterogeneous freezing - frzimm_idx = pbuf_get_index('FRZIMM', ierr) - frzcnt_idx = pbuf_get_index('FRZCNT', ierr) - frzdep_idx = pbuf_get_index('FRZDEP', ierr) - - ! Initialize physics buffer grid fields for accumulating precip and condensation - if (is_first_step()) then - call pbuf_set_field(pbuf2d, cldo_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8) - call pbuf_set_field(pbuf2d, acpr_idx, 0._r8) - call pbuf_set_field(pbuf2d, acgcme_idx, 0._r8) - call pbuf_set_field(pbuf2d, acnum_idx, 0) - call pbuf_set_field(pbuf2d, relvar_idx, 2._r8) - call pbuf_set_field(pbuf2d, accre_enhan_idx, 1._r8) - call pbuf_set_field(pbuf2d, am_evp_st_idx, 0._r8) - call pbuf_set_field(pbuf2d, evprain_st_idx, 0._r8) - call pbuf_set_field(pbuf2d, evpsnow_st_idx, 0._r8) - call pbuf_set_field(pbuf2d, prer_evap_idx, 0._r8) - call pbuf_set_field(pbuf2d, bergso_idx, 0._r8) - call pbuf_set_field(pbuf2d, icswp_idx, 0._r8) - call pbuf_set_field(pbuf2d, cldfsnow_idx, 0._r8) - call pbuf_set_field(pbuf2d, dei_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, des_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, mu_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, lambdac_idx, 0.0_r8) - - if (degrau_idx > 0) call pbuf_set_field(pbuf2d, degrau_idx, 0.0_r8) - if (icgrauwp_idx > 0) call pbuf_set_field(pbuf2d, icgrauwp_idx, 0.0_r8) - if (qrain_idx > 0) call pbuf_set_field(pbuf2d, qrain_idx, 0._r8) - if (qsnow_idx > 0) call pbuf_set_field(pbuf2d, qsnow_idx, 0._r8) - if (nrain_idx > 0) call pbuf_set_field(pbuf2d, nrain_idx, 0._r8) - if (nsnow_idx > 0) call pbuf_set_field(pbuf2d, nsnow_idx, 0._r8) - if (qcsedten_idx > 0) call pbuf_set_field(pbuf2d, qcsedten_idx, 0._r8) - if (qrsedten_idx > 0) call pbuf_set_field(pbuf2d, qrsedten_idx, 0._r8) - if (qisedten_idx > 0) call pbuf_set_field(pbuf2d, qisedten_idx, 0._r8) - if (qssedten_idx > 0) call pbuf_set_field(pbuf2d, qssedten_idx, 0._r8) - if (qgsedten_idx > 0) call pbuf_set_field(pbuf2d, qgsedten_idx, 0._r8) !+tht - if (vtrmc_idx > 0) call pbuf_set_field(pbuf2d, vtrmc_idx, 0._r8) - if (umr_idx > 0) call pbuf_set_field(pbuf2d, umr_idx, 0._r8) - if (vtrmi_idx > 0) call pbuf_set_field(pbuf2d, vtrmi_idx, 0._r8) - if (ums_idx > 0) call pbuf_set_field(pbuf2d, ums_idx, 0._r8) - if (qcsevap_idx > 0) call pbuf_set_field(pbuf2d, qcsevap_idx, 0._r8) - if (qisevap_idx > 0) call pbuf_set_field(pbuf2d, qisevap_idx, 0._r8) - - ! If sub-columns turned on, need to set the sub-column fields as well - if (use_subcol_microp) then - call pbuf_set_field(pbuf2d, cldo_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_qlst_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, icswp_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cldfsnow_idx,0._r8, col_type=col_type_subcol) - end if - - end if - -end subroutine micro_pumas_cam_init - -!=============================================================================== - -subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) - - use micro_pumas_utils, only: size_dist_param_basic, size_dist_param_liq - use micro_pumas_utils, only: mg_liq_props, mg_ice_props, avg_diameter - use micro_pumas_utils, only: rhoi, rhosn, rhow, rhows, rhog, qsmall, mincld - - use micro_pumas_ccpp, only: micro_pumas_ccpp_run - - use physics_buffer, only: pbuf_col_type_index - use subcol, only: subcol_field_avg - use tropopause, only: tropopause_find_cam, TROP_ALG_CPP, TROP_ALG_NONE, NOTFOUND - use wv_saturation, only: qsat - use infnan, only: nan, assignment(=) - use cam_abortutils, only: handle_allocate_error - - use stochastic_tau_cam, only: ncd - - type(physics_state), intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtime - type(physics_buffer_desc), pointer :: pbuf(:) - - ! Local variables - - type(proc_rates_type) :: proc_rates - - integer :: lchnk, ncol, psetcols, ngrdcol - - integer :: i, k, itim_old, it - - real(r8), parameter :: micron2meter = 1.e6_r8 - real(r8), parameter :: shapeparam = 1.e5_r8 - - real(r8), pointer :: naai(:,:) ! ice nucleation number - real(r8), pointer :: naai_hom(:,:) ! ice nucleation number (homogeneous) - real(r8), pointer :: npccn(:,:) ! liquid activation number tendency - real(r8), pointer :: rndst(:,:,:) - real(r8), pointer :: nacon(:,:,:) - real(r8), pointer :: am_evp_st_grid(:,:) ! Evaporation area of stratiform precipitation. 0<= am_evp_st <=1. - real(r8), pointer :: evprain_st_grid(:,:) ! Evaporation rate of stratiform rain [kg/kg/s] - real(r8), pointer :: evpsnow_st_grid(:,:) ! Evaporation rate of stratiform snow [kg/kg/s] - - real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] - real(r8), pointer :: snow_str(:) ! [Total] Sfc flux of snow from stratiform [ m/s ] - real(r8), pointer :: prec_sed(:) ! Surface flux of total cloud water from sedimentation - real(r8), pointer :: snow_sed(:) ! Surface flux of cloud ice from sedimentation - real(r8), pointer :: prec_pcw(:) ! Sfc flux of precip from microphysics [ m/s ] - real(r8), pointer :: snow_pcw(:) ! Sfc flux of snow from microphysics [ m/s ] - - real(r8), pointer :: ast(:,:) ! Relative humidity cloud fraction - real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. - real(r8), pointer :: alst_mic(:,:) - real(r8), pointer :: aist_mic(:,:) - real(r8), pointer :: cldo(:,:) ! Old cloud fraction - real(r8), pointer :: nevapr(:,:) ! Evaporation of total precipitation (rain + snow) - real(r8), pointer :: prer_evap(:,:) ! precipitation evaporation rate - real(r8), pointer :: relvar(:,:) ! relative variance of cloud water - real(r8), pointer :: accre_enhan(:,:) ! optional accretion enhancement for experimentation - real(r8), pointer :: prain(:,:) ! Total precipitation (rain + snow) - real(r8), pointer :: dei(:,:) ! Ice effective diameter (meters) - real(r8), pointer :: mu(:,:) ! Size distribution shape parameter for radiation - real(r8), pointer :: lambdac(:,:) ! Size distribution slope parameter for radiation - real(r8), pointer :: des(:,:) ! Snow effective diameter (m) - real(r8), pointer :: degrau(:,:) ! Graupel effective diameter (m) - real(r8), pointer :: bergstot(:,:) ! Conversion of cloud water to snow from bergeron - - !These variables need to be extracted from the - !proc_rates DDT in order for the subcolumn averaging - !routine to work properly when writing out diagnostic - !fields. - real(r8) :: evapsnow_sc(state%psetcols,pver-top_lev+1) - real(r8) :: bergstot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qcrestot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: melttot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: mnuccctot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: mnuccttot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: bergtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: homotot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: msacwitot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: psacwstot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: cmeitot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qirestot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: prcitot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: praitot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: pratot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: prctot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qcsedten_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qisedten_sc(state%psetcols,pver-top_lev+1) - real(r8) :: vtrmc_sc(state%psetcols,pver-top_lev+1) - real(r8) :: vtrmi_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qcsevap_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qisevap_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qrsedten_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qssedten_sc(state%psetcols,pver-top_lev+1) - real(r8) :: umr_sc(state%psetcols,pver-top_lev+1) - real(r8) :: ums_sc(state%psetcols,pver-top_lev+1) - real(r8) :: psacrtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: pracgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: psacwgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: pgsacwtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: pgracstot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: prdgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qmultgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: qmultrgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: npracgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: nscngtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: ngracstot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: nmultgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: nmultrgtot_sc(state%psetcols,pver-top_lev+1) - real(r8) :: npsacwgtot_sc(state%psetcols,pver-top_lev+1) - - real(r8) :: rho(state%psetcols,pver) - real(r8) :: cldmax(state%psetcols,pver) - - real(r8) :: rate1cld(state%psetcols,pver) ! array to hold rate1ord_cw2pr_st from microphysics - - real(r8) :: tlat(state%psetcols,pver) - real(r8) :: qvlat(state%psetcols,pver) - real(r8) :: qcten(state%psetcols,pver) - real(r8) :: qiten(state%psetcols,pver) - real(r8) :: ncten(state%psetcols,pver) - real(r8) :: niten(state%psetcols,pver) - - real(r8) :: qrten(state%psetcols,pver) - real(r8) :: qsten(state%psetcols,pver) - real(r8) :: nrten(state%psetcols,pver) - real(r8) :: nsten(state%psetcols,pver) - real(r8) :: qgten(state%psetcols,pver) - real(r8) :: ngten(state%psetcols,pver) - - real(r8) :: prect(state%psetcols) - real(r8) :: preci(state%psetcols) - real(r8) :: am_evp_st(state%psetcols,pver) ! Area over which precip evaporates - real(r8) :: cmeice(state%psetcols,pver) ! Rate of cond-evap of ice within the cloud - real(r8) :: qsout(state%psetcols,pver) ! Snow mixing ratio - real(r8) :: cflx(state%psetcols,pverp) ! grid-box avg liq condensate flux (kg m^-2 s^-1) - real(r8) :: iflx(state%psetcols,pverp) ! grid-box avg ice condensate flux (kg m^-2 s^-1) - real(r8) :: rflx(state%psetcols,pverp) ! grid-box average rain flux (kg m^-2 s^-1) - real(r8) :: sflx(state%psetcols,pverp) ! grid-box average snow flux (kg m^-2 s^-1) - real(r8) :: gflx(state%psetcols,pverp) ! grid-box average snow flux (kg m^-2 s^-1) - real(r8) :: qrout(state%psetcols,pver) ! Rain mixing ratio - - real(r8) :: nrout(state%psetcols,pver) - real(r8) :: nsout(state%psetcols,pver) - real(r8) :: refl(state%psetcols,pver) ! analytic radar reflectivity - real(r8) :: arefl(state%psetcols,pver) ! average reflectivity will zero points outside valid range - real(r8) :: areflz(state%psetcols,pver) ! average reflectivity in z. - real(r8) :: frefl(state%psetcols,pver) - real(r8) :: csrfl(state%psetcols,pver) ! cloudsat reflectivity - real(r8) :: acsrfl(state%psetcols,pver) ! cloudsat average - real(r8) :: fcsrfl(state%psetcols,pver) - real(r8) :: refl10cm(state%psetcols,pver) ! analytic radar reflectivity - real(r8) :: reflz10cm(state%psetcols,pver) ! analytic radar reflectivity Z - real(r8) :: rercld(state%psetcols,pver) ! effective radius calculation for rain + cloud - real(r8) :: ncai(state%psetcols,pver) ! output number conc of ice nuclei available (1/m3) - real(r8) :: ncal(state%psetcols,pver) ! output number conc of CCN (1/m3) - real(r8) :: qrout2(state%psetcols,pver) - real(r8) :: qsout2(state%psetcols,pver) - real(r8) :: nrout2(state%psetcols,pver) - real(r8) :: nsout2(state%psetcols,pver) - real(r8) :: freqs(state%psetcols,pver) - real(r8) :: freqr(state%psetcols,pver) - real(r8) :: nfice(state%psetcols,pver) - real(r8) :: qcrat(state%psetcols,pver) ! qc limiter ratio (1=no limit) - -!Hail/Graupel Output - real(r8) :: freqg(state%psetcols,pver) - real(r8) :: qgout(state%psetcols,pver) - real(r8) :: ngout(state%psetcols,pver) - real(r8) :: dgout(state%psetcols,pver) - real(r8) :: qgout2(state%psetcols,pver) - real(r8) :: ngout2(state%psetcols,pver) - real(r8) :: dgout2(state%psetcols,pver) - - ! Dummy arrays for cases where we throw away the MG version and - ! recalculate sizes on the CAM grid to avoid time/subcolumn averaging - ! issues. - real(r8) :: rel_fn_dum(state%ncol,pver) - real(r8) :: dsout2_dum(state%ncol,pver) - real(r8) :: drout_dum(state%ncol,pver) - real(r8) :: reff_rain_dum(state%ncol,pver) - real(r8) :: reff_snow_dum(state%ncol,pver) - real(r8) :: reff_grau_dum(state%ncol,pver) !not used for now or passed to COSP. - real(r8), target :: nan_array(state%ncol,pver) ! Array for NaN's - - ! Heterogeneous-only version of mnuccdtot. - real(r8) :: mnuccdohet(state%psetcols,pver) - - ! physics buffer fields for COSP simulator - real(r8), pointer :: mgflxprc(:,:) ! MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces (kg/m2/s) - real(r8), pointer :: mgflxsnw(:,:) ! MG grid-box mean flux_large_scale_cloud_snow at interfaces (kg/m2/s) - real(r8), pointer :: mgmrprc(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces (kg/kg) - real(r8), pointer :: mgmrsnw(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces (kg/kg) - real(r8), pointer :: mgreffrain_grid(:,:) ! MG diagnostic rain effective radius (um) - real(r8), pointer :: mgreffsnow_grid(:,:) ! MG diagnostic snow effective radius (um) - real(r8), pointer :: cvreffliq(:,:) ! convective cloud liquid effective radius (um) - real(r8), pointer :: cvreffice(:,:) ! convective cloud ice effective radius (um) - - ! physics buffer fields used with CARMA - real(r8), pointer, dimension(:,:) :: tnd_qsnow ! external tendency on snow mass (kg/kg/s) - real(r8), pointer, dimension(:,:) :: tnd_nsnow ! external tendency on snow number(#/kg/s) - real(r8), pointer, dimension(:,:) :: re_ice ! ice effective radius (m) - - real(r8), pointer :: rate1ord_cw2pr_st(:,:) ! 1st order rate for direct conversion of - ! strat. cloud water to precip (1/s) ! rce 2010/05/01 - real(r8), pointer :: wsedl(:,:) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] - - - real(r8), pointer :: CC_T(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_qv(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_ql(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_qi(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_nl(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_ni(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_qlst(:,:) ! In-liquid stratus microphysical tendency - - ! variables for heterogeneous freezing - real(r8), pointer :: frzimm(:,:) - real(r8), pointer :: frzcnt(:,:) - real(r8), pointer :: frzdep(:,:) - - real(r8), pointer :: qme(:,:) - - ! A local copy of state is used for diagnostic calculations - type(physics_state) :: state_loc - type(physics_ptend) :: ptend_loc - - real(r8) :: icecldf(state%psetcols,pver) ! Ice cloud fraction - real(r8) :: liqcldf(state%psetcols,pver) ! Liquid cloud fraction (combined into cloud) - - real(r8), pointer :: rel(:,:) ! Liquid effective drop radius (microns) - real(r8), pointer :: rei(:,:) ! Ice effective drop size (microns) - real(r8), pointer :: sadice(:,:) ! Ice surface area density (cm2/cm3) - real(r8), pointer :: sadsnow(:,:) ! Snow surface area density (cm2/cm3) - - - real(r8), pointer :: cmeliq(:,:) - - real(r8), pointer :: cld(:,:) ! Total cloud fraction - real(r8), pointer :: concld(:,:) ! Convective cloud fraction - real(r8), pointer :: prec_dp(:) ! Deep Convective precip - real(r8), pointer :: prec_sh(:) ! Shallow Convective precip - - real(r8), pointer :: iciwpst(:,:) ! Stratiform in-cloud ice water path for radiation - real(r8), pointer :: iclwpst(:,:) ! Stratiform in-cloud liquid water path for radiation - real(r8), pointer :: cldfsnow(:,:) ! Cloud fraction for liquid+snow - real(r8), pointer :: icswp(:,:) ! In-cloud snow water path - - real(r8), pointer :: cldfgrau(:,:) ! Cloud fraction for liquid+snow - real(r8), pointer :: icgrauwp(:,:) ! In-cloud snow water path - - real(r8) :: icimrst(state%psetcols,pver) ! In stratus ice mixing ratio - real(r8) :: icwmrst(state%psetcols,pver) ! In stratus water mixing ratio - real(r8) :: icinc(state%psetcols,pver) ! In cloud ice number conc - real(r8) :: icwnc(state%psetcols,pver) ! In cloud water number conc - - real(r8) :: iclwpi(state%psetcols) ! Vertically-integrated in-cloud Liquid WP before microphysics - real(r8) :: iciwpi(state%psetcols) ! Vertically-integrated in-cloud Ice WP before microphysics - - ! Averaging arrays for effective radius and number.... - real(r8) :: efiout_grid(pcols,pver) - real(r8) :: efcout_grid(pcols,pver) - real(r8) :: ncout_grid(pcols,pver) - real(r8) :: niout_grid(pcols,pver) - real(r8) :: freqi_grid(pcols,pver) - real(r8) :: freql_grid(pcols,pver) - -! Averaging arrays for supercooled liquid - real(r8) :: freqm_grid(pcols,pver) - real(r8) :: freqsl_grid(pcols,pver) - real(r8) :: freqslm_grid(pcols,pver) - real(r8) :: fctm_grid(pcols) - real(r8) :: fctsl_grid(pcols) - real(r8) :: fctslm_grid(pcols) - - real(r8) :: cdnumc_grid(pcols) ! Vertically-integrated droplet concentration - real(r8) :: icimrst_grid_out(pcols,pver) ! In stratus ice mixing ratio - real(r8) :: icwmrst_grid_out(pcols,pver) ! In stratus water mixing ratio - - ! Cloud fraction used for precipitation. - real(r8) :: cldmax_grid(pcols,pver) - - ! Average cloud top radius & number - real(r8) :: ctrel_grid(pcols) - real(r8) :: ctrei_grid(pcols) - real(r8) :: ctnl_grid(pcols) - real(r8) :: ctni_grid(pcols) - real(r8) :: fcti_grid(pcols) - real(r8) :: fctl_grid(pcols) - - real(r8) :: ftem_grid(pcols,pver) - - ! Variables for precip efficiency calculation - real(r8) :: minlwp ! LWP threshold - - real(r8), pointer, dimension(:) :: acprecl_grid ! accumulated precip across timesteps - real(r8), pointer, dimension(:) :: acgcme_grid ! accumulated condensation across timesteps - integer, pointer, dimension(:) :: acnum_grid ! counter for # timesteps accumulated - - ! Variables for liquid water path and column condensation - real(r8) :: tgliqwp_grid(pcols) ! column liquid - real(r8) :: tgcmeliq_grid(pcols) ! column condensation rate (units) - - real(r8) :: pe_grid(pcols) ! precip efficiency for output - real(r8) :: pefrac_grid(pcols) ! fraction of time precip efficiency is written out - real(r8) :: tpr_grid(pcols) ! average accumulated precipitation rate in pe calculation - - ! variables for autoconversion and accretion vertical averages - real(r8) :: vprco_grid(pcols) ! vertical average autoconversion - real(r8) :: vprao_grid(pcols) ! vertical average accretion - real(r8) :: racau_grid(pcols) ! ratio of vertical averages - integer :: cnt_grid(pcols) ! counters - - logical :: lq(pcnst) - - real(r8) :: icimrst_grid(pcols,pver) ! stratus ice mixing ratio - on grid - real(r8) :: icwmrst_grid(pcols,pver) ! stratus water mixing ratio - on grid - - real(r8), pointer :: lambdac_grid(:,:) - real(r8), pointer :: mu_grid(:,:) - real(r8), pointer :: rel_grid(:,:) - real(r8), pointer :: rei_grid(:,:) - real(r8), pointer :: sadice_grid(:,:) - real(r8), pointer :: sadsnow_grid(:,:) - real(r8), pointer :: dei_grid(:,:) - real(r8), pointer :: des_grid(:,:) - real(r8), pointer :: iclwpst_grid(:,:) - real(r8), pointer :: degrau_grid(:,:) - - real(r8) :: rho_grid(pcols,pver) - real(r8) :: liqcldf_grid(pcols,pver) - real(r8) :: qsout_grid(pcols,pver) - real(r8) :: ncic_grid(pcols,pver) - real(r8) :: niic_grid(pcols,pver) - real(r8) :: rel_fn_grid(pcols,pver) ! Ice effective drop size at fixed number (indirect effect) (microns) - on grid - real(r8) :: qrout_grid(pcols,pver) - real(r8) :: drout2_grid(pcols,pver) - real(r8) :: dsout2_grid(pcols,pver) - real(r8) :: nsout_grid(pcols,pver) - real(r8) :: nrout_grid(pcols,pver) - real(r8) :: reff_rain_grid(pcols,pver) - real(r8) :: reff_snow_grid(pcols,pver) - real(r8) :: reff_grau_grid(pcols,pver) - real(r8) :: cld_grid(pcols,pver) - real(r8) :: pdel_grid(pcols,pver) - real(r8) :: prco_grid(pcols,pver) - real(r8) :: prao_grid(pcols,pver) - real(r8) :: icecldf_grid(pcols,pver) - real(r8) :: icwnc_grid(pcols,pver) - real(r8) :: icinc_grid(pcols,pver) - real(r8) :: qcreso_grid(pcols,pver) - real(r8) :: melto_grid(pcols,pver) - real(r8) :: mnuccco_grid(pcols,pver) - real(r8) :: mnuccto_grid(pcols,pver) - real(r8) :: bergo_grid(pcols,pver) - real(r8) :: homoo_grid(pcols,pver) - real(r8) :: msacwio_grid(pcols,pver) - real(r8) :: psacwso_grid(pcols,pver) - real(r8) :: cmeiout_grid(pcols,pver) - real(r8) :: qireso_grid(pcols,pver) - real(r8) :: prcio_grid(pcols,pver) - real(r8) :: praio_grid(pcols,pver) - real(r8) :: psacro_grid(pcols,pver) - real(r8) :: pracgo_grid(pcols,pver) - real(r8) :: psacwgo_grid(pcols,pver) - real(r8) :: pgsacwo_grid(pcols,pver) - real(r8) :: pgracso_grid(pcols,pver) - real(r8) :: prdgo_grid(pcols,pver) - real(r8) :: qmultgo_grid(pcols,pver) - real(r8) :: qmultrgo_grid(pcols,pver) - real(r8) :: npracgo_grid(pcols,pver) - real(r8) :: nscngo_grid(pcols,pver) - real(r8) :: ngracso_grid(pcols,pver) - real(r8) :: nmultgo_grid(pcols,pver) - real(r8) :: nmultrgo_grid(pcols,pver) - real(r8) :: npsacwgo_grid(pcols,pver) - real(r8) :: qcsedtenout_grid(pcols,pver) - real(r8) :: qrsedtenout_grid(pcols,pver) - real(r8) :: qisedtenout_grid(pcols,pver) - real(r8) :: qssedtenout_grid(pcols,pver) - real(r8) :: qgsedtenout_grid(pcols,pver)!+tht - real(r8) :: vtrmcout_grid(pcols,pver) - real(r8) :: umrout_grid(pcols,pver) - real(r8) :: vtrmiout_grid(pcols,pver) - real(r8) :: umsout_grid(pcols,pver) - real(r8) :: qcsevapout_grid(pcols,pver) - real(r8) :: qisevapout_grid(pcols,pver) - - real(r8) :: nc_grid(pcols,pver) - real(r8) :: ni_grid(pcols,pver) - real(r8) :: qr_grid(pcols,pver) - real(r8) :: nr_grid(pcols,pver) - real(r8) :: qs_grid(pcols,pver) - real(r8) :: ns_grid(pcols,pver) - real(r8) :: qg_grid(pcols,pver) - real(r8) :: ng_grid(pcols,pver) - - real(r8) :: dgout2_grid(pcols,pver) - - real(r8) :: cp_rh(pcols,pver) - real(r8) :: cp_t(pcols) - real(r8) :: cp_z(pcols) - real(r8) :: cp_dt(pcols) - real(r8) :: cp_dz(pcols) - integer :: troplev(pcols) - real(r8) :: es - real(r8) :: qs - - real(r8) :: state_loc_graup(state%psetcols,pver) - real(r8) :: state_loc_numgraup(state%psetcols,pver) - - real(r8), pointer :: cmeliq_grid(:,:) - - real(r8), pointer :: prec_str_grid(:) - real(r8), pointer :: snow_str_grid(:) - real(r8), pointer :: prec_pcw_grid(:) - real(r8), pointer :: snow_pcw_grid(:) - real(r8), pointer :: prec_sed_grid(:) - real(r8), pointer :: snow_sed_grid(:) - real(r8), pointer :: cldo_grid(:,:) - real(r8), pointer :: nevapr_grid(:,:) - real(r8), pointer :: prain_grid(:,:) - real(r8), pointer :: mgflxprc_grid(:,:) - real(r8), pointer :: mgflxsnw_grid(:,:) - real(r8), pointer :: mgmrprc_grid(:,:) - real(r8), pointer :: mgmrsnw_grid(:,:) - real(r8), pointer :: cvreffliq_grid(:,:) - real(r8), pointer :: cvreffice_grid(:,:) - real(r8), pointer :: rate1ord_cw2pr_st_grid(:,:) - real(r8), pointer :: wsedl_grid(:,:) - real(r8), pointer :: CC_t_grid(:,:) - real(r8), pointer :: CC_qv_grid(:,:) - real(r8), pointer :: CC_ql_grid(:,:) - real(r8), pointer :: CC_qi_grid(:,:) - real(r8), pointer :: CC_nl_grid(:,:) - real(r8), pointer :: CC_ni_grid(:,:) - real(r8), pointer :: CC_qlst_grid(:,:) - real(r8), pointer :: qme_grid(:,:) - real(r8), pointer :: iciwpst_grid(:,:) - real(r8), pointer :: icswp_grid(:,:) - real(r8), pointer :: ast_grid(:,:) - real(r8), pointer :: cldfsnow_grid(:,:) - real(r8), pointer :: bergso_grid(:,:) - - real(r8), pointer :: icgrauwp_grid(:,:) - real(r8), pointer :: cldfgrau_grid(:,:) - - real(r8), pointer :: qrout_grid_ptr(:,:) - real(r8), pointer :: qsout_grid_ptr(:,:) - real(r8), pointer :: nrout_grid_ptr(:,:) - real(r8), pointer :: nsout_grid_ptr(:,:) - real(r8), pointer :: qcsedtenout_grid_ptr(:,:) - real(r8), pointer :: qrsedtenout_grid_ptr(:,:) - real(r8), pointer :: qisedtenout_grid_ptr(:,:) - real(r8), pointer :: qssedtenout_grid_ptr(:,:) - real(r8), pointer :: qgsedtenout_grid_ptr(:,:) !+tht - real(r8), pointer :: vtrmcout_grid_ptr(:,:) - real(r8), pointer :: umrout_grid_ptr(:,:) - real(r8), pointer :: vtrmiout_grid_ptr(:,:) - real(r8), pointer :: umsout_grid_ptr(:,:) - real(r8), pointer :: qcsevapout_grid_ptr(:,:) - real(r8), pointer :: qisevapout_grid_ptr(:,:) - - - logical :: use_subcol_microp - integer :: col_type ! Flag to store whether accessing grid or sub-columns in pbuf_get_field - integer :: ierr - integer :: nlev - integer :: num_dust_bins - - character(512) :: ccpp_errmsg ! CCPP return status (non-blank for error return) - character(128) :: pumas_errstring ! PUMAS return status (non-blank for error return) - - ! For rrtmg optics. specified distribution. - real(r8), parameter :: dcon = 25.e-6_r8 ! Convective size distribution effective radius (meters) - real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter - real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) - -! Rainbows: SZA - real(r8) :: zen_angle(state%psetcols) ! Daytime solar zenith angles (radians) - real(r8) :: rlats(state%psetcols), rlons(state%psetcols) ! chunk latitudes and longitudes (radians) - real(r8) :: sza(state%psetcols) ! solar zenith angles (degrees) - real(r8), parameter :: rad2deg = 180._r8/pi ! radians to degrees conversion factor - real(r8) :: calday !current calendar day - - real(r8) :: precc(state%psetcols) ! convective precip rate - -! Rainbow frequency and fraction for output - - real(r8) :: rbfreq(state%psetcols) - real(r8) :: rbfrac(state%psetcols) - -!Rainbows: parameters - - real(r8), parameter :: rb_rmin =1.e-6_r8 ! Strat Rain threshold (mixing ratio) - real(r8), parameter :: rb_rcmin = 5._r8/(86400._r8*1000._r8) ! Conv Rain Threshold (mm/d--> m/s) - real(r8), parameter :: rb_pmin =85000._r8 ! Minimum pressure for surface layer - real(r8), parameter :: deg2rad = pi/180._r8 ! Conversion factor - integer :: top_idx !Index for top level below rb_pmin - real(r8) :: convmx - real(r8) :: cldmx - real(r8) :: frlow - real(r8) :: cldtot - real(r8) :: rmax - logical :: rval - - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - psetcols = state%psetcols - ngrdcol = state%ngrdcol - itim_old = pbuf_old_tim_idx() - nlev = pver - top_lev + 1 - - nan_array = nan - - ! Allocate the proc_rates DDT - ! IMPORTANT NOTE -- elements in proc_rates are dimensioned to the nlev dimension while - ! all the other arrays in this routine are dimensioned pver. This is required because - ! PUMAS only gets the top_lev:pver array subsection, and the proc_rates arrays - ! need to be the same levels. - call proc_rates%allocate(ncol, nlev, ncd, micro_mg_warm_rain, pumas_errstring) - - call handle_errmsg(pumas_errstring, subname="micro_pumas_cam_tend") - - - call phys_getopts(use_subcol_microp_out=use_subcol_microp) - - ! Set the col_type flag to grid or subcolumn dependent on the value of use_subcol_microp - call pbuf_col_type_index(use_subcol_microp, col_type=col_type) - - !----------------------- - ! These physics buffer fields are read only and not set in this parameterization - ! If these fields do not have subcolumn data, copy the grid to the subcolumn if subcolumns is turned on - ! If subcolumns is not turned on, then these fields will be grid data - - call pbuf_get_field(pbuf, naai_idx, naai, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, naai_hom_idx, naai_hom, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, npccn_idx, npccn, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, rndst_idx, rndst, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, nacon_idx, nacon, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, relvar_idx, relvar, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, cmeliq_idx, cmeliq, col_type=col_type, copy_if_needed=use_subcol_microp) - - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & - col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & - col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & - col_type=col_type, copy_if_needed=use_subcol_microp) - - ! Get convective precip for rainbows - if (prec_dp_idx > 0) then - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp, col_type=col_type, copy_if_needed=use_subcol_microp) - else - nullify(prec_dp) - end if - if (prec_sh_idx > 0) then - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh, col_type=col_type, copy_if_needed=use_subcol_microp) - else - nullify(prec_sh) - end if - -! Merge Precipitation rates (multi-process) - if (associated(prec_dp) .and. associated(prec_sh)) then - precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) - else if (associated(prec_dp)) then - precc(:ncol) = prec_dp(:ncol) - else if (associated(prec_sh)) then - precc(:ncol) = prec_sh(:ncol) - else - precc(:ncol) = 0._r8 - end if - - if (.not. do_cldice) then - ! If we are NOT prognosing ice and snow tendencies, then get them from the Pbuf - call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, tnd_nsnow_idx, tnd_nsnow, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, re_ice_idx, re_ice, col_type=col_type, copy_if_needed=use_subcol_microp) - else - ! If we ARE prognosing tendencies, then just point to an array of NaN fields to have - ! something for PUMAS to use in call - tnd_qsnow => nan_array - tnd_nsnow => nan_array - re_ice => nan_array - end if - - if (use_hetfrz_classnuc) then - call pbuf_get_field(pbuf, frzimm_idx, frzimm, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, frzcnt_idx, frzcnt, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, frzdep_idx, frzdep, col_type=col_type, copy_if_needed=use_subcol_microp) - else - ! Needed to satisfy gnu compiler with optional argument - set to an array of Nan fields - frzimm => nan_array - frzcnt => nan_array - frzdep => nan_array - end if - - if (qsatfac_idx > 0) then - call pbuf_get_field(pbuf, qsatfac_idx, qsatfac, col_type=col_type, copy_if_needed=use_subcol_microp) - else - allocate(qsatfac(ncol,pver),stat=ierr) - call handle_allocate_error(ierr, 'micro_pumas_cam_tend', 'qsatfac') - qsatfac = 1._r8 - end if - - ! initialize tendency variables - preci = 0._r8 - prect = 0._r8 - - ! initialize subcolumn variables - if (use_subcol_microp) then - evapsnow_sc = 0.0_r8 - bergstot_sc = 0.0_r8 - qcrestot_sc = 0.0_r8 - melttot_sc = 0.0_r8 - mnuccctot_sc = 0.0_r8 - mnuccttot_sc = 0.0_r8 - bergtot_sc = 0.0_r8 - homotot_sc = 0.0_r8 - msacwitot_sc = 0.0_r8 - psacwstot_sc = 0.0_r8 - cmeitot_sc = 0.0_r8 - qirestot_sc = 0.0_r8 - prcitot_sc = 0.0_r8 - praitot_sc = 0.0_r8 - pratot_sc = 0.0_r8 - prctot_sc = 0.0_r8 - qcsedten_sc = 0.0_r8 - qisedten_sc = 0.0_r8 - vtrmc_sc = 0.0_r8 - vtrmi_sc = 0.0_r8 - qcsevap_sc = 0.0_r8 - qisevap_sc = 0.0_r8 - qrsedten_sc = 0.0_r8 - qssedten_sc = 0.0_r8 - umr_sc = 0.0_r8 - ums_sc = 0.0_r8 - if (micro_mg_version > 2) then - psacrtot_sc = 0.0_r8 - pracgtot_sc = 0.0_r8 - psacwgtot_sc = 0.0_r8 - pgsacwtot_sc = 0.0_r8 - pgracstot_sc = 0.0_r8 - prdgtot_sc = 0.0_r8 - qmultgtot_sc = 0.0_r8 - qmultrgtot_sc = 0.0_r8 - npracgtot_sc = 0.0_r8 - nscngtot_sc = 0.0_r8 - ngracstot_sc = 0.0_r8 - nmultgtot_sc = 0.0_r8 - nmultrgtot_sc = 0.0_r8 - npsacwgtot_sc = 0.0_r8 - end if - end if - - !----------------------- - ! These physics buffer fields are calculated and set in this parameterization - ! If subcolumns is turned on, then these fields will be calculated on a subcolumn grid, otherwise they will be a normal grid - - call pbuf_get_field(pbuf, prec_str_idx, prec_str, col_type=col_type) - call pbuf_get_field(pbuf, snow_str_idx, snow_str, col_type=col_type) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw, col_type=col_type) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw, col_type=col_type) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed, col_type=col_type) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed, col_type=col_type) - call pbuf_get_field(pbuf, nevapr_idx, nevapr, col_type=col_type) - call pbuf_get_field(pbuf, prer_evap_idx, prer_evap, col_type=col_type) - call pbuf_get_field(pbuf, prain_idx, prain, col_type=col_type) - call pbuf_get_field(pbuf, dei_idx, dei, col_type=col_type) - call pbuf_get_field(pbuf, mu_idx, mu, col_type=col_type) - call pbuf_get_field(pbuf, lambdac_idx, lambdac, col_type=col_type) - call pbuf_get_field(pbuf, des_idx, des, col_type=col_type) - call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc, col_type=col_type) - call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw, col_type=col_type) - call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc, col_type=col_type) - call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw, col_type=col_type) - call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq, col_type=col_type) - call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice, col_type=col_type) - call pbuf_get_field(pbuf, iciwpst_idx, iciwpst, col_type=col_type) - call pbuf_get_field(pbuf, iclwpst_idx, iclwpst, col_type=col_type) - call pbuf_get_field(pbuf, icswp_idx, icswp, col_type=col_type) - call pbuf_get_field(pbuf, rel_idx, rel, col_type=col_type) - call pbuf_get_field(pbuf, rei_idx, rei, col_type=col_type) - call pbuf_get_field(pbuf, sadice_idx, sadice, col_type=col_type) - call pbuf_get_field(pbuf, sadsnow_idx, sadsnow, col_type=col_type) - call pbuf_get_field(pbuf, wsedl_idx, wsedl, col_type=col_type) - call pbuf_get_field(pbuf, qme_idx, qme, col_type=col_type) - call pbuf_get_field(pbuf, bergso_idx, bergstot, col_type=col_type) - - ! Assign the pointer values to the non-pointer proc_rates element - proc_rates%bergstot(:ncol,1:nlev) = bergstot(:ncol,top_lev:pver) - - if (degrau_idx > 0) call pbuf_get_field(pbuf, degrau_idx, degrau, col_type=col_type) - if (icgrauwp_idx > 0) call pbuf_get_field(pbuf, icgrauwp_idx, icgrauwp, col_type=col_type) - if (cldfgrau_idx > 0) call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau, col_type=col_type) - - call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_t_idx, CC_t, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_qv_idx, CC_qv, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_ql_idx, CC_ql, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_qi_idx, CC_qi, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_nl_idx, CC_nl, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_ni_idx, CC_ni, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - - if (rate1_cw2pr_st_idx > 0) then - call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st, col_type=col_type) - end if - - if (qrain_idx > 0) call pbuf_get_field(pbuf, qrain_idx, qrout_grid_ptr) - if (qsnow_idx > 0) call pbuf_get_field(pbuf, qsnow_idx, qsout_grid_ptr) - if (nrain_idx > 0) call pbuf_get_field(pbuf, nrain_idx, nrout_grid_ptr) - if (nsnow_idx > 0) call pbuf_get_field(pbuf, nsnow_idx, nsout_grid_ptr) - if (qcsedten_idx > 0) call pbuf_get_field(pbuf, qcsedten_idx, qcsedtenout_grid_ptr) - if (qrsedten_idx > 0) call pbuf_get_field(pbuf, qrsedten_idx, qrsedtenout_grid_ptr) - if (qisedten_idx > 0) call pbuf_get_field(pbuf, qisedten_idx, qisedtenout_grid_ptr) - if (qssedten_idx > 0) call pbuf_get_field(pbuf, qssedten_idx, qssedtenout_grid_ptr) - if (qgsedten_idx > 0) call pbuf_get_field(pbuf, qgsedten_idx, qgsedtenout_grid_ptr) !+tht - if (vtrmc_idx > 0) call pbuf_get_field(pbuf, vtrmc_idx, vtrmcout_grid_ptr) - if (umr_idx > 0) call pbuf_get_field(pbuf, umr_idx, umrout_grid_ptr) - if (vtrmi_idx > 0) call pbuf_get_field(pbuf, vtrmi_idx, vtrmiout_grid_ptr) - if (ums_idx > 0) call pbuf_get_field(pbuf, ums_idx, umsout_grid_ptr) - if (qcsevap_idx > 0) call pbuf_get_field(pbuf, qcsevap_idx, qcsevapout_grid_ptr) - if (qisevap_idx > 0) call pbuf_get_field(pbuf, qisevap_idx, qisevapout_grid_ptr) - - !----------------------- - ! If subcolumns is turned on, all calculated fields which are on subcolumns - ! need to be retrieved on the grid as well for storing averaged values - - if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_grid) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_grid) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw_grid) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw_grid) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed_grid) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed_grid) - call pbuf_get_field(pbuf, nevapr_idx, nevapr_grid) - call pbuf_get_field(pbuf, prain_idx, prain_grid) - call pbuf_get_field(pbuf, dei_idx, dei_grid) - call pbuf_get_field(pbuf, mu_idx, mu_grid) - call pbuf_get_field(pbuf, lambdac_idx, lambdac_grid) - call pbuf_get_field(pbuf, des_idx, des_grid) - call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc_grid) - call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw_grid) - call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc_grid) - call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw_grid) - call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq_grid) - call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice_grid) - call pbuf_get_field(pbuf, iciwpst_idx, iciwpst_grid) - call pbuf_get_field(pbuf, iclwpst_idx, iclwpst_grid) - call pbuf_get_field(pbuf, icswp_idx, icswp_grid) - call pbuf_get_field(pbuf, rel_idx, rel_grid) - call pbuf_get_field(pbuf, rei_idx, rei_grid) - call pbuf_get_field(pbuf, sadice_idx, sadice_grid) - call pbuf_get_field(pbuf, sadsnow_idx, sadsnow_grid) - call pbuf_get_field(pbuf, wsedl_idx, wsedl_grid) - call pbuf_get_field(pbuf, qme_idx, qme_grid) - call pbuf_get_field(pbuf, bergso_idx, bergso_grid) - if (degrau_idx > 0) call pbuf_get_field(pbuf, degrau_idx, degrau_grid) - if (icgrauwp_idx > 0) call pbuf_get_field(pbuf, icgrauwp_idx, icgrauwp_grid) - if (cldfgrau_idx > 0) call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau_grid) - - call pbuf_get_field(pbuf, cldo_idx, cldo_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_t_idx, CC_t_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_qv_idx, CC_qv_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_ql_idx, CC_ql_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_qi_idx, CC_qi_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_nl_idx, CC_nl_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_ni_idx, CC_ni_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - if (rate1_cw2pr_st_idx > 0) then - call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st_grid) - end if - - else - allocate(bergso_grid(pcols,pver), stat=ierr) - call handle_allocate_error(ierr, 'micro_pumas_cam_tend', 'bergso_grid') - bergso_grid(:,:) = 0._r8 - end if - - !----------------------- - ! These are only on the grid regardless of whether subcolumns are turned on or not - call pbuf_get_field(pbuf, ls_reffrain_idx, mgreffrain_grid) - call pbuf_get_field(pbuf, ls_reffsnow_idx, mgreffsnow_grid) - call pbuf_get_field(pbuf, acpr_idx, acprecl_grid) - call pbuf_get_field(pbuf, acgcme_idx, acgcme_grid) - call pbuf_get_field(pbuf, acnum_idx, acnum_grid) - call pbuf_get_field(pbuf, cmeliq_idx, cmeliq_grid) - call pbuf_get_field(pbuf, ast_idx, ast_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - call pbuf_get_field(pbuf, evprain_st_idx, evprain_st_grid) - call pbuf_get_field(pbuf, evpsnow_st_idx, evpsnow_st_grid) - call pbuf_get_field(pbuf, am_evp_st_idx, am_evp_st_grid) - - !----------------------------------------------------------------------- - ! ... Calculate cosine of zenith angle - ! then cast back to angle (radians) - !----------------------------------------------------------------------- - - zen_angle(:) = 0.0_r8 - rlats(:) = 0.0_r8 - rlons(:) = 0.0_r8 - calday = get_curr_calday() - call get_rlat_all_p( lchnk, ncol, rlats ) - call get_rlon_all_p( lchnk, ncol, rlons ) - call zenith( calday, rlats, rlons, zen_angle, ncol ) - where (zen_angle(:) <= 1.0_r8 .and. zen_angle(:) >= -1.0_r8) - zen_angle(:) = acos( zen_angle(:) ) - elsewhere - zen_angle(:) = 0.0_r8 - end where - - sza(:) = zen_angle(:) * rad2deg - call outfld( 'rbSZA', sza, ncol, lchnk ) - - !------------------------------------------------------------------------------------- - ! Microphysics assumes 'liquid stratus frac = ice stratus frac - ! = max( liquid stratus frac, ice stratus frac )'. - alst_mic => ast - aist_mic => ast - - ! Output initial in-cloud LWP (before microphysics) - - iclwpi = 0._r8 - iciwpi = 0._r8 - - do i = 1, ncol - do k = top_lev, pver - iclwpi(i) = iclwpi(i) + & - min(state%q(i,k,ixcldliq) / max(mincld,ast(i,k)),0.005_r8) & - * state%pdel(i,k) / gravit - iciwpi(i) = iciwpi(i) + & - min(state%q(i,k,ixcldice) / max(mincld,ast(i,k)),0.005_r8) & - * state%pdel(i,k) / gravit - end do - end do - - cldo(:ncol,top_lev:pver)=ast(:ncol,top_lev:pver) - - ! Initialize local state from input. - call physics_state_copy(state, state_loc) - - ! Because of the of limited vertical resolution, there can be a signifcant - ! warm bias at the cold point tropopause, which can create a wet bias in the - ! stratosphere. For the microphysics only, update the cold point temperature, with - ! an estimate of the coldest point between the model layers. - if (micro_mg_adjust_cpt) then - cp_rh(:ncol, :pver) = 0._r8 - cp_dt(:ncol) = 0._r8 - cp_dz(:ncol) = 0._r8 - - !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - troplev(:) = 0 - cp_z(:) = 0._r8 - cp_t(:) = 0._r8 - !REMOVECAM_END - call tropopause_find_cam(state_loc, troplev, primary=TROP_ALG_CPP, backup=TROP_ALG_NONE, & - tropZ=cp_z, tropT=cp_t) - - do i = 1, ncol - - ! Update statistics and output results. - if (troplev(i) .ne. NOTFOUND) then - cp_dt(i) = cp_t(i) - state_loc%t(i,troplev(i)) - cp_dz(i) = cp_z(i) - state_loc%zm(i,troplev(i)) - - ! NOTE: This change in temperature is just for the microphysics - ! and should not be added to any tendencies or used to update - ! any states - state_loc%t(i,troplev(i)) = state_loc%t(i,troplev(i)) + cp_dt(i) - end if - end do - - ! Output all of the statistics related to the cold point - ! tropopause adjustment. Th cold point information itself is - ! output in tropopause.F90. - call outfld("TROPF_TADJ", state_loc%t, pcols, lchnk) - call outfld("TROPF_CDT", cp_dt, pcols, lchnk) - call outfld("TROPF_CDZ", cp_dz, pcols, lchnk) - end if - - ! Initialize ptend for output. - lq = .false. - lq(ixq) = .true. - lq(ixcldliq) = .true. - lq(ixcldice) = .true. - lq(ixnumliq) = .true. - lq(ixnumice) = .true. - lq(ixrain) = .true. - lq(ixsnow) = .true. - lq(ixnumrain) = .true. - lq(ixnumsnow) = .true. - if (micro_mg_version > 2) then - lq(ixgraupel) = .true. - lq(ixnumgraupel) = .true. - end if - - ! the name 'cldwat' triggers special tests on cldliq - ! and cldice in physics_update - call physics_ptend_init(ptend, psetcols, "cldwat", ls=.true., lq=lq) - - if (micro_mg_version > 2) then - state_loc_graup(:ncol,:) = state_loc%q(:ncol,:,ixgraupel) - state_loc_numgraup(:ncol,:) = state_loc%q(:ncol,:,ixnumgraupel) - else - state_loc_graup(:ncol,:) = 0._r8 - state_loc_numgraup(:ncol,:) = 0._r8 - end if - - ! Zero out diagnostic rainbow arrays - rbfreq = 0._r8 - rbfrac = 0._r8 - - ! Zero out values above top_lev before passing into _tend for some pbuf variables that are inputs - naai(:ncol,:top_lev-1) = 0._r8 - npccn(:ncol,:top_lev-1) = 0._r8 - - ! The null value for qsatfac is 1, not zero - qsatfac(:ncol,:top_lev-1) = 1._r8 - - ! Zero out values above top_lev for all output variables - ! Note that elements in proc_rates do not have the extra levels as they are dimensioned to be nlev instead of pver - tlat(:ncol,:top_lev-1)=0._r8 - qvlat(:ncol,:top_lev-1)=0._r8 - qcten(:ncol,:top_lev-1)=0._r8 - qiten(:ncol,:top_lev-1)=0._r8 - ncten(:ncol,:top_lev-1)=0._r8 - niten(:ncol,:top_lev-1)=0._r8 - qrten(:ncol,:top_lev-1)=0._r8 - qsten(:ncol,:top_lev-1)=0._r8 - nrten(:ncol,:top_lev-1)=0._r8 - nsten(:ncol,:top_lev-1)=0._r8 - qgten(:ncol,:top_lev-1)=0._r8 - ngten(:ncol,:top_lev-1)=0._r8 - rel(:ncol,:top_lev-1)=0._r8 - rel_fn_dum(:ncol,:top_lev-1)=0._r8 - rei(:ncol,:top_lev-1)=0._r8 - sadice(:ncol,:top_lev-1)=0._r8 - sadsnow(:ncol,:top_lev-1)=0._r8 - prect(:ncol)=0._r8 - preci(:ncol)=0._r8 - nevapr(:ncol,:top_lev-1)=0._r8 - am_evp_st(:ncol,:top_lev-1)=0._r8 - prain(:ncol,:top_lev-1)=0._r8 - cmeice(:ncol,:top_lev-1)=0._r8 - dei(:ncol,:top_lev-1)=0._r8 - mu(:ncol,:top_lev-1)=0._r8 - lambdac(:ncol,:top_lev-1)=0._r8 - qsout(:ncol,:top_lev-1)=0._r8 - des(:ncol,:top_lev-1)=0._r8 - qgout(:ncol,:top_lev-1)=0._r8 - ngout(:ncol,:top_lev-1)=0._r8 - dgout(:ncol,:top_lev-1)=0._r8 - cflx(:ncol,:top_lev-1)=0._r8 - iflx(:ncol,:top_lev-1)=0._r8 - gflx(:ncol,:top_lev-1)=0._r8 - rflx(:ncol,:top_lev-1)=0._r8 - sflx(:ncol,:top_lev-1)=0._r8 - qrout(:ncol,:top_lev-1)=0._r8 - reff_rain_dum(:ncol,:top_lev-1)=0._r8 - reff_snow_dum(:ncol,:top_lev-1)=0._r8 - reff_grau_dum(:ncol,:top_lev-1)=0._r8 - nrout(:ncol,:top_lev-1)=0._r8 - nsout(:ncol,:top_lev-1)=0._r8 - refl(:ncol,:top_lev-1)=0._r8 - arefl(:ncol,:top_lev-1)=0._r8 - areflz(:ncol,:top_lev-1)=0._r8 - frefl(:ncol,:top_lev-1)=0._r8 - csrfl(:ncol,:top_lev-1)=0._r8 - acsrfl(:ncol,:top_lev-1)=0._r8 - fcsrfl(:ncol,:top_lev-1)=0._r8 - refl10cm(:ncol,:top_lev-1)=-9999._r8 - reflz10cm(:ncol,:top_lev-1)=0._r8 - rercld(:ncol,:top_lev-1)=0._r8 - ncai(:ncol,:top_lev-1)=0._r8 - ncal(:ncol,:top_lev-1)=0._r8 - qrout2(:ncol,:top_lev-1)=0._r8 - qsout2(:ncol,:top_lev-1)=0._r8 - nrout2(:ncol,:top_lev-1)=0._r8 - nsout2(:ncol,:top_lev-1)=0._r8 - qgout2(:ncol,:top_lev-1)=0._r8 - ngout2(:ncol,:top_lev-1)=0._r8 - dgout2(:ncol,:top_lev-1)=0._r8 - freqg(:ncol,:top_lev-1)=0._r8 - freqs(:ncol,:top_lev-1)=0._r8 - freqr(:ncol,:top_lev-1)=0._r8 - nfice(:ncol,:top_lev-1)=0._r8 - qcrat(:ncol,:top_lev-1)=0._r8 - tnd_qsnow(:ncol,:top_lev-1)=0._r8 - tnd_nsnow(:ncol,:top_lev-1)=0._r8 - re_ice(:ncol,:top_lev-1)=0._r8 - prer_evap(:ncol,:top_lev-1)=0._r8 - frzimm(:ncol,:top_lev-1)=0._r8 - frzcnt(:ncol,:top_lev-1)=0._r8 - frzdep(:ncol,:top_lev-1)=0._r8 - - !Determine number of dust size bins: - num_dust_bins = size(rndst, dim=3) - - do it = 1, num_steps - - call micro_pumas_ccpp_run( & - ncol, nlev, nlev+1, num_dust_bins, dtime/num_steps, & - state_loc%t(:ncol,top_lev:), state_loc%q(:ncol,top_lev:,ixq), & - state_loc%q(:ncol,top_lev:,ixcldliq), state_loc%q(:ncol,top_lev:,ixcldice), & - state_loc%q(:ncol,top_lev:,ixnumliq), state_loc%q(:ncol,top_lev:,ixnumice), & - state_loc%q(:ncol,top_lev:,ixrain), state_loc%q(:ncol,top_lev:,ixsnow), & - state_loc%q(:ncol,top_lev:,ixnumrain), state_loc%q(:ncol,top_lev:,ixnumsnow), & - state_loc_graup(:ncol,top_lev:), state_loc_numgraup(:ncol,top_lev:), & - relvar(:ncol,top_lev:), accre_enhan(:ncol,top_lev:), & - state_loc%pmid(:ncol,top_lev:), state_loc%pdel(:ncol,top_lev:), & - state_loc%pint(:ncol,top_lev:), & - ast(:ncol,top_lev:), alst_mic(:ncol,top_lev:), & - aist_mic(:ncol,top_lev:), qsatfac(:ncol,top_lev:), & - naai(:ncol,top_lev:), npccn(:ncol,top_lev:), & - rndst(:ncol,top_lev:,:), nacon(:ncol,top_lev:,:), & - tnd_qsnow(:ncol,top_lev:), tnd_nsnow(:ncol,top_lev:), & - re_ice(:ncol,top_lev:), & - frzimm(:ncol,top_lev:), frzcnt(:ncol,top_lev:), & - frzdep(:ncol,top_lev:), rate1cld(:ncol,top_lev:), & - tlat(:ncol,top_lev:), qvlat(:ncol,top_lev:), & - qcten(:ncol,top_lev:), qiten(:ncol,top_lev:), & - ncten(:ncol,top_lev:), niten(:ncol,top_lev:), & - qrten(:ncol,top_lev:), qsten(:ncol,top_lev:), & - nrten(:ncol,top_lev:), nsten(:ncol,top_lev:), & - qgten(:ncol,top_lev:), ngten(:ncol,top_lev:), & - rel(:ncol,top_lev:), rel_fn_dum(:ncol,top_lev:), & - rei(:ncol,top_lev:), & - sadice(:ncol,top_lev:), sadsnow(:ncol,top_lev:), & - prect(:ncol), preci(:ncol), & - nevapr(:ncol,top_lev:), am_evp_st(:ncol,top_lev:), & - prain(:ncol,top_lev:), & - cmeice(:ncol,top_lev:), dei(:ncol,top_lev:), & - mu(:ncol,top_lev:), lambdac(:ncol,top_lev:), & - qsout(:ncol,top_lev:), des(:ncol,top_lev:), & - qgout(:ncol,top_lev:), ngout(:ncol,top_lev:), & - dgout(:ncol,top_lev:), & - cflx(:ncol,top_lev:), iflx(:ncol,top_lev:), & - gflx(:ncol,top_lev:), & - rflx(:ncol,top_lev:), sflx(:ncol,top_lev:), & - qrout(:ncol,top_lev:), reff_rain_dum(:ncol,top_lev:), & - reff_snow_dum(:ncol,top_lev:), reff_grau_dum(:ncol,top_lev:), & - nrout(:ncol,top_lev:), nsout(:ncol,top_lev:), & - refl(:ncol,top_lev:), arefl(:ncol,top_lev:), & - areflz(:ncol,top_lev:), frefl(:ncol,top_lev:), & - csrfl(:ncol,top_lev:), acsrfl(:ncol,top_lev:), & - fcsrfl(:ncol,top_lev:), refl10cm(:ncol,top_lev:), & - reflz10cm(:ncol,top_lev:), rercld(:ncol,top_lev:), & - ncai(:ncol,top_lev:), ncal(:ncol,top_lev:), & - qrout2(:ncol,top_lev:), qsout2(:ncol,top_lev:), & - nrout2(:ncol,top_lev:), nsout2(:ncol,top_lev:), & - drout_dum(:ncol,top_lev:), dsout2_dum(:ncol,top_lev:), & - qgout2(:ncol,top_lev:), ngout2(:ncol,top_lev:), & - dgout2(:ncol,top_lev:), freqg(:ncol,top_lev:), & - freqs(:ncol,top_lev:), freqr(:ncol,top_lev:), & - nfice(:ncol,top_lev:), qcrat(:ncol,top_lev:), & - prer_evap(:ncol,top_lev:), proc_rates, & - ccpp_errmsg, ierr ) - - call handle_errmsg(ccpp_errmsg, subname="micro_pumas_cam_tend") - - call physics_ptend_init(ptend_loc, psetcols, "micro_pumas", & - ls=.true., lq=lq) - - ! Set local tendency. - ptend_loc%s(:ncol,top_lev:) = tlat(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixq) = qvlat(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixcldliq) = qcten(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixcldice) = qiten(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixnumliq) = ncten(:ncol,top_lev:) - - if (do_cldice) then - ptend_loc%q(:ncol,top_lev:,ixnumice) = niten(:ncol,top_lev:) - else - ! In this case, the tendency should be all 0. - if (any(niten(:ncol,:) /= 0._r8)) then - call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & - " but micro_pumas_tend has ice number tendencies.") - end if - ptend_loc%q(:ncol,:,ixnumice) = 0._r8 - end if - - ptend_loc%q(:ncol,top_lev:,ixrain) = qrten(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixsnow) = qsten(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixnumrain) = nrten(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixnumsnow) = nsten(:ncol,top_lev:) - - if (micro_mg_version > 2) then - ptend_loc%q(:ncol,top_lev:,ixgraupel) = qgten(:ncol,top_lev:) - ptend_loc%q(:ncol,top_lev:,ixnumgraupel) = ngten(:ncol,top_lev:) - end if - - ! Sum into overall ptend - call physics_ptend_sum(ptend_loc, ptend, ncol) - - ! Update local state - call physics_update(state_loc, ptend_loc, dtime/num_steps) - - if (trim(micro_mg_warm_rain) == 'tau') then - proc_rates%amk_c(:ncol,:,:) = proc_rates%amk_c(:ncol,:,:)/num_steps - proc_rates%ank_c(:ncol,:,:) = proc_rates%ank_c(:ncol,:,:)/num_steps - proc_rates%amk_r(:ncol,:,:) = proc_rates%amk_r(:ncol,:,:)/num_steps - proc_rates%ank_r(:ncol,:,:) = proc_rates%ank_r(:ncol,:,:)/num_steps - proc_rates%amk(:ncol,:,:) = proc_rates%amk(:ncol,:,:)/num_steps - proc_rates%ank(:ncol,:,:) = proc_rates%ank(:ncol,:,:)/num_steps - proc_rates%amk_out(:ncol,:,:) = proc_rates%amk_out(:ncol,:,:)/num_steps - end if - - end do - - ! Divide ptend by substeps. - call physics_ptend_scale(ptend, 1._r8/num_steps, ncol) - - ! Check to make sure that the microphysics code is respecting the flags that control - ! whether MG should be prognosing cloud ice and cloud liquid or not. - if (.not. do_cldice) then - if (any(ptend%q(:ncol,top_lev:pver,ixcldice) /= 0.0_r8)) & - call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & - " but micro_pumas_tend has ice mass tendencies.") - if (any(ptend%q(:ncol,top_lev:pver,ixnumice) /= 0.0_r8)) & - call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & - " but micro_pumas_tend has ice number tendencies.") - end if - if (.not. do_cldliq) then - if (any(ptend%q(:ncol,top_lev:pver,ixcldliq) /= 0.0_r8)) & - call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & - " but micro_pumas_tend has liquid mass tendencies.") - if (any(ptend%q(:ncol,top_lev:pver,ixnumliq) /= 0.0_r8)) & - call endrun("micro_pumas_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & - " but micro_pumas_tend has liquid number tendencies.") - end if - - mnuccdohet = 0._r8 - do k=top_lev,pver - do i=1,ncol - if (naai(i,k) > 0._r8) then - mnuccdohet(i,k) = proc_rates%mnuccdtot(i,k-top_lev+1) - (naai_hom(i,k)/naai(i,k))*proc_rates%mnuccdtot(i,k-top_lev+1) - end if - end do - end do - - mgflxprc(:ncol,top_lev:pverp) = rflx(:ncol,top_lev:pverp) + sflx(:ncol,top_lev:pverp) - mgflxsnw(:ncol,top_lev:pverp) = sflx(:ncol,top_lev:pverp) - - !add condensate fluxes for MG2 (ice and snow already added for MG1) - if (micro_mg_version >= 2) then - mgflxprc(:ncol,top_lev:pverp) = mgflxprc(:ncol,top_lev:pverp)+ iflx(:ncol,top_lev:pverp) + cflx(:ncol,top_lev:pverp) - mgflxsnw(:ncol,top_lev:pverp) = mgflxsnw(:ncol,top_lev:pverp) + iflx(:ncol,top_lev:pverp) - end if - - !add graupel fluxes for MG3 to snow flux - if (micro_mg_version >= 3) then - mgflxprc(:ncol,top_lev:pverp) = mgflxprc(:ncol,top_lev:pverp)+gflx(:ncol,top_lev:pverp) - mgflxsnw(:ncol,top_lev:pverp) = mgflxsnw(:ncol,top_lev:pverp)+gflx(:ncol,top_lev:pverp) - end if - - mgmrprc(:ncol,top_lev:pver) = qrout(:ncol,top_lev:pver) + qsout(:ncol,top_lev:pver) - mgmrsnw(:ncol,top_lev:pver) = qsout(:ncol,top_lev:pver) - - !! calculate effective radius of convective liquid and ice using dcon and deicon (not used by code, not useful for COSP) - !! hard-coded as average of hard-coded values used for deep/shallow convective detrainment (near line 1502/1505) - cvreffliq(:ncol,top_lev:pver) = 9.0_r8 - cvreffice(:ncol,top_lev:pver) = 37.0_r8 - - ! Reassign rate1 if modal aerosols - if (rate1_cw2pr_st_idx > 0) then - rate1ord_cw2pr_st(:ncol,top_lev:pver) = rate1cld(:ncol,top_lev:pver) - end if - - ! Sedimentation velocity for liquid stratus cloud droplet - wsedl(:ncol,top_lev:pver) = proc_rates%vtrmc(:ncol,1:nlev) - - ! Microphysical tendencies for use in the macrophysics at the next time step - CC_T(:ncol,top_lev:pver) = tlat(:ncol,top_lev:pver)/cpair - CC_qv(:ncol,top_lev:pver) = qvlat(:ncol,top_lev:pver) - CC_ql(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver) - CC_qi(:ncol,top_lev:pver) = qiten(:ncol,top_lev:pver) - CC_nl(:ncol,top_lev:pver) = ncten(:ncol,top_lev:pver) - CC_ni(:ncol,top_lev:pver) = niten(:ncol,top_lev:pver) - CC_qlst(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver)/max(0.01_r8,alst_mic(:ncol,top_lev:pver)) - - ! Net micro_pumas_cam condensation rate - qme(:ncol,:top_lev-1) = 0._r8 - qme(:ncol,top_lev:pver) = cmeliq(:ncol,top_lev:pver) + proc_rates%cmeitot(:ncol,1:nlev) - - ! For precip, accumulate only total precip in prec_pcw and snow_pcw variables. - ! Other precip output variables are set to 0 - ! Do not subscript by ncol here, because in physpkg we divide the whole - ! array and need to avoid an FPE due to uninitialized data. - prec_pcw = prect - snow_pcw = preci - prec_sed = 0._r8 - snow_sed = 0._r8 - prec_str = prec_pcw + prec_sed - snow_str = snow_pcw + snow_sed - - icecldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) - liqcldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) - - ! ------------------------------------------------------------ ! - ! Compute in cloud ice and liquid mixing ratios ! - ! Note that 'iclwp, iciwp' are used for radiation computation. ! - ! ------------------------------------------------------------ ! - - icinc = 0._r8 - icwnc = 0._r8 - iciwpst = 0._r8 - iclwpst = 0._r8 - icswp = 0._r8 - cldfsnow = 0._r8 - if (micro_mg_version > 2) then - icgrauwp = 0._r8 - cldfgrau = 0._r8 - end if - - do k = top_lev, pver - do i = 1, ncol - ! Limits for in-cloud mixing ratios consistent with MG microphysics - ! in-cloud mixing ratio maximum limit of 0.005 kg/kg - icimrst(i,k) = min( state_loc%q(i,k,ixcldice) / max(mincld,icecldf(i,k)),0.005_r8 ) - icwmrst(i,k) = min( state_loc%q(i,k,ixcldliq) / max(mincld,liqcldf(i,k)),0.005_r8 ) - icinc(i,k) = state_loc%q(i,k,ixnumice) / max(mincld,icecldf(i,k)) * & - state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) - icwnc(i,k) = state_loc%q(i,k,ixnumliq) / max(mincld,liqcldf(i,k)) * & - state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) - ! Calculate micro_pumas_cam cloud water paths in each layer - ! Note: uses stratiform cloud fraction! - iciwpst(i,k) = min(state_loc%q(i,k,ixcldice)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit - iclwpst(i,k) = min(state_loc%q(i,k,ixcldliq)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit - - ! ------------------------------ ! - ! Adjust cloud fraction for snow ! - ! ------------------------------ ! - cldfsnow(i,k) = cld(i,k) - ! If cloud and only ice ( no convective cloud or ice ), then set to 0. - if( ( cldfsnow(i,k) .gt. 1.e-4_r8 ) .and. & - ( concld(i,k) .lt. 1.e-4_r8 ) .and. & - ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then - cldfsnow(i,k) = 0._r8 - end if - ! If no cloud and snow, then set to 0.25 - if( ( cldfsnow(i,k) .le. 1.e-4_r8 ) .and. ( qsout(i,k) .gt. 1.e-6_r8 ) ) then - cldfsnow(i,k) = 0.25_r8 - end if - ! Calculate in-cloud snow water path - icswp(i,k) = qsout(i,k) / max( mincld, cldfsnow(i,k) ) * state_loc%pdel(i,k) / gravit - - ! --------------------------------- ! - ! Adjust cloud fraction for graupel ! - ! --------------------------------- ! - if (micro_mg_version > 2) then - cldfgrau(i,k) = cld(i,k) - ! If cloud and only ice ( no convective cloud or ice ), then set to 0. - if( ( cldfgrau(i,k) .gt. 1.e-4_r8 ) .and. & - ( concld(i,k) .lt. 1.e-4_r8 ) .and. & - ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then - cldfgrau(i,k) = 0._r8 - end if - ! If no cloud and graupel, then set to 0.25 - if( ( cldfgrau(i,k) .le. 1.e-4_r8 ) .and. ( qgout(i,k) .gt. 1.e-9_r8 ) ) then - cldfgrau(i,k) = 0.25_r8 - end if - - ! Calculate in-cloud snow water path - icgrauwp(i,k) = qgout(i,k) / max( 1.e-2_r8, cldfgrau(i,k) ) * state_loc%pdel(i,k) / gravit - end if - - end do - end do - - ! Calculate cloud fraction for prognostic precip sizes. - ! Cloud fraction for purposes of precipitation is maximum cloud - ! fraction out of all the layers that the precipitation may be - ! falling down from. - cldmax(:ncol,top_lev:) = max(mincld, ast(:ncol,top_lev:)) - do k = top_lev+1, pver - where (state_loc%q(:ncol,k-1,ixrain) >= qsmall .or. & - state_loc%q(:ncol,k-1,ixsnow) >= qsmall) - cldmax(:ncol,k) = max(cldmax(:ncol,k-1), cldmax(:ncol,k)) - end where - end do - - !Copy pbuf field from proc_rates back to pbuf pointer - bergstot(:ncol,top_lev:) = proc_rates%bergstot(:ncol,1:nlev) - bergstot(:ncol,1:top_lev-1) = 0._r8 - - ! ------------------------------------------------------ ! - ! ------------------------------------------------------ ! - ! All code from here to the end is on grid columns only ! - ! ------------------------------------------------------ ! - ! ------------------------------------------------------ ! - - ! Average the fields which are needed later in this paramterization to be on the grid - if (use_subcol_microp) then - call subcol_field_avg(prec_str, ngrdcol, lchnk, prec_str_grid) - call subcol_field_avg(iclwpst, ngrdcol, lchnk, iclwpst_grid) - call subcol_field_avg(cvreffliq, ngrdcol, lchnk, cvreffliq_grid) - call subcol_field_avg(cvreffice, ngrdcol, lchnk, cvreffice_grid) - call subcol_field_avg(mgflxprc, ngrdcol, lchnk, mgflxprc_grid) - call subcol_field_avg(mgflxsnw, ngrdcol, lchnk, mgflxsnw_grid) - call subcol_field_avg(qme, ngrdcol, lchnk, qme_grid) - call subcol_field_avg(nevapr, ngrdcol, lchnk, nevapr_grid) - call subcol_field_avg(prain, ngrdcol, lchnk, prain_grid) - - evapsnow_sc(:ncol,:) = proc_rates%evapsnow(:ncol,1:nlev) - call subcol_field_avg(evapsnow_sc, ngrdcol, lchnk, evpsnow_st_grid(:,top_lev:)) - bergstot_sc(:ncol,:) = proc_rates%bergstot(:ncol,1:nlev) - call subcol_field_avg(bergstot_sc, ngrdcol, lchnk, bergso_grid(:,top_lev:)) - - call subcol_field_avg(am_evp_st, ngrdcol, lchnk, am_evp_st_grid) - - ! Average fields which are not in pbuf - call subcol_field_avg(qrout, ngrdcol, lchnk, qrout_grid) - call subcol_field_avg(qsout, ngrdcol, lchnk, qsout_grid) - call subcol_field_avg(nsout, ngrdcol, lchnk, nsout_grid) - call subcol_field_avg(nrout, ngrdcol, lchnk, nrout_grid) - call subcol_field_avg(cld, ngrdcol, lchnk, cld_grid) - - qcrestot_sc(:ncol,:) = proc_rates%qcrestot(:ncol,1:nlev) - call subcol_field_avg(qcrestot_sc, ngrdcol, lchnk, qcreso_grid(:,top_lev:)) - melttot_sc(:ncol,:) = proc_rates%melttot(:ncol,1:nlev) - call subcol_field_avg(melttot_sc, ngrdcol, lchnk, melto_grid(:,top_lev:)) - mnuccctot_sc(:ncol,:) = proc_rates%mnuccctot(:ncol,1:nlev) - call subcol_field_avg(mnuccctot_sc, ngrdcol, lchnk, mnuccco_grid(:,top_lev:)) - mnuccttot_sc(:ncol,:) = proc_rates%mnuccttot(:ncol,1:nlev) - call subcol_field_avg(mnuccttot_sc, ngrdcol, lchnk, mnuccto_grid(:,top_lev:)) - bergtot_sc(:ncol,:) = proc_rates%bergtot(:ncol,1:nlev) - call subcol_field_avg(bergtot_sc, ngrdcol, lchnk, bergo_grid(:,top_lev:)) - homotot_sc(:ncol,:) = proc_rates%homotot(:ncol,1:nlev) - call subcol_field_avg(homotot_sc, ngrdcol, lchnk, homoo_grid(:,top_lev:)) - msacwitot_sc(:ncol,:) = proc_rates%msacwitot(:ncol,1:nlev) - call subcol_field_avg(msacwitot_sc, ngrdcol, lchnk, msacwio_grid(:,top_lev:)) - psacwstot_sc(:ncol,:) = proc_rates%psacwstot(:ncol,1:nlev) - call subcol_field_avg(psacwstot_sc, ngrdcol, lchnk, psacwso_grid(:,top_lev:)) - cmeitot_sc(:ncol,:) = proc_rates%cmeitot(:ncol,1:nlev) - call subcol_field_avg(cmeitot_sc, ngrdcol, lchnk, cmeiout_grid(:,top_lev:)) - qirestot_sc(:ncol,:) = proc_rates%qirestot(:ncol,1:nlev) - call subcol_field_avg(qirestot_sc, ngrdcol, lchnk, qireso_grid(:,top_lev:)) - prcitot_sc(:ncol,:) = proc_rates%prcitot(:ncol,1:nlev) - call subcol_field_avg(prcitot_sc, ngrdcol, lchnk, prcio_grid(:,top_lev:)) - praitot_sc(:ncol,:) = proc_rates%praitot(:ncol,1:nlev) - call subcol_field_avg(praitot_sc, ngrdcol, lchnk, praio_grid(:,top_lev:)) - - call subcol_field_avg(icwmrst, ngrdcol, lchnk, icwmrst_grid) - call subcol_field_avg(icimrst, ngrdcol, lchnk, icimrst_grid) - call subcol_field_avg(liqcldf, ngrdcol, lchnk, liqcldf_grid) - call subcol_field_avg(icecldf, ngrdcol, lchnk, icecldf_grid) - call subcol_field_avg(icwnc, ngrdcol, lchnk, icwnc_grid) - call subcol_field_avg(icinc, ngrdcol, lchnk, icinc_grid) - call subcol_field_avg(state_loc%pdel, ngrdcol, lchnk, pdel_grid) - - pratot_sc(:ncol,:) = proc_rates%pratot(:ncol,1:nlev) - call subcol_field_avg(pratot_sc, ngrdcol, lchnk, prao_grid(:,top_lev:)) - prctot_sc(:ncol,:) = proc_rates%prctot(:ncol,1:nlev) - call subcol_field_avg(prctot_sc, ngrdcol, lchnk, prco_grid(:,top_lev:)) - - call subcol_field_avg(state_loc%q(:,:,ixnumliq), ngrdcol, lchnk, nc_grid(:,top_lev:)) - call subcol_field_avg(state_loc%q(:,:,ixnumice), ngrdcol, lchnk, ni_grid(:,top_lev:)) - - qcsedten_sc(:ncol,:) = proc_rates%qcsedten(:ncol,1:nlev) - call subcol_field_avg(qcsedten_sc, ngrdcol, lchnk, qcsedtenout_grid(:,top_lev:)) - qisedten_sc(:ncol,:) = proc_rates%qisedten(:ncol,1:nlev) - call subcol_field_avg(qisedten_sc, ngrdcol, lchnk, qisedtenout_grid(:,top_lev:)) - vtrmc_sc(:ncol,:) = proc_rates%vtrmc(:ncol,1:nlev) - call subcol_field_avg(vtrmc_sc, ngrdcol, lchnk, vtrmcout_grid(:,top_lev:)) - vtrmi_sc(:ncol,:) = proc_rates%vtrmi(:ncol,1:nlev) - call subcol_field_avg(vtrmi_sc, ngrdcol, lchnk, vtrmiout_grid(:,top_lev:)) - qcsevap_sc(:ncol,:) = proc_rates%qcsevap(:ncol,1:nlev) - call subcol_field_avg(qcsevap_sc, ngrdcol, lchnk, qcsevapout_grid(:,top_lev:)) - qisevap_sc(:ncol,:) = proc_rates%qisevap(:ncol,1:nlev) - call subcol_field_avg(qisevap_sc, ngrdcol, lchnk, qisevapout_grid(:,top_lev:)) - - call subcol_field_avg(cldmax, ngrdcol, lchnk, cldmax_grid) - - call subcol_field_avg(state_loc%q(:,:,ixrain), ngrdcol, lchnk, qr_grid) - call subcol_field_avg(state_loc%q(:,:,ixnumrain), ngrdcol, lchnk, nr_grid) - call subcol_field_avg(state_loc%q(:,:,ixsnow), ngrdcol, lchnk, qs_grid) - call subcol_field_avg(state_loc%q(:,:,ixnumsnow), ngrdcol, lchnk, ns_grid) - - qrsedten_sc(:ncol,:) = proc_rates%qrsedten(:ncol,1:nlev) - call subcol_field_avg(qrsedten_sc, ngrdcol, lchnk, qrsedtenout_grid(:,top_lev:)) - qssedten_sc(:ncol,:) = proc_rates%qssedten(:ncol,1:nlev) - call subcol_field_avg(qssedten_sc, ngrdcol, lchnk, qssedtenout_grid(:,top_lev:)) - umr_sc(:ncol,:) = proc_rates%umr(:ncol,1:nlev) - call subcol_field_avg(umr_sc, ngrdcol, lchnk, umrout_grid(:,top_lev:)) - ums_sc(:ncol,:) = proc_rates%ums(:ncol,1:nlev) - call subcol_field_avg(ums_sc, ngrdcol, lchnk, umsout_grid(:,top_lev:)) - - if (micro_mg_version > 2) then - call subcol_field_avg(state_loc%q(:,:,ixgraupel), ngrdcol, lchnk, qg_grid) - call subcol_field_avg(state_loc%q(:,:,ixnumgraupel), ngrdcol, lchnk, ng_grid) - - psacrtot_sc(:ncol,:) = proc_rates%psacrtot(:ncol,1:nlev) - call subcol_field_avg(psacrtot_sc, ngrdcol, lchnk, psacro_grid(:,top_lev:)) - pracgtot_sc(:ncol,:) = proc_rates%pracgtot(:ncol,1:nlev) - call subcol_field_avg(pracgtot_sc, ngrdcol, lchnk, pracgo_grid(:,top_lev:)) - psacwgtot_sc(:ncol,:) = proc_rates%psacwgtot(:ncol,1:nlev) - call subcol_field_avg(psacwgtot_sc, ngrdcol, lchnk, psacwgo_grid(:,top_lev:)) - pgsacwtot_sc(:ncol,:) = proc_rates%pgsacwtot(:ncol,1:nlev) - call subcol_field_avg(pgsacwtot_sc, ngrdcol, lchnk, pgsacwo_grid(:,top_lev:)) - pgracstot_sc(:ncol,:) = proc_rates%pgracstot(:ncol,1:nlev) - call subcol_field_avg(pgracstot_sc, ngrdcol, lchnk, pgracso_grid(:,top_lev:)) - prdgtot_sc(:ncol,:) = proc_rates%prdgtot(:ncol,1:nlev) - call subcol_field_avg(prdgtot_sc, ngrdcol, lchnk, prdgo_grid(:,top_lev:)) - qmultgtot_sc(:ncol,:) = proc_rates%qmultgtot(:ncol,1:nlev) - call subcol_field_avg(qmultgtot_sc, ngrdcol, lchnk, qmultgo_grid(:,top_lev:)) - qmultrgtot_sc(:ncol,:) = proc_rates%qmultrgtot(:ncol,1:nlev) - call subcol_field_avg(qmultrgtot_sc, ngrdcol, lchnk, qmultrgo_grid(:,top_lev:)) - npracgtot_sc(:ncol,:) = proc_rates%npracgtot(:ncol,1:nlev) - call subcol_field_avg(npracgtot_sc, ngrdcol, lchnk, npracgo_grid(:,top_lev:)) - nscngtot_sc(:ncol,:) = proc_rates%nscngtot(:ncol,1:nlev) - call subcol_field_avg(nscngtot_sc, ngrdcol, lchnk, nscngo_grid(:,top_lev:)) - ngracstot_sc(:ncol,:) = proc_rates%ngracstot(:ncol,1:nlev) - call subcol_field_avg(ngracstot_sc, ngrdcol, lchnk, ngracso_grid(:,top_lev:)) - nmultgtot_sc(:ncol,:) = proc_rates%nmultgtot(:ncol,1:nlev) - call subcol_field_avg(nmultgtot_sc, ngrdcol, lchnk, nmultgo_grid(:,top_lev:)) - nmultrgtot_sc(:ncol,:) = proc_rates%nmultrgtot(:ncol,1:nlev) - call subcol_field_avg(nmultrgtot_sc, ngrdcol, lchnk, nmultrgo_grid(:,top_lev:)) - npsacwgtot_sc(:ncol,:) = proc_rates%npsacwgtot(:ncol,1:nlev) - call subcol_field_avg(npsacwgtot_sc, ngrdcol, lchnk, npsacwgo_grid(:,top_lev:)) - end if - - else - qcreso_grid(:ncol,:top_lev-1) = 0._r8 - melto_grid(:ncol,:top_lev-1) = 0._r8 - mnuccco_grid(:ncol,:top_lev-1) = 0._r8 - mnuccto_grid(:ncol,:top_lev-1) = 0._r8 - bergo_grid(:ncol,:top_lev-1) = 0._r8 - homoo_grid(:ncol,:top_lev-1) = 0._r8 - msacwio_grid(:ncol,:top_lev-1) = 0._r8 - psacwso_grid(:ncol,:top_lev-1) = 0._r8 - cmeiout_grid(:ncol,:top_lev-1) = 0._r8 - qireso_grid(:ncol,:top_lev-1) = 0._r8 - prcio_grid(:ncol,:top_lev-1) = 0._r8 - praio_grid(:ncol,:top_lev-1) = 0._r8 - prao_grid(:ncol,:top_lev-1) = 0._r8 - prco_grid(:ncol,:top_lev-1) = 0._r8 - qcsedtenout_grid(:ncol,:top_lev-1) = 0._r8 - qisedtenout_grid(:ncol,:top_lev-1) = 0._r8 - vtrmcout_grid(:ncol,:top_lev-1) = 0._r8 - vtrmiout_grid(:ncol,:top_lev-1) = 0._r8 - qcsevapout_grid(:ncol,:top_lev-1) = 0._r8 - qisevapout_grid(:ncol,:top_lev-1) = 0._r8 - qrsedtenout_grid(:ncol,:top_lev-1) = 0._r8 - qssedtenout_grid(:ncol,:top_lev-1) = 0._r8 - qgsedtenout_grid(:ncol,:top_lev-1) = 0._r8 !+tht - umrout_grid(:ncol,:top_lev-1) = 0._r8 - umsout_grid(:ncol,:top_lev-1) = 0._r8 - psacro_grid(:ncol,:top_lev-1) = 0._r8 - pracgo_grid(:ncol,:top_lev-1) = 0._r8 - psacwgo_grid(:ncol,:top_lev-1) = 0._r8 - pgsacwo_grid(:ncol,:top_lev-1) = 0._r8 - pgracso_grid(:ncol,:top_lev-1) = 0._r8 - prdgo_grid(:ncol,:top_lev-1) = 0._r8 - qmultgo_grid(:ncol,:top_lev-1) = 0._r8 - qmultrgo_grid(:ncol,:top_lev-1) = 0._r8 - npracgo_grid(:ncol,:top_lev-1) = 0._r8 - nscngo_grid(:ncol,:top_lev-1) = 0._r8 - ngracso_grid(:ncol,:top_lev-1) = 0._r8 - nmultgo_grid(:ncol,:top_lev-1) = 0._r8 - nmultrgo_grid(:ncol,:top_lev-1) = 0._r8 - npsacwgo_grid(:ncol,:top_lev-1) = 0._r8 - bergso_grid(:ncol,:top_lev-1) = 0._r8 - - ! These pbuf fields need to be assigned. There is no corresponding subcol_field_avg - ! as they are reset before being used, so it would be a needless calculation - lambdac_grid => lambdac - mu_grid => mu - rel_grid => rel - rei_grid => rei - sadice_grid => sadice - sadsnow_grid => sadsnow - dei_grid => dei - des_grid => des - degrau_grid => degrau - - ! fields already on grids, so just assign - prec_str_grid => prec_str - iclwpst_grid => iclwpst - cvreffliq_grid => cvreffliq - cvreffice_grid => cvreffice - mgflxprc_grid => mgflxprc - mgflxsnw_grid => mgflxsnw - qme_grid => qme - nevapr_grid => nevapr - prain_grid => prain - - bergso_grid(:ncol,top_lev:) = proc_rates%bergstot - am_evp_st_grid = am_evp_st - - evpsnow_st_grid(:ncol,top_lev:) = proc_rates%evapsnow - qrout_grid = qrout - qsout_grid = qsout - nsout_grid = nsout - nrout_grid = nrout - cld_grid = cld - qcreso_grid(:ncol,top_lev:) = proc_rates%qcrestot - melto_grid(:ncol,top_lev:) = proc_rates%melttot - mnuccco_grid(:ncol,top_lev:) = proc_rates%mnuccctot - mnuccto_grid(:ncol,top_lev:) = proc_rates%mnuccttot - bergo_grid(:ncol,top_lev:) = proc_rates%bergtot - homoo_grid(:ncol,top_lev:) = proc_rates%homotot - msacwio_grid(:ncol,top_lev:) = proc_rates%msacwitot - psacwso_grid(:ncol,top_lev:) = proc_rates%psacwstot - cmeiout_grid(:ncol,top_lev:) = proc_rates%cmeitot - qireso_grid(:ncol,top_lev:) = proc_rates%qirestot - prcio_grid(:ncol,top_lev:) = proc_rates%prcitot - praio_grid(:ncol,top_lev:) = proc_rates%praitot - icwmrst_grid = icwmrst - icimrst_grid = icimrst - liqcldf_grid = liqcldf - icecldf_grid = icecldf - icwnc_grid = icwnc - icinc_grid = icinc - pdel_grid = state_loc%pdel - prao_grid(:ncol,top_lev:) = proc_rates%pratot - prco_grid(:ncol,top_lev:) = proc_rates%prctot - - nc_grid = state_loc%q(:,:,ixnumliq) - ni_grid = state_loc%q(:,:,ixnumice) - - qcsedtenout_grid(:ncol,top_lev:) = proc_rates%qcsedten - qisedtenout_grid(:ncol,top_lev:) = proc_rates%qisedten - vtrmcout_grid(:ncol,top_lev:) = proc_rates%vtrmc - vtrmiout_grid(:ncol,top_lev:) = proc_rates%vtrmi - qcsevapout_grid(:ncol,top_lev:) = proc_rates%qcsevap - qisevapout_grid(:ncol,top_lev:) = proc_rates%qisevap - - cldmax_grid = cldmax - - qr_grid = state_loc%q(:,:,ixrain) - nr_grid = state_loc%q(:,:,ixnumrain) - qs_grid = state_loc%q(:,:,ixsnow) - ns_grid = state_loc%q(:,:,ixnumsnow) - qrsedtenout_grid(:ncol,top_lev:) = proc_rates%qrsedten - qssedtenout_grid(:ncol,top_lev:) = proc_rates%qssedten - qgsedtenout_grid(:ncol,top_lev:) = proc_rates%qgsedten !+tht - umrout_grid(:ncol,top_lev:) = proc_rates%umr - umsout_grid(:ncol,top_lev:) = proc_rates%ums - -! Zero out terms for budgets if not mg3.... - psacwgo_grid = 0._r8 - pgsacwo_grid = 0._r8 - qmultgo_grid = 0._r8 - - if (micro_mg_version > 2) then - qg_grid = state_loc%q(:,:,ixgraupel) - ng_grid = state_loc%q(:,:,ixnumgraupel) - psacro_grid(:ncol,top_lev:) = proc_rates%psacrtot - pracgo_grid(:ncol,top_lev:) = proc_rates%pracgtot - psacwgo_grid(:ncol,top_lev:) = proc_rates%psacwgtot - pgsacwo_grid(:ncol,top_lev:) = proc_rates%pgsacwtot - pgracso_grid(:ncol,top_lev:) = proc_rates%pgracstot - prdgo_grid(:ncol,top_lev:) = proc_rates%prdgtot - qmultgo_grid(:ncol,top_lev:) = proc_rates%qmultgtot - qmultrgo_grid(:ncol,top_lev:) = proc_rates%qmultrgtot - npracgo_grid(:ncol,top_lev:) = proc_rates%npracgtot - nscngo_grid(:ncol,top_lev:) = proc_rates%nscngtot - ngracso_grid(:ncol,top_lev:) = proc_rates%ngracstot - nmultgo_grid(:ncol,top_lev:) = proc_rates%nmultgtot - nmultrgo_grid(:ncol,top_lev:) = proc_rates%nmultrgtot - npsacwgo_grid(:ncol,top_lev:) = proc_rates%npsacwgtot - end if - - - end if - - ! If on subcolumns, average the rest of the pbuf fields which were modified on subcolumns but are not used further in - ! this parameterization (no need to assign in the non-subcolumn case -- the else step) - if (use_subcol_microp) then - call subcol_field_avg(snow_str, ngrdcol, lchnk, snow_str_grid) - call subcol_field_avg(prec_pcw, ngrdcol, lchnk, prec_pcw_grid) - call subcol_field_avg(snow_pcw, ngrdcol, lchnk, snow_pcw_grid) - call subcol_field_avg(prec_sed, ngrdcol, lchnk, prec_sed_grid) - call subcol_field_avg(snow_sed, ngrdcol, lchnk, snow_sed_grid) - call subcol_field_avg(cldo, ngrdcol, lchnk, cldo_grid) - call subcol_field_avg(mgmrprc, ngrdcol, lchnk, mgmrprc_grid) - call subcol_field_avg(mgmrsnw, ngrdcol, lchnk, mgmrsnw_grid) - call subcol_field_avg(wsedl, ngrdcol, lchnk, wsedl_grid) - call subcol_field_avg(cc_t, ngrdcol, lchnk, cc_t_grid) - call subcol_field_avg(cc_qv, ngrdcol, lchnk, cc_qv_grid) - call subcol_field_avg(cc_ql, ngrdcol, lchnk, cc_ql_grid) - call subcol_field_avg(cc_qi, ngrdcol, lchnk, cc_qi_grid) - call subcol_field_avg(cc_nl, ngrdcol, lchnk, cc_nl_grid) - call subcol_field_avg(cc_ni, ngrdcol, lchnk, cc_ni_grid) - call subcol_field_avg(cc_qlst, ngrdcol, lchnk, cc_qlst_grid) - call subcol_field_avg(iciwpst, ngrdcol, lchnk, iciwpst_grid) - call subcol_field_avg(icswp, ngrdcol, lchnk, icswp_grid) - call subcol_field_avg(cldfsnow, ngrdcol, lchnk, cldfsnow_grid) - - if (micro_mg_version > 2) then - call subcol_field_avg(icgrauwp, ngrdcol, lchnk, icgrauwp_grid) - call subcol_field_avg(cldfgrau, ngrdcol, lchnk, cldfsnow_grid) - end if - - if (rate1_cw2pr_st_idx > 0) then - call subcol_field_avg(rate1ord_cw2pr_st, ngrdcol, lchnk, rate1ord_cw2pr_st_grid) - end if - - end if - - ! ------------------------------------- ! - ! Size distribution calculation ! - ! ------------------------------------- ! - - ! Calculate rho (on subcolumns if turned on) for size distribution - ! parameter calculations and average it if needed - ! - ! State instead of state_loc to preserve answers for MG1 (and in any - ! case, it is unlikely to make much difference). - rho(:ncol,top_lev:) = state%pmid(:ncol,top_lev:) / & - (rair*state%t(:ncol,top_lev:)) - if (use_subcol_microp) then - call subcol_field_avg(rho, ngrdcol, lchnk, rho_grid) - else - rho_grid = rho - end if - - ! Effective radius for cloud liquid, fixed number. - mu_grid = 0._r8 - lambdac_grid = 0._r8 - rel_fn_grid = 10._r8 - - ncic_grid = 1.e8_r8 - - do k = top_lev, pver - !$acc data copyin (mg_liq_props,icwmrst_grid(:ngrdcol,k),rho_grid(:ngrdcol,k)) & - !$acc copy (ncic_grid(:ngrdcol,k)) & - !$acc copyout (mu_grid(:ngrdcol,k),lambdac_grid(:ngrdcol,k)) - call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,k), & - ncic_grid(:ngrdcol,k), rho_grid(:ngrdcol,k), & - mu_grid(:ngrdcol,k), lambdac_grid(:ngrdcol,k), ngrdcol) - !$acc end data - end do - - where (icwmrst_grid(:ngrdcol,top_lev:) > qsmall) - rel_fn_grid(:ngrdcol,top_lev:) = & - (mu_grid(:ngrdcol,top_lev:) + 3._r8)/ & - lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 - end where - - ! Effective radius for cloud liquid, and size parameters - ! mu_grid and lambdac_grid. - mu_grid = 0._r8 - lambdac_grid = 0._r8 - rel_grid = 10._r8 - - ! Calculate ncic on the grid - ncic_grid(:ngrdcol,top_lev:) = nc_grid(:ngrdcol,top_lev:) / & - max(mincld,liqcldf_grid(:ngrdcol,top_lev:)) - - do k = top_lev, pver - !$acc data copyin (mg_liq_props,icwmrst_grid(:ngrdcol,k), rho_grid(:ngrdcol,k)) & - !$acc copy (ncic_grid(:ngrdcol,k)) & - !$acc copyout (mu_grid(:ngrdcol,k),lambdac_grid(:ngrdcol,k)) - call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,k), & - ncic_grid(:ngrdcol,k), rho_grid(:ngrdcol,k), & - mu_grid(:ngrdcol,k), lambdac_grid(:ngrdcol,k), ngrdcol) - !$acc end data - end do - - where (icwmrst_grid(:ngrdcol,top_lev:) >= qsmall) - rel_grid(:ngrdcol,top_lev:) = & - (mu_grid(:ngrdcol,top_lev:) + 3._r8) / & - lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 - elsewhere - ! Deal with the fact that size_dist_param_liq sets mu_grid to -100 - ! wherever there is no cloud. - mu_grid(:ngrdcol,top_lev:) = 0._r8 - end where - - ! Rain/Snow effective diameter. - drout2_grid = 0._r8 - reff_rain_grid = 0._r8 - des_grid = 0._r8 - dsout2_grid = 0._r8 - reff_snow_grid = 0._r8 - reff_grau_grid = 0._r8 - - ! Prognostic precipitation - - where (qr_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) - drout2_grid(:ngrdcol,top_lev:) = avg_diameter( & - qr_grid(:ngrdcol,top_lev:), & - nr_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & - rho_grid(:ngrdcol,top_lev:), rhow) - - reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & - shapeparam * micron2meter - end where - - where (qs_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) - dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( & - qs_grid(:ngrdcol,top_lev:), & - ns_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & - rho_grid(:ngrdcol,top_lev:), rhosn) - - des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) *& - 3._r8 * rhosn/rhows - - reff_snow_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) * & - shapeparam * micron2meter - end where - - -! Graupel/Hail size distribution Placeholder - if (micro_mg_version > 2) then - degrau_grid = 0._r8 - where (qg_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) - dgout2_grid(:ngrdcol,top_lev:) = avg_diameter( & - qg_grid(:ngrdcol,top_lev:), & - ng_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & - rho_grid(:ngrdcol,top_lev:), rhog) - - reff_grau_grid(:ngrdcol,top_lev:) = dgout2_grid(:ngrdcol,top_lev:) * & - 1.5_r8 * 1.e6_r8 - degrau_grid(:ngrdcol,top_lev:) = dgout2_grid(:ngrdcol,top_lev:) *& - 3._r8 * rhog/rhows - end where - end if - - ! Effective radius and diameter for cloud ice. - rei_grid = 25._r8 - - niic_grid(:ngrdcol,top_lev:) = ni_grid(:ngrdcol,top_lev:) / & - max(mincld,icecldf_grid(:ngrdcol,top_lev:)) - - do k = top_lev, pver - !$acc data copyin (mg_ice_props, icimrst_grid(:ngrdcol,k)) & - !$acc copy (niic_grid(:ngrdcol,k)) & - !$acc copyout (rei_grid(:ngrdcol,k)) - call size_dist_param_basic(mg_ice_props,icimrst_grid(:ngrdcol,k), & - niic_grid(:ngrdcol,k),rei_grid(:ngrdcol,k),ngrdcol) - !$acc end data - end do - - where (icimrst_grid(:ngrdcol,top_lev:) >= qsmall) - rei_grid(:ngrdcol,top_lev:) = 1.5_r8/rei_grid(:ngrdcol,top_lev:) & - * 1.e6_r8 - elsewhere - rei_grid(:ngrdcol,top_lev:) = 25._r8 - end where - - dei_grid = rei_grid * rhoi/rhows * 2._r8 - - ! Limiters for low cloud fraction. - do k = top_lev, pver - do i = 1, ngrdcol - ! Convert snow effective diameter to microns - des_grid(i,k) = des_grid(i,k) * 1.e6_r8 - if ( ast_grid(i,k) < 1.e-4_r8 ) then - mu_grid(i,k) = mucon - lambdac_grid(i,k) = (mucon + 1._r8)/dcon - dei_grid(i,k) = deicon - end if - end do - end do - - mgreffrain_grid(:ngrdcol,top_lev:pver) = reff_rain_grid(:ngrdcol,top_lev:pver) - mgreffsnow_grid(:ngrdcol,top_lev:pver) = reff_snow_grid(:ngrdcol,top_lev:pver) - - ! ------------------------------------- ! - ! Precipitation efficiency Calculation ! - ! ------------------------------------- ! - - !----------------------------------------------------------------------- - ! Liquid water path - - ! Compute liquid water paths, and column condensation - tgliqwp_grid(:ngrdcol) = 0._r8 - tgcmeliq_grid(:ngrdcol) = 0._r8 - do k = top_lev, pver - do i = 1, ngrdcol - tgliqwp_grid(i) = tgliqwp_grid(i) + iclwpst_grid(i,k)*cld_grid(i,k) - - if (cmeliq_grid(i,k) > 1.e-12_r8) then - !convert cmeliq to right units: kgh2o/kgair/s * kgair/m2 / kgh2o/m3 = m/s - tgcmeliq_grid(i) = tgcmeliq_grid(i) + cmeliq_grid(i,k) * & - (pdel_grid(i,k) / gravit) / rhoh2o - end if - end do - end do - - ! note: 1e-6 kgho2/kgair/s * 1000. pa / (9.81 m/s2) / 1000 kgh2o/m3 = 1e-7 m/s - ! this is 1ppmv of h2o in 10hpa - ! alternatively: 0.1 mm/day * 1.e-4 m/mm * 1/86400 day/s = 1.e-9 - - !----------------------------------------------------------------------- - ! precipitation efficiency calculation (accumulate cme and precip) - - minlwp = 0.01_r8 !minimum lwp threshold (kg/m3) - - ! zero out precip efficiency and total averaged precip - pe_grid(:ngrdcol) = 0._r8 - tpr_grid(:ngrdcol) = 0._r8 - pefrac_grid(:ngrdcol) = 0._r8 - - ! accumulate precip and condensation - do i = 1, ngrdcol - - acgcme_grid(i) = acgcme_grid(i) + tgcmeliq_grid(i) - acprecl_grid(i) = acprecl_grid(i) + prec_str_grid(i) - acnum_grid(i) = acnum_grid(i) + 1 - - ! if LWP is zero, then 'end of cloud': calculate precip efficiency - if (tgliqwp_grid(i) < minlwp) then - if (acprecl_grid(i) > 5.e-8_r8) then - tpr_grid(i) = max(acprecl_grid(i)/acnum_grid(i), 1.e-15_r8) - if (acgcme_grid(i) > 1.e-10_r8) then - pe_grid(i) = min(max(acprecl_grid(i)/acgcme_grid(i), 1.e-15_r8), 1.e5_r8) - pefrac_grid(i) = 1._r8 - end if - end if - - ! reset counters -! if (pe_grid(i) /= 0._r8 .and. (pe_grid(i) < 1.e-8_r8 .or. pe_grid(i) > 1.e3_r8)) then -! write (iulog,*) 'PE_grid:ANOMALY pe_grid, acprecl_grid, acgcme_grid, tpr_grid, acnum_grid ', & -! pe_grid(i),acprecl_grid(i), acgcme_grid(i), tpr_grid(i), acnum_grid(i) -! endif - - acprecl_grid(i) = 0._r8 - acgcme_grid(i) = 0._r8 - acnum_grid(i) = 0 - end if ! end LWP zero conditional - - ! if never find any rain....(after 10^3 timesteps...) - if (acnum_grid(i) > 1000) then - acnum_grid(i) = 0 - acprecl_grid(i) = 0._r8 - acgcme_grid(i) = 0._r8 - end if - - end do - - !----------------------------------------------------------------------- - ! vertical average of non-zero accretion, autoconversion and ratio. - ! vars: vprco_grid(i),vprao_grid(i),racau_grid(i),cnt_grid - - vprao_grid = 0._r8 - cnt_grid = 0 - do k = top_lev, pver - vprao_grid(:ngrdcol) = vprao_grid(:ngrdcol) + prao_grid(:ngrdcol,k) - where (prao_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 - end do - - where (cnt_grid > 0) vprao_grid = vprao_grid/cnt_grid - - vprco_grid = 0._r8 - cnt_grid = 0 - do k = top_lev, pver - vprco_grid(:ngrdcol) = vprco_grid(:ngrdcol) + prco_grid(:ngrdcol,k) - where (prco_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 - end do - - where (cnt_grid > 0) - vprco_grid = vprco_grid/cnt_grid - racau_grid = vprao_grid/vprco_grid - elsewhere - racau_grid = 0._r8 - end where - - racau_grid = min(racau_grid, 1.e10_r8) - -!----------------------------------------------------------------------- -! Diagnostic Rainbow Calculation. Seriously. -!----------------------------------------------------------------------- - - do i = 1, ngrdcol - - top_idx = pver - convmx = 0._r8 - frlow = 0._r8 - cldmx = 0._r8 - cldtot = maxval(ast(i,top_lev:)) - -! Find levels in surface layer - do k = top_lev, pver - if (state%pmid(i,k) > rb_pmin) then - top_idx = min(k,top_idx) - end if - end do - -!For all fractional precip calculated below, use maximum in surface layer. -!For convective precip, base on convective cloud area - convmx = maxval(concld(i,top_idx:)) -!For stratiform precip, base on precip fraction - cldmx= maxval(freqr(i,top_idx:)) -! Combine and use maximum of strat or conv fraction - frlow= max(cldmx,convmx) - -!max precip - rmax=maxval(qrout_grid(i,top_idx:)) - -! Stratiform precip mixing ratio OR some convective precip -! (rval = true if any sig precip) - - rval = ((precc(i) > rb_rcmin) .or. (rmax > rb_rmin)) - -!Now can find conditions for a rainbow: -! Maximum cloud cover (CLDTOT) < 0.5 -! 48 < SZA < 90 -! freqr (below rb_pmin) > 0.25 -! Some rain (liquid > 1.e-6 kg/kg, convective precip > 1.e-7 m/s - - if ((cldtot < 0.5_r8) .and. (sza(i) > 48._r8) .and. (sza(i) < 90._r8) .and. rval) then - -!Rainbow 'probability' (area) derived from solid angle theory -!as the fraction of the hemisphere for a spherical cap with angle phi=sza-48. -! This is only valid between 48 < sza < 90 (controlled for above). - - rbfrac(i) = max(0._r8,(1._r8-COS((sza(i)-48._r8)*deg2rad))/2._r8) * frlow - rbfreq(i) = 1.0_r8 - end if - - end do ! end column loop for rainbows - - call outfld('RBFRAC', rbfrac, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('RBFREQ', rbfreq, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - - - ! --------------------- ! - ! History Output Fields ! - ! --------------------- ! - - ! Column droplet concentration - cdnumc_grid(:ngrdcol) = sum(nc_grid(:ngrdcol,top_lev:pver) * & - pdel_grid(:ngrdcol,top_lev:pver)/gravit, dim=2) - - ! Averaging for new output fields - efcout_grid = 0._r8 - efiout_grid = 0._r8 - ncout_grid = 0._r8 - niout_grid = 0._r8 - freql_grid = 0._r8 - freqi_grid = 0._r8 - icwmrst_grid_out = 0._r8 - icimrst_grid_out = 0._r8 - freqm_grid = 0._r8 - freqsl_grid = 0._r8 - freqslm_grid = 0._r8 - - do k = top_lev, pver - do i = 1, ngrdcol - if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 5.e-5_r8 ) then - efcout_grid(i,k) = rel_grid(i,k) * liqcldf_grid(i,k) - ncout_grid(i,k) = icwnc_grid(i,k) * liqcldf_grid(i,k) - freql_grid(i,k) = liqcldf_grid(i,k) - icwmrst_grid_out(i,k) = icwmrst_grid(i,k) - end if - if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-6_r8 ) then - efiout_grid(i,k) = rei_grid(i,k) * icecldf_grid(i,k) - niout_grid(i,k) = icinc_grid(i,k) * icecldf_grid(i,k) - freqi_grid(i,k) = icecldf_grid(i,k) - icimrst_grid_out(i,k) = icimrst_grid(i,k) - end if - - ! Supercooled liquid - if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) > 0.01_r8 ) then - freqm_grid(i,k)=min(liqcldf_grid(i,k),icecldf_grid(i,k)) - end if - if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) < 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then - freqsl_grid(i,k)=liqcldf_grid(i,k) - end if - if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) > 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then - freqslm_grid(i,k)=liqcldf_grid(i,k) - end if - - end do - end do - - ! Cloud top effective radius and number. - fcti_grid = 0._r8 - fctl_grid = 0._r8 - ctrel_grid = 0._r8 - ctrei_grid = 0._r8 - ctnl_grid = 0._r8 - ctni_grid = 0._r8 - fctm_grid = 0._r8 - fctsl_grid = 0._r8 - fctslm_grid= 0._r8 - - do i = 1, ngrdcol - do k = top_lev, pver - if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 1.e-7_r8 ) then - ctrel_grid(i) = rel_grid(i,k) * liqcldf_grid(i,k) - ctnl_grid(i) = icwnc_grid(i,k) * liqcldf_grid(i,k) - fctl_grid(i) = liqcldf_grid(i,k) - - ! Cloud Top Mixed phase, supercooled liquid only and supercooled liquid mixed - if (freqi_grid(i,k) > 0.01_r8) then - fctm_grid(i)=min(liqcldf_grid(i,k),icecldf_grid(i,k)) - end if - if (freqi_grid(i,k) < 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then - fctsl_grid(i)=liqcldf_grid(i,k) - end if - if (freqi_grid(i,k) > 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then - fctslm_grid(i)=liqcldf_grid(i,k) - end if - - exit - end if - - if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-7_r8 ) then - ctrei_grid(i) = rei_grid(i,k) * icecldf_grid(i,k) - ctni_grid(i) = icinc_grid(i,k) * icecldf_grid(i,k) - fcti_grid(i) = icecldf_grid(i,k) - exit - end if - end do - end do - - ! Evaporation of stratiform precipitation fields for UNICON - evprain_st_grid(:ngrdcol,:pver) = nevapr_grid(:ngrdcol,:pver) - evpsnow_st_grid(:ngrdcol,:pver) - do k = top_lev, pver - do i = 1, ngrdcol - evprain_st_grid(i,k) = max(evprain_st_grid(i,k), 0._r8) - evpsnow_st_grid(i,k) = max(evpsnow_st_grid(i,k), 0._r8) - end do - end do - - ! Assign the values to the pbuf pointers if they exist in pbuf - if (qrain_idx > 0) qrout_grid_ptr = qrout_grid - if (qsnow_idx > 0) qsout_grid_ptr = qsout_grid - if (nrain_idx > 0) nrout_grid_ptr = nrout_grid - if (nsnow_idx > 0) nsout_grid_ptr = nsout_grid - if (qcsedten_idx > 0) qcsedtenout_grid_ptr = qcsedtenout_grid - if (qrsedten_idx > 0) qrsedtenout_grid_ptr = qrsedtenout_grid - if (qisedten_idx > 0) qisedtenout_grid_ptr = qisedtenout_grid - if (qssedten_idx > 0) qssedtenout_grid_ptr = qssedtenout_grid - if (qgsedten_idx > 0) qgsedtenout_grid_ptr = qgsedtenout_grid !+tht - if (vtrmc_idx > 0) vtrmcout_grid_ptr = vtrmcout_grid - if (umr_idx > 0) umrout_grid_ptr = umrout_grid - if (vtrmi_idx > 0) vtrmiout_grid_ptr = vtrmiout_grid - if (ums_idx > 0) umsout_grid_ptr = umsout_grid - if (qcsevap_idx > 0 ) qcsevapout_grid_ptr = qcsevapout_grid - if (qisevap_idx > 0 ) qisevapout_grid_ptr = qisevapout_grid - - ! --------------------------------------------- ! - ! General outfield calls for microphysics ! - ! --------------------------------------------- ! - - ! Output a handle of variables which are calculated on the fly - - ftem_grid = 0._r8 - - ftem_grid(:ngrdcol,top_lev:pver) = qcreso_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDW2V', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = melto_grid(:ngrdcol,top_lev:pver) - mnuccco_grid(:ngrdcol,top_lev:pver)& - - mnuccto_grid(:ngrdcol,top_lev:pver) - bergo_grid(:ngrdcol,top_lev:pver) - homoo_grid(:ngrdcol,top_lev:pver)& - - msacwio_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDW2I', ftem_grid, pcols, lchnk) - - if (micro_mg_version > 2) then - ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& - - psacwso_grid(:ngrdcol,top_lev:pver) - bergso_grid(:ngrdcol,top_lev:pver)& - - psacwgo_grid(:ngrdcol,top_lev:pver) - pgsacwo_grid(:ngrdcol,top_lev:pver) - else - ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& - - psacwso_grid(:ngrdcol,top_lev:pver) - bergso_grid(:ngrdcol,top_lev:pver) - endif - - call outfld( 'MPDW2P', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = cmeiout_grid(:ngrdcol,top_lev:pver) + qireso_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDI2V', ftem_grid, pcols, lchnk) - - if (micro_mg_version > 2) then - ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & - + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& - + msacwio_grid(:ngrdcol,top_lev:pver)& - - qmultgo_grid(:ngrdcol,top_lev:pver) - else - ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & - + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& - + msacwio_grid(:ngrdcol,top_lev:pver) - endif - - call outfld( 'MPDI2W', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = -prcio_grid(:ngrdcol,top_lev:pver) - praio_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDI2P', ftem_grid, pcols, lchnk) - - ! Output fields which have not been averaged already, averaging if use_subcol_microp is true - if (trim(micro_mg_warm_rain) == 'tau' .or. trim(micro_mg_warm_rain) == 'emulated') then - call outfld('scale_qc', proc_rates%scale_qc, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('scale_nc', proc_rates%scale_nc, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('scale_qr', proc_rates%scale_qr, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('scale_nr', proc_rates%scale_nr, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('amk_c', proc_rates%amk_c, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ank_c', proc_rates%ank_c, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('amk_r', proc_rates%amk_r, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ank_r', proc_rates%ank_r, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('amk', proc_rates%amk, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ank', proc_rates%ank, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('amk_out', proc_rates%amk_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ank_out', proc_rates%ank_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QC_TAU_out', proc_rates%qc_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NC_TAU_out', proc_rates%nc_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QR_TAU_out', proc_rates%qr_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NR_TAU_out', proc_rates%nr_out_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('qctend_TAU', proc_rates%qctend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nctend_TAU', proc_rates%nctend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('qrtend_TAU', proc_rates%qrtend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nrtend_TAU', proc_rates%nrtend_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('gmnnn_lmnnn_TAU', proc_rates%gmnnn_lmnnn_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ML_fixer', proc_rates%ML_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('qc_fixer', proc_rates%qc_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nc_fixer', proc_rates%nc_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('qr_fixer', proc_rates%qr_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nr_fixer', proc_rates%nr_fixer, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QC_TAU_in', proc_rates%qc_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NC_TAU_in', proc_rates%nc_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QR_TAU_in', proc_rates%qr_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NR_TAU_in', proc_rates%nr_in_TAU, ncol, lchnk, avg_subcol_field=use_subcol_microp) - end if - - if (trim(micro_mg_warm_rain) == 'sb2001') then - call outfld('qctend_SB2001', proc_rates%qctend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nctend_SB2001', proc_rates%nctend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('qrtend_SB2001', proc_rates%qrtend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nrtend_SB2001', proc_rates%nrtend_SB2001, ncol, lchnk, avg_subcol_field=use_subcol_microp) - end if - if (trim(micro_mg_warm_rain) == 'kk2000') then - call outfld('qctend_KK2000', proc_rates%qctend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nctend_KK2000', proc_rates%nctend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('qrtend_KK2000', proc_rates%qrtend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('nrtend_KK2000', proc_rates%nrtend_KK2000, ncol, lchnk, avg_subcol_field=use_subcol_microp) - end if - call outfld('LAMC', proc_rates%lamc_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('LAMR', proc_rates%lamr_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('PGAM', proc_rates%pgam_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('N0R', proc_rates%n0r_out, ncol, lchnk, avg_subcol_field=use_subcol_microp) - - call outfld('MPICLWPI', iclwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPICIWPI', iciwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('REFL', refl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AREFL', arefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AREFLZ', areflz, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREFL', frefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('CSRFL', csrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ACSRFL', acsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FCSRFL', fcsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('REFL10CM', refl10cm, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('REFLZ10CM', reflz10cm, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('RERCLD', rercld, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NCAL', ncal, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NCAI', ncai, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AQRAIN', qrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AQSNOW', qsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ANRAIN', nrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ANSNOW', nsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREQR', freqr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREQS', freqs, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDT', tlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDQ', qvlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDLIQ', qcten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDICE', qiten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDNLIQ', ncten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDNICE', niten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('EVAPSNOW', proc_rates%evapsnow, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QCSEVAP', proc_rates%qcsevap, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QISEVAP', proc_rates%qisevap, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QVRES', proc_rates%qvres, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('VTRMC', proc_rates%vtrmc, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('VTRMI', proc_rates%vtrmi, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QCSEDTEN', proc_rates%qcsedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QISEDTEN', proc_rates%qisedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QRSEDTEN', proc_rates%qrsedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QSSEDTEN', proc_rates%qssedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCRIO', proc_rates%mnuccritot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUDEPO', proc_rates%mnudeptot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MELTSTOT', proc_rates%meltstot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCDO', proc_rates%mnuccdtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCDOhet', mnuccdohet, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCRO', proc_rates%mnuccrtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('PRACSO', proc_rates%pracstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('VAPDEPSO', proc_rates%vapdepstot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MELTSDT', proc_rates%meltsdttot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FRZRDT', proc_rates%frzrdttot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FICE', nfice, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('CLDFSNOW', cldfsnow, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NNUCCCO', proc_rates%nnuccctot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NNUCCTO', proc_rates%nnuccttot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NNUCCDO', proc_rates%nnuccdtot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NNUDEPO', proc_rates%nnudeptot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NHOMO', proc_rates%nhomotot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NNUCCRO', proc_rates%nnuccrtot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NNUCCRIO', proc_rates%nnuccritot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NSACWIO', proc_rates%nsacwitot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NPRAO', proc_rates%npratot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NPSACWSO', proc_rates%npsacwstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NPRAIO', proc_rates%npraitot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NPRACSO', proc_rates%npracstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NPRCO', proc_rates%nprctot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NPRCIO', proc_rates%nprcitot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NCSEDTEN', proc_rates%ncsedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NISEDTEN', proc_rates%nisedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NRSEDTEN', proc_rates%nrsedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NSSEDTEN', proc_rates%nssedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NMELTO', proc_rates%nmelttot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld ('NMELTS', proc_rates%nmeltstot , ncol, lchnk, avg_subcol_field=use_subcol_microp) - - call outfld('UMR', proc_rates%umr, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('UMS', proc_rates%ums, ncol, lchnk, avg_subcol_field=use_subcol_microp) - - call outfld('QCRAT', qcrat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - - if (micro_mg_version > 2) then - call outfld('UMG', proc_rates%umg, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QGSEDTEN', proc_rates%qgsedten, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREQG', freqg, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AQGRAU', qgout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ANGRAU', ngout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('CLDFGRAU', cldfgrau, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MELTGTOT', proc_rates%meltgtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NMELTG', proc_rates%nmeltgtot, ncol, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NGSEDTEN', proc_rates%ngsedten , ncol, lchnk, avg_subcol_field=use_subcol_microp) - - end if - - ! Example subcolumn outfld call - if (use_subcol_microp) then - call outfld('FICE_SCOL', nfice, psubcols*pcols, lchnk) - call outfld('MPDLIQ_SCOL', ptend%q(:,:,ixcldliq), psubcols*pcols, lchnk) - call outfld('MPDICE_SCOL', qiten, psubcols*pcols, lchnk) - end if - - ! Output fields which are already on the grid - call outfld('QRAIN', qrout_grid, pcols, lchnk) - call outfld('QSNOW', qsout_grid, pcols, lchnk) - call outfld('NRAIN', nrout_grid, pcols, lchnk) - call outfld('NSNOW', nsout_grid, pcols, lchnk) - call outfld('CV_REFFLIQ', cvreffliq_grid, pcols, lchnk) - call outfld('CV_REFFICE', cvreffice_grid, pcols, lchnk) - call outfld('LS_FLXPRC', mgflxprc_grid, pcols, lchnk) - call outfld('LS_FLXSNW', mgflxsnw_grid, pcols, lchnk) - call outfld('CME', qme_grid, pcols, lchnk) - call outfld('PRODPREC', prain_grid, pcols, lchnk) - call outfld('EVAPPREC', nevapr_grid, pcols, lchnk) - call outfld('QCRESO', qcreso_grid, pcols, lchnk) - call outfld('LS_REFFRAIN', mgreffrain_grid, pcols, lchnk) - call outfld('LS_REFFSNOW', mgreffsnow_grid, pcols, lchnk) - call outfld('DSNOW', des_grid, pcols, lchnk) - call outfld('ADRAIN', drout2_grid, pcols, lchnk) - call outfld('ADSNOW', dsout2_grid, pcols, lchnk) - call outfld('PE', pe_grid, pcols, lchnk) - call outfld('PEFRAC', pefrac_grid, pcols, lchnk) - call outfld('APRL', tpr_grid, pcols, lchnk) - call outfld('VPRAO', vprao_grid, pcols, lchnk) - call outfld('VPRCO', vprco_grid, pcols, lchnk) - call outfld('RACAU', racau_grid, pcols, lchnk) - call outfld('AREL', efcout_grid, pcols, lchnk) - call outfld('AREI', efiout_grid, pcols, lchnk) - call outfld('AWNC' , ncout_grid, pcols, lchnk) - call outfld('AWNI' , niout_grid, pcols, lchnk) - call outfld('FREQL', freql_grid, pcols, lchnk) - call outfld('FREQI', freqi_grid, pcols, lchnk) - call outfld('ACTREL', ctrel_grid, pcols, lchnk) - call outfld('ACTREI', ctrei_grid, pcols, lchnk) - call outfld('ACTNL', ctnl_grid, pcols, lchnk) - call outfld('ACTNI', ctni_grid, pcols, lchnk) - call outfld('FCTL', fctl_grid, pcols, lchnk) - call outfld('FCTI', fcti_grid, pcols, lchnk) - call outfld('ICINC', icinc_grid, pcols, lchnk) - call outfld('ICWNC', icwnc_grid, pcols, lchnk) - call outfld('EFFLIQ_IND', rel_fn_grid, pcols, lchnk) - call outfld('CDNUMC', cdnumc_grid, pcols, lchnk) - call outfld('REL', rel_grid, pcols, lchnk) - call outfld('REI', rei_grid, pcols, lchnk) - call outfld('MG_SADICE', sadice_grid, pcols, lchnk) - call outfld('MG_SADSNOW', sadsnow_grid, pcols, lchnk) - call outfld('ICIMRST', icimrst_grid_out, pcols, lchnk) - call outfld('ICWMRST', icwmrst_grid_out, pcols, lchnk) - call outfld('CMEIOUT', cmeiout_grid, pcols, lchnk) - call outfld('PRAO', prao_grid, pcols, lchnk) - call outfld('PRCO', prco_grid, pcols, lchnk) - call outfld('MNUCCCO', mnuccco_grid, pcols, lchnk) - call outfld('MNUCCTO', mnuccto_grid, pcols, lchnk) - call outfld('MSACWIO', msacwio_grid, pcols, lchnk) - call outfld('PSACWSO', psacwso_grid, pcols, lchnk) - call outfld('BERGSO', bergso_grid, pcols, lchnk) - call outfld('BERGO', bergo_grid, pcols, lchnk) - call outfld('MELTO', melto_grid, pcols, lchnk) - call outfld('HOMOO', homoo_grid, pcols, lchnk) - call outfld('PRCIO', prcio_grid, pcols, lchnk) - call outfld('PRAIO', praio_grid, pcols, lchnk) - call outfld('QIRESO', qireso_grid, pcols, lchnk) - call outfld('FREQM', freqm_grid, pcols, lchnk) - call outfld('FREQSL', freqsl_grid, pcols, lchnk) - call outfld('FREQSLM', freqslm_grid, pcols, lchnk) - call outfld('FCTM', fctm_grid, pcols, lchnk) - call outfld('FCTSL', fctsl_grid, pcols, lchnk) - call outfld('FCTSLM', fctslm_grid, pcols, lchnk) - - if (micro_mg_version > 2) then - call outfld('PRACGO', pracgo_grid, pcols, lchnk) - call outfld('PSACRO', psacro_grid, pcols, lchnk) - call outfld('PSACWGO', psacwgo_grid, pcols, lchnk) - call outfld('PGSACWO', pgsacwo_grid, pcols, lchnk) - call outfld('PGRACSO', pgracso_grid, pcols, lchnk) - call outfld('PRDGO', prdgo_grid, pcols, lchnk) - call outfld('QMULTGO', qmultgo_grid, pcols, lchnk) - call outfld('QMULTRGO', qmultrgo_grid, pcols, lchnk) - call outfld('LS_REFFGRAU', reff_grau_grid, pcols, lchnk) - call outfld ('NPRACGO', npracgo_grid, pcols, lchnk) - call outfld ('NSCNGO', nscngo_grid, pcols, lchnk) - call outfld ('NGRACSO', ngracso_grid, pcols, lchnk) - call outfld ('NMULTGO', nmultgo_grid, pcols, lchnk) - call outfld ('NMULTRGO', nmultrgo_grid, pcols, lchnk) - call outfld ('NPSACWGO', npsacwgo_grid, pcols, lchnk) - end if - - if (micro_mg_adjust_cpt) then - cp_rh(:ncol, :pver) = 0._r8 - - do i = 1, ncol - - ! Calculate the RH including any T change that we make. - do k = top_lev, pver - call qsat(state_loc%t(i,k), state_loc%pmid(i,k), es, qs) - cp_rh(i,k) = state_loc%q(i, k, ixq) / qs * 100._r8 - end do - end do - - call outfld("TROPF_RHADJ", cp_rh, pcols, lchnk) - end if - - ! deallocate the temporary pbuf grid variable which was allocated if subcolumns are not used - if (.not. use_subcol_microp) then - deallocate(bergso_grid) - end if - - ! deallocate the proc_rates DDT - call proc_rates%deallocate(micro_mg_warm_rain) - - ! ptend_loc is deallocated in physics_update above - call physics_state_dealloc(state_loc) - - if (qsatfac_idx <= 0) then - deallocate(qsatfac) - end if - -end subroutine micro_pumas_cam_tend - -subroutine massless_droplet_destroyer(ztodt, state, ptend) - - ! This subroutine eradicates cloud droplets in grid boxes with no cloud - ! mass. This code is now expanded to remove massless rain drops, ice - ! crystals, and snow flakes. - ! - ! Note: qsmall, which is a small, positive number, is used as the - ! threshold here instead of qmin, which is 0. Some numbers that are - ! supposed to have a value of 0, but don't because of numerical - ! roundoff (especially after hole filling) will have small, positive - ! values. Using qsmall as the threshold here instead of qmin allows - ! for unreasonable massless drop concentrations to be removed in - ! those scenarios. - - use micro_pumas_utils, only: qsmall - use ref_pres, only: top_lev => trop_cloud_top_lev - - implicit none - - ! Input Variables - real(r8), intent(in) :: ztodt ! model time increment - type(physics_state), intent(in) :: state ! state for columns - - ! Input/Output Variables - type(physics_ptend), intent(inout) :: ptend ! ptend for columns - - ! Local Variables - integer :: icol, k - - !----- Begin Code ----- - - ! Don't do anything if this option isn't enabled. - if ( .not. micro_do_massless_droplet_destroyer ) return - - col_loop: do icol=1, state%ncol - vert_loop: do k = top_lev, pver - ! If updated qc (after microphysics) is zero, then ensure updated nc is also zero!! - if ( state%q(icol,k,ixcldliq) + ztodt * ptend%q(icol,k,ixcldliq) < qsmall ) then - ptend%lq(ixnumliq) = .true. ! This is probably already true, but it doesn't - ! hurt to set it. - ptend%q(icol,k,ixnumliq) = -(state%q(icol,k,ixnumliq) / ztodt) - end if - if ( ixnumrain > 0 ) then - ! If updated qr (after microphysics) is zero, then ensure updated nr is also zero!! - if ( state%q(icol,k,ixrain) + ztodt * ptend%q(icol,k,ixrain) < qsmall ) then - ptend%lq(ixnumrain) = .true. ! This is probably already true, but it doesn't - ! hurt to set it. - ptend%q(icol,k,ixnumrain) = -(state%q(icol,k,ixnumrain) / ztodt) - end if - endif ! ixnumrain > 0 - ! If updated qi (after microphysics) is zero, then ensure updated ni is also zero!! - if ( state%q(icol,k,ixcldice) + ztodt * ptend%q(icol,k,ixcldice) < qsmall ) then - ptend%lq(ixnumice) = .true. ! This is probably already true, but it doesn't - ! hurt to set it. - ptend%q(icol,k,ixnumice) = -(state%q(icol,k,ixnumice) / ztodt) - end if - if ( ixnumsnow > 0 ) then - ! If updated qs (after microphysics) is zero, then ensure updated ns is also zero!! - if ( state%q(icol,k,ixsnow) + ztodt * ptend%q(icol,k,ixsnow) < qsmall ) then - ptend%lq(ixnumsnow) = .true. ! This is probably already true, but it doesn't - ! hurt to set it. - ptend%q(icol,k,ixnumsnow) = -(state%q(icol,k,ixnumsnow) / ztodt) - end if - endif ! ixnumsnow > 0 - end do vert_loop - end do col_loop - - return -end subroutine massless_droplet_destroyer - -end module micro_pumas_cam From f9238de5ad4757e8fea532edf626417a1b11e7e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=98yvind=20Seland?= Date: Fri, 20 Jun 2025 07:51:23 +0200 Subject: [PATCH 04/78] Added untis to new parameters when relevant --- bld/namelist_files/namelist_definition.xml | 74 ++-------------------- 1 file changed, 4 insertions(+), 70 deletions(-) diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 8363139ac3..2345cd9fa6 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -2275,7 +2275,7 @@ Default: 0,-24,-24,-24,-24,-24,-24,-24,-24,-24 group="cam_history_nl" valid_values=""> If interpolate_output(k) = .true., then the k'th history file will be interpolated to a lat/lon grid before output. -Default: .false.,.false.,.false.,.false.,.false.,.false.,.false.,.false.,.false.,.false. +Default: .false. - - - If .true., compute secondary ice production using random forests method. - Default: .true. - - - - ML parameters for the forestALL RFR model. - Georgakaki, P., & Nenes, A. (2024). - RaFSIP: Parameterizing ice multiplication in models using a machine learning - approach. Journal of Advances in Modeling Earth Systems, 16, - e2023MS003923. - https://doi.org/10.1029/2023MS003923 - Default: None - - - - ML parameters for the forestBRDS RFR model. - Georgakaki, P., & Nenes, A. (2024). - RaFSIP: Parameterizing ice multiplication in models using a machine learning - approach. Journal of Advances in Modeling Earth Systems, 16, - e2023MS003923. - https://doi.org/10.1029/2023MS003923 - Default: None - - - - ML parameters for the forestBRHM RFR model. - Georgakaki, P., & Nenes, A. (2024). - RaFSIP: Parameterizing ice multiplication in models using a machine learning - approach. Journal of Advances in Modeling Earth Systems, 16, - e2023MS003923. - https://doi.org/10.1029/2023MS003923 - Default: None - - - - ML parameters for the forestBR RFR model. - Georgakaki, P., & Nenes, A. (2024). - RaFSIP: Parameterizing ice multiplication in models using a machine learning - approach. Journal of Advances in Modeling Earth Systems, 16, - e2023MS003923. - https://doi.org/10.1029/2023MS003923 - Default: None - - - - ML parameters for the forestBRwarm RFR model. - Georgakaki, P., & Nenes, A. (2024). - RaFSIP: Parameterizing ice multiplication in models using a machine learning - approach. Journal of Advances in Modeling Earth Systems, 16, - e2023MS003923. - https://doi.org/10.1029/2023MS003923 - Default: None - - - - SIP: Total secondary ice production amount and it's components - All: sip outputs plus inputs to SIP computation (except temperature) - default: none - + + tht: previously undeclared param: min LCL pressure to allow zm -Default: 6e2 +Default: 6e2 mbar From fa61489b558ad2bf2d8759fc9c0d91bfef1c8088 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 16 Aug 2025 20:35:49 +0200 Subject: [PATCH 05/78] first set of refactors for cam cam computing enthalpy over ocean to send to mediator --- bld/namelist_files/namelist_definition.xml | 70 +- src/chemistry/oslo_aero | 2 +- src/cpl/nuopc/atm_comp_nuopc.F90 | 10 + src/cpl/nuopc/atm_import_export.F90 | 50 +- .../camnor_phys/physics/atm_import_export.F90 | 1531 ----------------- 5 files changed, 127 insertions(+), 1536 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/atm_import_export.F90 diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 2345cd9fa6..bfde645137 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -3023,8 +3023,74 @@ level from 100 to 125 hPa applied only in the polar regions (false). Default: .true. - - + + + If .true., compute secondary ice production using random forests method. + Default: .true. + + + + ML parameters for the forestALL RFR model. + Georgakaki, P., & Nenes, A. (2024). + RaFSIP: Parameterizing ice multiplication in models using a machine learning + approach. Journal of Advances in Modeling Earth Systems, 16, + e2023MS003923. + https://doi.org/10.1029/2023MS003923 + Default: None + + + + ML parameters for the forestBRDS RFR model. + Georgakaki, P., & Nenes, A. (2024). + RaFSIP: Parameterizing ice multiplication in models using a machine learning + approach. Journal of Advances in Modeling Earth Systems, 16, + e2023MS003923. + https://doi.org/10.1029/2023MS003923 + Default: None + + + + ML parameters for the forestBRHM RFR model. + Georgakaki, P., & Nenes, A. (2024). + RaFSIP: Parameterizing ice multiplication in models using a machine learning + approach. Journal of Advances in Modeling Earth Systems, 16, + e2023MS003923. + https://doi.org/10.1029/2023MS003923 + Default: None + + + + ML parameters for the forestBR RFR model. + Georgakaki, P., & Nenes, A. (2024). + RaFSIP: Parameterizing ice multiplication in models using a machine learning + approach. Journal of Advances in Modeling Earth Systems, 16, + e2023MS003923. + https://doi.org/10.1029/2023MS003923 + Default: None + + + + ML parameters for the forestBRwarm RFR model. + Georgakaki, P., & Nenes, A. (2024). + RaFSIP: Parameterizing ice multiplication in models using a machine learning + approach. Journal of Advances in Modeling Earth Systems, 16, + e2023MS003923. + https://doi.org/10.1029/2023MS003923 + Default: None + + + + SIP: Total secondary ice production amount and it's components + All: sip outputs plus inputs to SIP computation (except temperature) + default: none + atm integer :: emis_nflds = -huge(1) ! number of fire emission fields from lnd-> atm logical :: atm_provides_lightning = .false. ! cld to grnd lightning flash freq (min-1) + logical, public :: dms_from_ocn = .false. ! dms is obtained from ocean as atm import data logical, public :: brf_from_ocn = .false. ! brf is obtained from ocean as atm import data logical, public :: n2o_from_ocn = .false. ! n2o is obtained from ocean as atm import data logical, public :: nh3_from_ocn = .false. ! nh3 is obtained from ocean as atm import data @@ -115,7 +117,6 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) logical :: flds_co2b ! use case logical :: flds_co2c ! use case character(len=128) :: fldname - logical :: dms_from_ocn ! dms is obtained from ocean as atm import data logical :: ispresent logical :: isset character(len=*), parameter :: subname='(atm_import_export:advertise_fields): ' @@ -219,6 +220,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainl' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowc' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowl' ) + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hmat' ) ! enthalpy flux computed by cam + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hlat' ) ! var.lat.ht.part call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_lwdn' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndr' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdr' ) @@ -301,6 +304,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_sen' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lwup' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_evap' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faox_evap' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_hrof' ) ! dust fluxes from land (4 sizes) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_flxdst', ungridded_lbound=1, ungridded_ubound=4) @@ -583,6 +588,8 @@ subroutine import_fields( gcomp, cam_in, restart_init, rc) real(r8), pointer :: fldptr_tauy(:) real(r8), pointer :: fldptr_sen(:) real(r8), pointer :: fldptr_evap(:) + real(r8), pointer :: fldptr_evop(:) + real(r8), pointer :: fldptr_hrof(:) logical, save :: first_time = .true. character(len=*), parameter :: subname='(atm_import_export:import_fields)' !--------------------------------------------------------------------------- @@ -611,6 +618,30 @@ subroutine import_fields( gcomp, cam_in, restart_init, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getfldptr(importState, 'Faxx_evap', fldptr=fldptr_evap, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ***NOTE:*** if cam_compute_enthalpy_flux is .false. and if in + ! CMEPS med_computes_enthalpy_flux is .true., then the mediator + ! will compute it if the ocean requests it and add a correction + ! to the sensible heat sent to cam. This is the case if cam is coupled to MOM6. + ! However, it is not the case if CAM is coupled to BLOM. + + if (compute_enthalpy_flux) then + ! ocean-point hevap (compute_enthalpy_flux = T) + call state_getfldptr(importState, 'Faox_evap', fldptr=fldptr_evop, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! enthalpy of runoff(compute_enthalpy_flux = T) + call state_getfldptr(importState, 'Faxx_hrof', fldptr=fldptr_hrof, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%evap_ocn(i) = -fldptr_evop(g) * med2mod_areacor(g) + cam_in(c)%hrof(i) = -fldptr_hrof(g) * med2mod_areacor(g) + g = g + 1 + end do + end do + end if ! end of compute_enthalpy_flux + g = 1 do c = begchunk,endchunk do i = 1,get_ncols_p(c) @@ -1052,6 +1083,7 @@ subroutine export_fields( gcomp, model_mesh, model_clock, cam_out, rc) real(r8), pointer :: fldptr_soll(:) , fldptr_sols(:) real(r8), pointer :: fldptr_solld(:) , fldptr_solsd(:) real(r8), pointer :: fldptr_snowc(:) , fldptr_snowl(:) + real(r8), pointer :: fldptr_hmat (:) , fldptr_hlat (:) ! enthalpy flux computed by cam real(r8), pointer :: fldptr_rainc(:) , fldptr_rainl(:) real(r8), pointer :: fldptr_lwdn(:) , fldptr_swnet(:) real(r8), pointer :: fldptr_topo(:) , fldptr_zbot(:) @@ -1150,6 +1182,20 @@ subroutine export_fields( gcomp, model_mesh, model_clock, cam_out, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getfldptr(exportState, 'Faxa_swvdf', fldptr=fldptr_solsd, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (compute_enthalpy_flux) then + call state_getfldptr(exportState, 'Faxa_hmat' , fldptr=fldptr_hmat , rc=rc) ! enthalpy + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Faxa_hlat' , fldptr=fldptr_hlat , rc=rc) ! variable latent heat part + if (ChkErr(rc,__LINE__,u_FILE_u)) return + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + fldptr_hmat (g) = cam_out(c)%hmat(i) * mod2med_areacor(g) ! enthalpy + fldptr_hlat (g) = cam_out(c)%hlat(i) * mod2med_areacor(g) ! variable latent heat part + g = g + 1 + end do + end do + end if g = 1 do c = begchunk,endchunk do i = 1,get_ncols_p(c) diff --git a/src/physics/camnor_phys/physics/atm_import_export.F90 b/src/physics/camnor_phys/physics/atm_import_export.F90 deleted file mode 100644 index 054854689e..0000000000 --- a/src/physics/camnor_phys/physics/atm_import_export.F90 +++ /dev/null @@ -1,1531 +0,0 @@ -module atm_import_export - - use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected - use NUOPC_Model , only : NUOPC_ModelGet - use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet, ESMF_Field - use ESMF , only : ESMF_Clock - use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError - use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag - use ESMF , only : operator(/=), operator(==) - use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs, cx=>shr_kind_cx - use shr_sys_mod , only : shr_sys_abort - use shr_mpi_mod , only : shr_mpi_min, shr_mpi_max - use nuopc_shr_methods , only : chkerr - use cam_logfile , only : iulog - use cam_history , only: outfld - use spmd_utils , only : masterproc, mpicom - use srf_field_check , only : set_active_Sl_ram1 - use srf_field_check , only : set_active_Sl_fv - use srf_field_check , only : set_active_Sl_soilw - use srf_field_check , only : set_active_Fall_flxdst1 - use srf_field_check , only : set_active_Fall_flxvoc - use srf_field_check , only : set_active_Fall_flxfire - use srf_field_check , only : set_active_Fall_fco2_lnd - use srf_field_check , only : set_active_Faoo_fco2_ocn - use atm_stream_ndep , only : stream_ndep_init, stream_ndep_interp, stream_ndep_is_initialized - use atm_stream_ndep , only : ndep_stream_active - use chemistry , only : chem_has_ndep_flx - use cam_control_mod , only : aqua_planet, simple_phys - - implicit none - private ! except - - public :: read_surface_fields_namelists - public :: advertise_fields - public :: realize_fields - public :: import_fields - public :: export_fields - - private :: fldlist_add - private :: fldlist_realize - private :: state_getfldptr - - type fldlist_type - character(len=128) :: stdname - integer :: ungridded_lbound = 0 - integer :: ungridded_ubound = 0 - end type fldlist_type - - integer , parameter :: fldsMax = 100 - integer , public, protected :: fldsToAtm_num = 0 - integer , public, protected :: fldsFrAtm_num = 0 - type (fldlist_type) , public, protected :: fldsToAtm(fldsMax) - type (fldlist_type) , public, protected :: fldsFrAtm(fldsMax) - - ! area correction factors for fluxes send and received from mediator - real(r8), allocatable :: mod2med_areacor(:) - real(r8), allocatable :: med2mod_areacor(:) - - character(len=cx) :: carma_fields = ' ' ! list of CARMA fields from lnd->atm - integer :: drydep_nflds = -huge(1) ! number of dry deposition velocity fields lnd-> atm - integer :: megan_nflds = -huge(1) ! number of MEGAN voc fields from lnd-> atm - integer :: emis_nflds = -huge(1) ! number of fire emission fields from lnd-> atm - logical :: atm_provides_lightning = .false. ! cld to grnd lightning flash freq (min-1) - logical, public :: dms_from_ocn = .false. ! dms is obtained from ocean as atm import data - logical, public :: brf_from_ocn = .false. ! brf is obtained from ocean as atm import data - logical, public :: n2o_from_ocn = .false. ! n2o is obtained from ocean as atm import data - logical, public :: nh3_from_ocn = .false. ! nh3 is obtained from ocean as atm import data - character(*),parameter :: F01 = "('(cam_import_export) ',a,i8,2x,i8,2x,d21.14)" - character(*),parameter :: F02 = "('(cam_import_export) ',a,i8,2x,i8,2x,i8,2x,d21.14)" - character(*),parameter :: u_FILE_u = __FILE__ - -!=============================================================================== -contains -!=============================================================================== - - !----------------------------------------------------------- - ! read mediator fields namelist file - !----------------------------------------------------------- - subroutine read_surface_fields_namelists() - - use shr_drydep_mod , only : shr_drydep_readnl - use shr_megan_mod , only : shr_megan_readnl - use shr_fire_emis_mod , only : shr_fire_emis_readnl - use shr_carma_mod , only : shr_carma_readnl - use shr_lightning_coupling_mod, only : shr_lightning_coupling_readnl - - character(len=*), parameter :: nl_file_name = 'drv_flds_in' - - ! read mediator fields options - call shr_drydep_readnl(nl_file_name, drydep_nflds) - call shr_megan_readnl(nl_file_name, megan_nflds) - call shr_fire_emis_readnl(nl_file_name, emis_nflds) - call shr_carma_readnl(nl_file_name, carma_fields) - call shr_lightning_coupling_readnl(nl_file_name, atm_provides_lightning) - - end subroutine read_surface_fields_namelists - - !----------------------------------------------------------- - ! advertise fields - !----------------------------------------------------------- - subroutine advertise_fields(gcomp, flds_scalar_name, rc) - - ! input/output variables - type(ESMF_GridComp) :: gcomp - character(len=*) , intent(in) :: flds_scalar_name - integer , intent(out) :: rc - - ! local variables - type(ESMF_State) :: importState - type(ESMF_State) :: exportState - character(ESMF_MAXSTR) :: stdname - character(ESMF_MAXSTR) :: cvalue - integer :: n, num - logical :: flds_co2a ! use case - logical :: flds_co2b ! use case - logical :: flds_co2c ! use case - character(len=128) :: fldname - logical :: ispresent - logical :: isset - character(len=*), parameter :: subname='(atm_import_export:advertise_fields): ' - !------------------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - !-------------------------------- - ! determine necessary toggles for below - !-------------------------------- - - call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) flds_co2a - if (masterproc) then - write(iulog,'(3a)') trim(subname), 'flds_co2a = ', trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) flds_co2b - if (masterproc) then - write(iulog,'(3a)') trim(subname), 'flds_co2b = ', trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) flds_co2c - if (masterproc) then - write(iulog,'(3a)') trim(subname), 'flds_co2c = ', trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='flds_dms', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ispresent .and. isset) then - read(cvalue,*) dms_from_ocn - else - dms_from_ocn = .false. - end if - if (masterproc) then - write(iulog,'(2a,l)') trim(subname), 'dms_from_ocn = ', dms_from_ocn - end if - - call NUOPC_CompAttributeGet(gcomp, name='flds_brf', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ispresent .and. isset) then - read(cvalue,*) brf_from_ocn - else - brf_from_ocn = .false. - end if - if (masterproc) then - write(iulog,'(2a,l)') trim(subname), 'brf_from_ocn = ', brf_from_ocn - end if - - call NUOPC_CompAttributeGet(gcomp, name='flds_n2o', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ispresent .and. isset) then - read(cvalue,*) n2o_from_ocn - else - n2o_from_ocn = .false. - end if - if (masterproc) then - write(iulog,'(2a,l)') trim(subname), 'n2o_from_ocn = ', n2o_from_ocn - end if - - call NUOPC_CompAttributeGet(gcomp, name='flds_nh3', value=cvalue, ispresent=ispresent, isset=isset, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ispresent .and. isset) then - read(cvalue,*) nh3_from_ocn - else - nh3_from_ocn = .false. - end if - if (masterproc) then - write(iulog,'(2a,l)') trim(subname), 'nh3_from_ocn = ', nh3_from_ocn - end if - - !-------------------------------- - ! Export fields - !-------------------------------- - - if (masterproc) write(iulog,'(a)') trim(subname)//'export_fields ' - - call fldlist_add(fldsFrAtm_num, fldsFrAtm, trim(flds_scalar_name)) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_topo' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_z' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_u' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_v' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_u10m' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_v10m' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_tbot' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_ptem' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_shum' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_pbot' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_dens' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_pslv' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_o3' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainc' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainl' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowc' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowl' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hmat' ) !tht enthalpy - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hlat' ) !tht var.lat.ht.part - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_lwdn' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndr' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdr' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndf' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdf' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swnet' ) ! only diagnostic - - ! from atm - black carbon deposition fluxes (3) - ! (1) => bcphidry, (2) => bcphodry, (3) => bcphiwet - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_bcph', ungridded_lbound=1, ungridded_ubound=3) - - ! from atm - organic carbon deposition fluxes (3) - ! (1) => ocphidry, (2) => ocphodry, (3) => ocphiwet - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_ocph', ungridded_lbound=1, ungridded_ubound=3) - - ! from atm - wet dust deposition frluxes (4 sizes) - ! (1) => dstwet1, (2) => dstwet2, (3) => dstwet3, (4) => dstwet4 - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_dstwet', ungridded_lbound=1, ungridded_ubound=4) - - ! from atm - dry dust deposition frluxes (4 sizes) - ! (1) => dstdry1, (2) => dstdry2, (3) => dstdry3, (4) => dstdry4 - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_dstdry', ungridded_lbound=1, ungridded_ubound=4) - - call ESMF_LogWrite(subname//' export fields co2', ESMF_LOGMSG_INFO) - - ! from atm co2 fields - if (flds_co2a .or. flds_co2b .or. flds_co2c) then - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_co2prog' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_co2diag' ) - end if - - ! Nitrogen deposition fluxes - ! Assume that 2 fields are always sent as part of Faxa_ndep - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_ndep', ungridded_lbound=1, ungridded_ubound=2) - - ! lightning flash freq - if (atm_provides_lightning) then - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Sa_lightning') - end if - - ! Now advertise above export fields - if (masterproc) write(iulog,*) trim(subname)//' advertise export fields' - do n = 1,fldsFrAtm_num - call NUOPC_Advertise(exportState, standardName=fldsFrAtm(n)%stdname, & - TransferOfferGeomObject='will provide', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - enddo - - !----------------- - ! Import fields - !----------------- - - if (masterproc) write(iulog,'(a)') trim(subname)//' import fields ' - - call fldlist_add(fldsToAtm_num, fldsToAtm, trim(flds_scalar_name)) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_anidr' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_avsdf' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_anidf' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_avsdr' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_lfrac' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Si_ifrac' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ofrac' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_tref' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_qref' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_t' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_t' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_fv' ); call set_active_Sl_fv(.true.) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_ram1' ); call set_active_Sl_ram1(.true.) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_snowh' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Si_snowh' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ssq' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_re' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ustar' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_u10' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ugustOut') - call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_u10withGust') - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_taux' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_tauy' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lat' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_sen' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lwup' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_evap' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_goef' ) !+tht - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faox_evap' ) !+tht - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_hrof' ) !+tht - - ! dust fluxes from land (4 sizes) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_flxdst', ungridded_lbound=1, ungridded_ubound=4) - call set_active_Fall_flxdst1(.true.) - - ! co2 fields from land and ocean - if (flds_co2b .or. flds_co2c) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_fco2_lnd') - call set_active_Fall_fco2_lnd(.true.) - end if - if (flds_co2c) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fco2_ocn') - call set_active_Faoo_fco2_ocn(.true.) - end if - - ! dry deposition velocities from land - ALSO initialize drydep here - if (drydep_nflds > 0) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_ddvel', ungridded_lbound=1, ungridded_ubound=drydep_nflds) - end if - - ! MEGAN VOC emissions fluxes from land - if (megan_nflds > 0) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_voc', ungridded_lbound=1, ungridded_ubound=megan_nflds) - call set_active_Fall_flxvoc(.true.) - end if - - ! fire emissions fluxes from land - if (emis_nflds > 0) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_fire', ungridded_lbound=1, ungridded_ubound=emis_nflds) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_fztop') - call set_active_Fall_flxfire(.true.) - end if - - ! CARMA volumetric soil water from land - if (carma_fields /= ' ') then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sl_soilw') ! optional for carma - call set_active_Sl_soilw(.true.) ! check for carma - end if - - ! DMS source from ocean - if (dms_from_ocn) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fdms_ocn') ! optional - end if - - ! BRF source from ocean - if (brf_from_ocn) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fbrf_ocn') ! optional - end if - - ! N2O source from ocean - if (n2o_from_ocn) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fn2o_ocn') ! optional - end if - - ! NH3 source from ocean - if (nh3_from_ocn) then - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faoo_fnh3_ocn') ! optional - end if - - ! ------------------------------------------ - ! Now advertise above import fields - ! ------------------------------------------ - call ESMF_LogWrite(trim(subname)//' advertise import fields ', ESMF_LOGMSG_INFO) - do n = 1,fldsToAtm_num - call NUOPC_Advertise(importState, standardName=fldsToAtm(n)%stdname, & - TransferOfferGeomObject='will provide', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - enddo - - end subroutine advertise_fields - - !=============================================================================== - - subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, single_column, rc) - - use ESMF , only : ESMF_MeshGet, ESMF_StateGet - use ESMF , only : ESMF_FieldRegridGetArea,ESMF_FieldGet - use ppgrid , only : pcols, begchunk, endchunk - use phys_grid , only : get_area_all_p, get_ncols_p - - ! input/output variables - type(ESMF_GridComp) , intent(inout) :: gcomp - type(ESMF_Mesh) , intent(in) :: Emesh - character(len=*) , intent(in) :: flds_scalar_name - integer , intent(in) :: flds_scalar_num - logical , intent(in) :: single_column - integer , intent(out) :: rc - - ! local variables - type(ESMF_State) :: importState - type(ESMF_State) :: exportState - type(ESMF_Field) :: lfield - integer :: numOwnedElements - integer :: c,i,n,ncols - real(r8), allocatable :: mesh_areas(:) - real(r8), allocatable :: model_areas(:) - real(r8), allocatable :: area(:) - real(r8), pointer :: dataptr(:) - real(r8) :: max_mod2med_areacor - real(r8) :: max_med2mod_areacor - real(r8) :: min_mod2med_areacor - real(r8) :: min_med2mod_areacor - real(r8) :: max_mod2med_areacor_glob - real(r8) :: max_med2mod_areacor_glob - real(r8) :: min_mod2med_areacor_glob - real(r8) :: min_med2mod_areacor_glob - character(len=cl) :: cvalue - character(len=cl) :: mesh_atm - character(len=cl) :: mesh_lnd - character(len=cl) :: mesh_ocn - logical :: samegrid_atm_lnd_ocn - character(len=*), parameter :: subname='(atm_import_export:realize_fields)' - !--------------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - - call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call fldlist_realize( & - state=ExportState, & - fldList=fldsFrAtm, & - numflds=fldsFrAtm_num, & - flds_scalar_name=flds_scalar_name, & - flds_scalar_num=flds_scalar_num, & - tag=subname//':camExport',& - mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call fldlist_realize( & - state=importState, & - fldList=fldsToAtm, & - numflds=fldsToAtm_num, & - flds_scalar_name=flds_scalar_name, & - flds_scalar_num=flds_scalar_num, & - tag=subname//':camImport',& - mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Determine if atm/lnd/ocn are on the same grid - if so set area correction factors to 1 - call NUOPC_CompAttributeGet(gcomp, name='mesh_atm', value=mesh_atm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='mesh_lnd', value=mesh_lnd, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=mesh_ocn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - samegrid_atm_lnd_ocn = .false. - if ( trim(mesh_lnd) /= 'UNSET' .and. trim(mesh_atm) == trim(mesh_lnd) .and. & - trim(mesh_ocn) /= 'UNSET' .and. trim(mesh_atm) == trim(mesh_ocn)) then - samegrid_atm_lnd_ocn = .true. - elseif ( trim(mesh_lnd) == 'UNSET' .and. trim(mesh_atm) == trim(mesh_ocn)) then - samegrid_atm_lnd_ocn = .true. - elseif ( trim(mesh_ocn) == 'UNSET' .and. trim(mesh_atm) == trim(mesh_lnd)) then - samegrid_atm_lnd_ocn = .true. - end if - - ! allocate area correction factors - call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate (mod2med_areacor(numOwnedElements)) - allocate (med2mod_areacor(numOwnedElements)) - - if (single_column .or. samegrid_atm_lnd_ocn) then - - mod2med_areacor(:) = 1._r8 - med2mod_areacor(:) = 1._r8 - - else - - ! Determine areas for regridding - call ESMF_StateGet(exportState, itemName=trim(fldsFrAtm(2)%stdname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridGetArea(lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayPtr=dataptr, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(mesh_areas(numOwnedElements)) - mesh_areas(:) = dataptr(:) - - ! Determine model areas - allocate(model_areas(numOwnedElements)) - allocate(area(numOwnedElements)) - n = 0 - do c = begchunk, endchunk - ncols = get_ncols_p(c) - call get_area_all_p(c, ncols, area) - do i = 1,ncols - n = n + 1 - model_areas(n) = area(i) - end do - end do - deallocate(area) - - ! Determine flux correction factors (module variables) - do n = 1,numOwnedElements - mod2med_areacor(n) = model_areas(n) / mesh_areas(n) - med2mod_areacor(n) = 1._r8 / mod2med_areacor(n) - end do - deallocate(model_areas) - deallocate(mesh_areas) - - end if - - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) - call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) - call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) - - if (masterproc) then - write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'CAM' - write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'CAM' - end if - - call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) - - end subroutine realize_fields - - !=============================================================================== - - subroutine import_fields( gcomp, cam_in, restart_init, rc) - - ! ----------------------------------------------------- - ! Set field pointers in import state and - ! copy from field pointer to chunk array data structure - ! ----------------------------------------------------- - - use camsrfexch , only : cam_in_t - use phys_grid , only : get_ncols_p - use ppgrid , only : begchunk, endchunk - use shr_const_mod , only : shr_const_stebol - use co2_cycle , only : c_i, co2_readFlux_ocn, co2_readFlux_fuel - use co2_cycle , only : co2_transport, co2_time_interp_ocn, co2_time_interp_fuel - use co2_cycle , only : data_flux_ocn, data_flux_fuel - use physconst , only : mwco2 - use time_manager , only : is_first_step, get_nstep - use air_composition, only : compute_enthalpy_flux - - ! input/output variabes - type(ESMF_GridComp) :: gcomp - type(cam_in_t) , intent(inout) :: cam_in(begchunk:endchunk) - logical, optional , intent(in) :: restart_init - integer , intent(out) :: rc - - ! local variables - type(ESMF_State) :: importState - integer :: i,n,c,g, num ! indices - integer :: nstep - logical :: overwrite_flds - logical :: exists - logical :: exists_fco2_ocn - logical :: exists_fco2_lnd - character(len=128) :: fldname - real(r8), pointer :: fldptr2d(:,:) - real(r8), pointer :: fldptr1d(:) - real(r8), pointer :: fldptr_lat(:) - real(r8), pointer :: fldptr_lwup(:) - real(r8), pointer :: fldptr_avsdr(:) - real(r8), pointer :: fldptr_anidr(:) - real(r8), pointer :: fldptr_avsdf(:) - real(r8), pointer :: fldptr_anidf(:) - real(r8), pointer :: fldptr_tsurf(:) - real(r8), pointer :: fldptr_tocn(:) - real(r8), pointer :: fldptr_tref(:) - real(r8), pointer :: fldptr_qref(:) - real(r8), pointer :: fldptr_u10(:) - real(r8), pointer :: fldptr_snowhland(:) - real(r8), pointer :: fldptr_snowhice(:) - real(r8), pointer :: fldptr_ifrac(:) - real(r8), pointer :: fldptr_ofrac(:) - real(r8), pointer :: fldptr_lfrac(:) - real(r8), pointer :: fldptr_taux(:) - real(r8), pointer :: fldptr_tauy(:) - real(r8), pointer :: fldptr_sen(:) - real(r8), pointer :: fldptr_evap(:) - real(r8), pointer :: fldptr_evop(:)!+tht - real(r8), pointer :: fldptr_hrof(:)!+tht - real(r8), pointer :: fldptr_goef(:)!+tht - logical, save :: first_time = .true. - character(len=*), parameter :: subname='(atm_import_export:import_fields)' - !--------------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - ! Get import state - call NUOPC_ModelGet(gcomp, importState=importState, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! don't overwrite fields if invoked during the initialization phase - ! of a 'continue' or 'branch' run type with data from .rs file - overwrite_flds = .true. - if (present(restart_init)) overwrite_flds = .not. restart_init - - !-------------------------- - ! Required atmosphere input fields - !-------------------------- - - if (overwrite_flds) then - call state_getfldptr(importState, 'Faxx_taux', fldptr=fldptr_taux, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Faxx_tauy', fldptr=fldptr_tauy, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Faxx_sen' , fldptr=fldptr_sen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Faxx_evap', fldptr=fldptr_evap, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return -!+tht - ! ocean-point hevap (compute_enthalpy=T) - call state_getfldptr(importState, 'Faox_evap', fldptr=fldptr_evop, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! enthalpy of runoff(compute_enthalpy=T) - call state_getfldptr(importState, 'Faxx_hrof', fldptr=fldptr_hrof, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! ocean mat.enth.flx to atm (back compatibility) - call state_getfldptr(importState, 'Faxx_goef', fldptr=fldptr_goef,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return -!-tht - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%wsx(i) = -fldptr_taux(g) * med2mod_areacor(g) - cam_in(c)%wsy(i) = -fldptr_tauy(g) * med2mod_areacor(g) - cam_in(c)%shf(i) = -fldptr_sen(g) * med2mod_areacor(g) - cam_in(c)%cflx(i,1) = -fldptr_evap(g) * med2mod_areacor(g) -!+tht - ! add sensible heat correction only if not conserving energy - if(.not.compute_enthalpy_flux) & - cam_in(c)%shf(i) = cam_in(c)%shf(i)-fldptr_goef(g)*med2mod_areacor(g) - ! hevap over ocean - cam_in(c)%evap_ocn(i) = -fldptr_evop(g) * med2mod_areacor(g) - cam_in(c)%hrof (i) = -fldptr_hrof(g) * med2mod_areacor(g) -!-tht - g = g + 1 - end do - end do - end if ! end of overwrite_flds - - call state_getfldptr(importState, 'Faxx_lat', fldptr=fldptr_lat, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Faxx_lwup', fldptr=fldptr_lwup, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_avsdr', fldptr=fldptr_avsdr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_anidr', fldptr=fldptr_anidr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_avsdf', fldptr=fldptr_avsdf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_anidf', fldptr=fldptr_anidf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_t', fldptr=fldptr_tsurf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'So_t', fldptr=fldptr_tocn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sl_snowh', fldptr=fldptr_snowhland, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Si_snowh', fldptr=fldptr_snowhice, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_tref', fldptr=fldptr_tref, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_qref', fldptr=fldptr_qref, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_u10', fldptr=fldptr_u10, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Si_ifrac', fldptr=fldptr_ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'So_ofrac', fldptr=fldptr_ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sl_lfrac', fldptr=fldptr_lfrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Only do area correction on fluxes - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%lhf(i) = -fldptr_lat(g) * med2mod_areacor(g) - cam_in(c)%lwup(i) = -fldptr_lwup(g) * med2mod_areacor(g) - cam_in(c)%asdir(i) = fldptr_avsdr(g) - cam_in(c)%aldir(i) = fldptr_anidr(g) - cam_in(c)%asdif(i) = fldptr_avsdf(g) - cam_in(c)%aldif(i) = fldptr_anidf(g) - cam_in(c)%ts(i) = fldptr_tsurf(g) - cam_in(c)%sst(i) = fldptr_tocn(g) - cam_in(c)%tref(i) = fldptr_tref(g) - cam_in(c)%qref(i) = fldptr_qref(g) - cam_in(c)%u10(i) = fldptr_u10(g) - cam_in(c)%snowhland(i) = fldptr_snowhland(g) - cam_in(c)%snowhice(i) = fldptr_snowhice(g) - cam_in(c)%icefrac(i) = fldptr_ifrac(g) - cam_in(c)%ocnfrac(i) = fldptr_ofrac(g) - cam_in(c)%landfrac(i) = fldptr_lfrac(g) - g = g + 1 - end do - end do - - ! Optional fields - - call state_getfldptr(importState, 'Sl_ram1', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - if ( associated(cam_in(c)%ram1) ) then - do i = 1, get_ncols_p(c) - cam_in(c)%ram1(i) = fldptr1d(g) - g = g + 1 - end do - end if - end do - end if - - call state_getfldptr(importState, 'Sl_fv', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - if ( associated(cam_in(c)%fv) ) then - do i = 1,get_ncols_p(c) - cam_in(c)%fv(i) = fldptr1d(g) - g = g + 1 - end do - end if - end do - end if - - ! For CARMA - soil water from land - call state_getfldptr(importState, 'Sl_soilw', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - if ( associated(cam_in(c)%soilw)) then - do i = 1,get_ncols_p(c) - cam_in(c)%soilw(i) = fldptr1d(g) - g = g+1 - end do - end if - end do - end if - - ! dry deposition fluxes from land - call state_getfldptr(importState, 'Fall_flxdst', fldptr2d=fldptr2d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - if ( associated(cam_in(c)%dstflx) ) then - do i = 1,get_ncols_p(c) - do n = 1, size(fldptr2d, dim=1) - cam_in(c)%dstflx(i,n) = fldptr2d(n,g) * med2mod_areacor(g) - end do - g = g + 1 - end do - end if - end do - end if - - ! MEGAN VOC emis fluxes from land - call state_getfldptr(importState, 'Fall_voc', fldptr2d=fldptr2d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c=begchunk,endchunk - if ( associated(cam_in(c)%meganflx) ) then - do i = 1,get_ncols_p(c) - do n = 1, size(fldptr2d, dim=1) - cam_in(c)%meganflx(i,n) = fldptr2d(n,g) * med2mod_areacor(g) - end do - g = g + 1 - end do - end if - end do - end if - - ! fire emission fluxes from land - call state_getfldptr(importState, 'Fall_fire', fldptr2d=fldptr2d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - if ( associated(cam_in(c)%fireflx) .and. associated(cam_in(c)%fireztop) ) then - do i = 1,get_ncols_p(c) - do n = 1, size(fldptr2d, dim=1) - cam_in(c)%fireflx(i,n) = fldptr2d(n,g) * med2mod_areacor(g) - end do - g = g + 1 - end do - end if - end do - end if - call state_getfldptr(importState, 'Sl_fztop', fldptr=fldptr1d, exists=exists, rc=rc) - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fireztop(i) = fldptr1d(g) - g = g + 1 - end do - end do - end if - - ! dry dep velocities - call state_getfldptr(importState, 'Sl_ddvel', fldptr2d=fldptr2d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - do n = 1, size(fldptr2d, dim=1) - cam_in(c)%depvel(i,n) = fldptr2d(n,g) - end do - g = g + 1 - end do - end do - end if - - ! fields needed to calculate water isotopes to ocean evaporation processes - call state_getfldptr(importState, 'So_ustar', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%ustar(i) = fldptr1d(g) - g = g + 1 - end do - end do - end if - call state_getfldptr(importState, 'So_re', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%re(i)= fldptr1d(g) - g = g + 1 - end do - end do - end if - call state_getfldptr(importState, 'So_ssq', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%ssq(i) = fldptr1d(g) - g = g + 1 - end do - end do - end if - - call state_getfldptr(importState, 'So_ugustOut', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%ugustOut(i) = fldptr1d(g) - g = g + 1 - end do - end do - end if - - call state_getfldptr(importState, 'So_u10withGust', fldptr=fldptr1d, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%u10withGusts(i) = fldptr1d(g) - g = g + 1 - end do - end do - end if - - ! bgc scenarios - call state_getfldptr(importState, 'Fall_fco2_lnd', fldptr=fldptr1d, exists=exists_fco2_lnd, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists_fco2_lnd) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fco2_lnd(i) = -fldptr1d(g) * med2mod_areacor(g) - g = g + 1 - end do - end do - end if - call state_getfldptr(importState, 'Faoo_fco2_ocn', fldptr=fldptr1d, exists=exists_fco2_ocn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists_fco2_ocn) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fco2_ocn(i) = -fldptr1d(g) * med2mod_areacor(g) - g = g + 1 - end do - end do - else - ! Consistency check - if (co2_readFlux_ocn) then - call shr_sys_abort(subname // ':: co2_readFlux_ocn and x2a_Faoo_fco2_ocn cannot both be active') - end if - end if - - call state_getfldptr(importState, 'Faoo_fdms_ocn', fldptr=fldptr1d, exists=exists, rc=rc) - if (exists) then - ! Ideally what should happen below is that - ! cam_in%cflx(icol,) should be set directly from - ! fldptr1d. However, the code initializes the chemistry - ! consituents surface fluxes (i.e.cam_in%cflx(:,:)) to zero in - ! the routine in mozart/chemistry.F90 at the start of every - ! time step. Introducing cam_in(c)%fdms below stores this - ! information until it can be updated in aero_model.F90 when - ! oslo-aero is used. - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fdms(i) = -fldptr1d(g) * med2mod_areacor(g) - g = g + 1 - end do - end do - end if - - call state_getfldptr(importState, 'Faoo_fbrf_ocn', fldptr=fldptr1d, exists=exists, rc=rc) - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fbrf(i) = -fldptr1d(g) * med2mod_areacor(g) - g = g + 1 - end do - end do - end if - - call state_getfldptr(importState, 'Faoo_fn2o_ocn', fldptr=fldptr1d, exists=exists, rc=rc) - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fn2o_ocn(i) = -fldptr1d(g) * med2mod_areacor(g) - g = g + 1 - end do - end do - end if - - call state_getfldptr(importState, 'Faoo_fnh3_ocn', fldptr=fldptr1d, exists=exists, rc=rc) - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - cam_in(c)%fnh3_ocn(i) = -fldptr1d(g) * med2mod_areacor(g) - g = g + 1 - end do - end do - end if - - ! ----------------------------------- - ! Get total co2 flux from components, - ! ----------------------------------- - - ! Note - co2_transport determines if cam_in(c)%cflx(i,c_i(1:4)) is allocated - - if (co2_transport() .and. overwrite_flds) then - - ! Interpolate in time for flux data read in - if (co2_readFlux_ocn) then - call co2_time_interp_ocn - end if - if (co2_readFlux_fuel) then - call co2_time_interp_fuel - end if - - ! from ocn : data read in or from coupler or zero - ! from fuel: data read in or zero - ! from lnd : through coupler or zero - ! all co2 fluxes in unit kgCO2/m2/s - - do c=begchunk,endchunk - do i=1, get_ncols_p(c) - - ! co2 flux from ocn - if (exists_fco2_ocn) then - cam_in(c)%cflx(i,c_i(1)) = cam_in(c)%fco2_ocn(i) - else if (co2_readFlux_ocn) then - ! convert from molesCO2/m2/s to kgCO2/m2/s - cam_in(c)%cflx(i,c_i(1)) = & - -data_flux_ocn%co2flx(i,c)*(1._r8- cam_in(c)%landfrac(i))*mwco2*1.0e-3_r8 - else - cam_in(c)%cflx(i,c_i(1)) = 0._r8 - end if - - ! co2 flux from fossil fuel - if (co2_readFlux_fuel) then - cam_in(c)%cflx(i,c_i(2)) = data_flux_fuel%co2flx(i,c) - else - cam_in(c)%cflx(i,c_i(2)) = 0._r8 - end if - - ! co2 flux from land (cpl already multiplies flux by land fraction) - if (exists_fco2_lnd) then - cam_in(c)%cflx(i,c_i(3)) = cam_in(c)%fco2_lnd(i) - else - cam_in(c)%cflx(i,c_i(3)) = 0._r8 - end if - - ! merged co2 flux - cam_in(c)%cflx(i,c_i(4)) = cam_in(c)%cflx(i,c_i(1)) + cam_in(c)%cflx(i,c_i(2)) + cam_in(c)%cflx(i,c_i(3)) - end do - end do - end if - - ! if first step, determine longwave up flux from the surface temperature - if (first_time) then - if (is_first_step()) then - do c=begchunk, endchunk - do i=1, get_ncols_p(c) - cam_in(c)%lwup(i) = shr_const_stebol*(cam_in(c)%ts(i)**4) - end do - end do - end if - first_time = .false. - end if - - end subroutine import_fields - - !=============================================================================== - - subroutine export_fields( gcomp, model_mesh, model_clock, cam_out, rc) - - ! ----------------------------------------------------- - ! Set field pointers in export set - ! Copy from chunk array data structure into state fldptr - ! ----------------------------------------------------- - - use camsrfexch , only : cam_out_t - use phys_grid , only : get_ncols_p - use ppgrid , only : begchunk, endchunk - use time_manager , only : is_first_step, get_nstep - use spmd_utils , only : masterproc - - !------------------------------- - ! Pack the export state - !------------------------------- - - ! input/output variables - type(ESMF_GridComp) :: gcomp - type(ESMF_Mesh) , intent(in) :: model_mesh - type(ESMF_Clock), intent(in) :: model_clock - type(cam_out_t) , intent(inout) :: cam_out(begchunk:endchunk) - integer , intent(out) :: rc - - ! local variables - type(ESMF_State) :: exportState - type(ESMF_State) :: importState - type(ESMF_Clock) :: clock - integer :: i,m,c,n,g ! indices - integer :: nstep - logical :: exists - real(r8) :: wind_dir - ! 2d output pointers - real(r8), pointer :: fldptr_ndep(:,:) - real(r8), pointer :: fldptr_bcph(:,:) , fldptr_ocph(:,:) - real(r8), pointer :: fldptr_dstwet(:,:), fldptr_dstdry(:,:) - ! 1d output pointers - real(r8), pointer :: fldptr_soll(:) , fldptr_sols(:) - real(r8), pointer :: fldptr_solld(:) , fldptr_solsd(:) - real(r8), pointer :: fldptr_snowc(:) , fldptr_snowl(:) - real(r8), pointer :: fldptr_hmat (:) , fldptr_hlat (:)!+tht enthalpy - real(r8), pointer :: fldptr_rainc(:) , fldptr_rainl(:) - real(r8), pointer :: fldptr_lwdn(:) , fldptr_swnet(:) - real(r8), pointer :: fldptr_topo(:) , fldptr_zbot(:) - real(r8), pointer :: fldptr_ubot(:) , fldptr_vbot(:) - real(r8), pointer :: fldptr_pbot(:) , fldptr_tbot(:) - real(r8), pointer :: fldptr_shum(:) , fldptr_dens(:) - real(r8), pointer :: fldptr_ptem(:) , fldptr_pslv(:) - real(r8), pointer :: fldptr_co2prog(:) , fldptr_co2diag(:) - real(r8), pointer :: fldptr_ozone(:) - real(r8), pointer :: fldptr_lght(:) - real(r8), pointer :: fldptr_u10m(:) - real(r8), pointer :: fldptr_v10m(:) - ! import state pointer - real(r8), pointer :: fldptr_wind10m(:) - character(len=*), parameter :: subname='(atm_import_export:export_fields)' - !--------------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - ! Get export state - call NUOPC_ModelGet(gcomp, exportState=exportState, importState=importState, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! required export state variables - call state_getfldptr(exportState, 'Sa_topo', fldptr=fldptr_topo, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_z' , fldptr=fldptr_zbot, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_u' , fldptr=fldptr_ubot, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_v' , fldptr=fldptr_vbot, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_tbot', fldptr=fldptr_tbot, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_pbot', fldptr=fldptr_pbot, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_shum', fldptr=fldptr_shum, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_dens', fldptr=fldptr_dens, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_ptem', fldptr=fldptr_ptem, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_pslv', fldptr=fldptr_pslv, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_u10m', fldptr=fldptr_u10m, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sa_v10m', fldptr=fldptr_v10m, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(importState, 'Sx_u10' , fldptr=fldptr_wind10m, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! The 10m wind speed over ocean obtained from the atm/ocn flux computation in the mediator - ! and is merged with the 10m wind speed obtained from the land ice ice components - ! This computation for 10m wind speed will have used the bottom level winds from cam sent - ! at the previous time - ! The decomposition of the 10m wind into its zonal and meridional components is done using - ! the bottom level u and v fields from cam (at the current time) - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_topo(g) = cam_out(c)%topo(i) - fldptr_zbot(g) = cam_out(c)%zbot(i) - fldptr_ubot(g) = cam_out(c)%ubot(i) - fldptr_vbot(g) = cam_out(c)%vbot(i) - fldptr_pbot(g) = cam_out(c)%pbot(i) - fldptr_tbot(g) = cam_out(c)%tbot(i) - fldptr_shum(g) = cam_out(c)%qbot(i,1) - fldptr_dens(g) = cam_out(c)%rho(i) - fldptr_ptem(g) = cam_out(c)%thbot(i) - fldptr_pslv(g) = cam_out(c)%psl(i) - wind_dir = cam_out(c)%wind_dir(i) - fldptr_u10m(g) = fldptr_wind10m(g)*cos(wind_dir) - fldptr_v10m(g) = fldptr_wind10m(g)*sin(wind_dir) - g = g + 1 - end do - end do - - ! required export flux variables - call state_getfldptr(exportState, 'Faxa_swnet', fldptr=fldptr_swnet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_lwdn' , fldptr=fldptr_lwdn , rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_rainc', fldptr=fldptr_rainc, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_rainl', fldptr=fldptr_rainl, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_snowc', fldptr=fldptr_snowc, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_snowl', fldptr=fldptr_snowl, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_swndr', fldptr=fldptr_soll, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_swvdr', fldptr=fldptr_sols, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_swndf', fldptr=fldptr_solld, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_swvdf', fldptr=fldptr_solsd, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_hmat' , fldptr=fldptr_hmat , rc=rc) !tht enthalpy - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_hlat' , fldptr=fldptr_hlat , rc=rc) !tht var.lat.ht.part - if (ChkErr(rc,__LINE__,u_FILE_u)) return - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_lwdn(g) = cam_out(c)%flwds(i) * mod2med_areacor(g) - fldptr_swnet(g) = cam_out(c)%netsw(i) * mod2med_areacor(g) - fldptr_snowc(g) = cam_out(c)%precsc(i)*1000._r8 * mod2med_areacor(g) - fldptr_snowl(g) = cam_out(c)%precsl(i)*1000._r8 * mod2med_areacor(g) - fldptr_rainc(g) = (cam_out(c)%precc(i) - cam_out(c)%precsc(i))*1000._r8 * mod2med_areacor(g) - fldptr_rainl(g) = (cam_out(c)%precl(i) - cam_out(c)%precsl(i))*1000._r8 * mod2med_areacor(g) - fldptr_soll(g) = cam_out(c)%soll(i) * mod2med_areacor(g) - fldptr_sols(g) = cam_out(c)%sols(i) * mod2med_areacor(g) - fldptr_solld(g) = cam_out(c)%solld(i) * mod2med_areacor(g) - fldptr_solsd(g) = cam_out(c)%solsd(i) * mod2med_areacor(g) - fldptr_hmat (g) = cam_out(c)%hmat(i) * mod2med_areacor(g) !+tht enthalpy - fldptr_hlat (g) = cam_out(c)%hlat(i) * mod2med_areacor(g) !+tht var.lat.ht.part - g = g + 1 - end do - end do - - ! aerosol deposition fluxes - call state_getfldptr(exportState, 'Faxa_bcph', fldptr2d=fldptr_bcph, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_ocph', fldptr2d=fldptr_ocph, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_dstdry', fldptr2d=fldptr_dstdry, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Faxa_dstwet', fldptr2d=fldptr_dstwet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! (1) => bcphidry, (2) => bcphodry, (3) => bcphiwet - ! (1) => ocphidry, (2) => ocphodry, (3) => ocphiwet - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_bcph(1,g) = cam_out(c)%bcphidry(i) * mod2med_areacor(g) - fldptr_bcph(2,g) = cam_out(c)%bcphodry(i) * mod2med_areacor(g) - fldptr_bcph(3,g) = cam_out(c)%bcphiwet(i) * mod2med_areacor(g) - fldptr_ocph(1,g) = cam_out(c)%ocphidry(i) * mod2med_areacor(g) - fldptr_ocph(2,g) = cam_out(c)%ocphodry(i) * mod2med_areacor(g) - fldptr_ocph(3,g) = cam_out(c)%ocphiwet(i) * mod2med_areacor(g) - fldptr_dstdry(1,g) = cam_out(c)%dstdry1(i) * mod2med_areacor(g) - fldptr_dstdry(2,g) = cam_out(c)%dstdry2(i) * mod2med_areacor(g) - fldptr_dstdry(3,g) = cam_out(c)%dstdry3(i) * mod2med_areacor(g) - fldptr_dstdry(4,g) = cam_out(c)%dstdry4(i) * mod2med_areacor(g) - fldptr_dstwet(1,g) = cam_out(c)%dstwet1(i) * mod2med_areacor(g) - fldptr_dstwet(2,g) = cam_out(c)%dstwet2(i) * mod2med_areacor(g) - fldptr_dstwet(3,g) = cam_out(c)%dstwet3(i) * mod2med_areacor(g) - fldptr_dstwet(4,g) = cam_out(c)%dstwet4(i) * mod2med_areacor(g) - g = g + 1 - end do - end do - - call state_getfldptr(exportState, 'Sa_o3', fldptr=fldptr_ozone, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_ozone(g) = cam_out(c)%ozone(i) ! atm ozone - g = g + 1 - end do - end do - end if - - call state_getfldptr(exportState, 'Sa_lightning', fldptr=fldptr_lght, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_lght(g) = cam_out(c)%lightning_flash_freq(i) ! cloud-to-ground lightning flash frequency (/min) - g = g + 1 - end do - end do - end if - - call state_getfldptr(exportState, 'Sa_co2prog', fldptr=fldptr_co2prog, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_co2prog(g) = cam_out(c)%co2prog(i) ! atm prognostic co2 - g = g + 1 - end do - end do - end if - - call state_getfldptr(exportState, 'Sa_co2diag', fldptr=fldptr_co2diag, exists=exists, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (exists) then - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_co2diag(g) = cam_out(c)%co2diag(i) ! atm diagnostic co2 - g = g + 1 - end do - end do - end if - - call state_getfldptr(exportState, 'Faxa_ndep', fldptr2d=fldptr_ndep, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr_ndep(:,:) = 0._r8 - - if (.not. (simple_phys .or. aqua_planet)) then - - ! The ndep_stream_nl namelist group is read in stream_ndep_init. This sets whether - ! or not the stream will be used. - if (.not. stream_ndep_is_initialized) then - call stream_ndep_init(model_mesh, model_clock, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - stream_ndep_is_initialized = .true. - end if - - if (ndep_stream_active.or.chem_has_ndep_flx) then - - ! Nitrogen dep fluxes are obtained from the ndep input stream if input data is available - ! otherwise computed by chemistry - if (ndep_stream_active) then - - ! get ndep fluxes from the stream - call stream_ndep_interp(cam_out, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - end if - - g = 1 - do c = begchunk,endchunk - do i = 1,get_ncols_p(c) - fldptr_ndep(1,g) = cam_out(c)%nhx_nitrogen_flx(i) * mod2med_areacor(g) - fldptr_ndep(2,g) = cam_out(c)%noy_nitrogen_flx(i) * mod2med_areacor(g) - g = g + 1 - end do - end do - - end if - - end if - - end subroutine export_fields - - !=============================================================================== - - subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) - - ! input/otuput variables - integer , intent(inout) :: num - type(fldlist_type) , intent(inout) :: fldlist(:) - character(len=*) , intent(in) :: stdname - integer, optional , intent(in) :: ungridded_lbound - integer, optional , intent(in) :: ungridded_ubound - - ! local variables - character(len=*), parameter :: subname='(atm_import_export:fldlist_add)' - !------------------------------------------------------------------------------- - - ! Set up a list of field information - - num = num + 1 - if (num > fldsMax) then - call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & - ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) - return - endif - fldlist(num)%stdname = trim(stdname) - - if (present(ungridded_lbound) .and. present(ungridded_ubound)) then - fldlist(num)%ungridded_lbound = ungridded_lbound - fldlist(num)%ungridded_ubound = ungridded_ubound - end if - - end subroutine fldlist_add - - !=============================================================================== - - subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) - - use NUOPC , only : NUOPC_IsConnected, NUOPC_Realize - use ESMF , only : ESMF_MeshLoc_Element, ESMF_FieldCreate, ESMF_TYPEKIND_R8 - use ESMF , only : ESMF_MAXSTR, ESMF_Field, ESMF_State, ESMF_Mesh, ESMF_StateRemove - use ESMF , only : ESMF_LogFoundError, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LOGERR_PASSTHRU - - ! input/output variables - type(ESMF_State) , intent(inout) :: state - type(fldlist_type) , intent(in) :: fldList(:) - integer , intent(in) :: numflds - character(len=*) , intent(in) :: flds_scalar_name - integer , intent(in) :: flds_scalar_num - character(len=*) , intent(in) :: tag - type(ESMF_Mesh) , intent(in) :: mesh - integer , intent(inout) :: rc - - ! local variables - integer :: n - type(ESMF_Field) :: field - character(len=80) :: stdname - character(CL) :: msg - character(len=*),parameter :: subname='(atm_import_export:fldlist_realize)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - do n = 1, numflds - stdname = fldList(n)%stdname - if (NUOPC_IsConnected(state, fieldName=stdname)) then - if (stdname == trim(flds_scalar_name)) then - if (masterproc) then - write(iulog,'(a)') trim(subname)//trim(tag)//" field = "//trim(stdname)//" is connected on root pe" - end if - ! Create the scalar field - call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - else - ! Create the field - if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then - field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & - ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & - ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & - gridToFieldMap=(/2/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (masterproc) then - write(iulog,'(a,i8,a,i8)') trim(subname)// trim(tag)//" Field = "//trim(stdname)// & - " is connected using mesh with lbound ", fldlist(n)%ungridded_lbound,& - " and with ubound ",fldlist(n)%ungridded_ubound - end if - else - field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - if (masterproc) then - write(iulog,'(a)') trim(subname)// trim(tag)//" Field = "//trim(stdname)// " is connected using mesh " - end if - end if - endif - - ! NOW call NUOPC_Realize - call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - else - if (stdname /= trim(flds_scalar_name)) then - if (masterproc) then - write(iulog,'(a)')trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is not connected" - end if - call ESMF_StateRemove(state, (/stdname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - end if - end if - end do - - contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) - ! ---------------------------------------------- - ! create a field with scalar data on the root pe - ! ---------------------------------------------- - - use ESMF, only : ESMF_Field, ESMF_DistGrid, ESMF_Grid - use ESMF, only : ESMF_DistGridCreate, ESMF_GridCreate, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU - use ESMF, only : ESMF_FieldCreate, ESMF_GridCreate, ESMF_TYPEKIND_R8 - - ! input/output variables - type(ESMF_Field) , intent(inout) :: field - character(len=*) , intent(in) :: flds_scalar_name - integer , intent(in) :: flds_scalar_num - integer , intent(inout) :: rc - - ! local variables - type(ESMF_Distgrid) :: distgrid - type(ESMF_Grid) :: grid - character(len=*), parameter :: subname='(atm_import_export:SetScalarField)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - ! create a DistGrid with a single index space element, which gets mapped onto DE 0. - distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - - grid = ESMF_GridCreate(distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - - field = ESMF_FieldCreate(name=trim(flds_scalar_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & - ungriddedLBound=(/1/), ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - - end subroutine SetScalarField - - end subroutine fldlist_realize - - !=============================================================================== - subroutine state_getfldptr(State, fldname, fldptr, fldptr2d, exists, rc) - - ! ---------------------------------------------- - ! Get pointer to a state field - ! ---------------------------------------------- - - use ESMF , only : ESMF_State, ESMF_Field, ESMF_Mesh, ESMF_FieldStatus_Flag - use ESMF , only : ESMF_StateGet, ESMF_FieldGet, ESMF_MeshGet - use ESMF , only : ESMF_FIELDSTATUS_COMPLETE, ESMF_FAILURE - - ! input/output variables - type(ESMF_State) , intent(in) :: State - character(len=*) , intent(in) :: fldname - real(R8), optional, pointer :: fldptr(:) - real(R8), optional, pointer :: fldptr2d(:,:) - logical , optional, intent(out) :: exists - integer , intent(out) :: rc - - ! local variables - type(ESMF_FieldStatus_Flag) :: status - type(ESMF_StateItem_Flag) :: itemFlag - type(ESMF_Field) :: lfield - type(ESMF_Mesh) :: lmesh - integer :: nnodes, nelements - logical :: lexists - character(len=*), parameter :: subname='(atm_import_export:state_getfldptr)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - lexists = .true. - - ! Determine if field with name fldname exists in state - if (present(exists)) then - call ESMF_StateGet(state, trim(fldname), itemFlag, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (itemflag == ESMF_STATEITEM_NOTFOUND) then - lexists = .false. - end if - exists = lexists - end if - - if (lexists) then - call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (present(fldptr)) then - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else if (present(fldptr2d)) then - call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - end if - - end subroutine state_getfldptr - -end module atm_import_export From b9a462b341372537b0bccf91d02a553444d51593 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 16 Aug 2025 23:16:18 +0200 Subject: [PATCH 06/78] refactored air_composition --- .../camnor_phys/physics/air_composition.F90 | 1287 ----------------- src/utils/air_composition.F90 | 97 +- 2 files changed, 85 insertions(+), 1299 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/air_composition.F90 diff --git a/src/physics/camnor_phys/physics/air_composition.F90 b/src/physics/camnor_phys/physics/air_composition.F90 deleted file mode 100644 index 6a32020b10..0000000000 --- a/src/physics/camnor_phys/physics/air_composition.F90 +++ /dev/null @@ -1,1287 +0,0 @@ -! air_composition module defines major species of the atmosphere and manages -! the physical properties that are dependent on the composition of air -module air_composition - - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_abortutils, only: endrun - - implicit none - private - save - - public :: air_composition_readnl - public :: air_composition_init - public :: dry_air_composition_update - public :: water_composition_update - - ! get_cp_dry: (generalized) heat capacity for dry air - public :: get_cp_dry - ! get_cp: (generalized) heat capacity - public :: get_cp - ! get_R_dry: (generalized) dry air gas constant - public :: get_R_dry - ! get_R: Compute generalized R - public :: get_R - ! get_mbarv: molecular weight of dry air - public :: get_mbarv - - logical, public :: compute_enthalpy_flux - ! - ! for book keeping of enthalpy variables in physics buffer - ! - integer, parameter, public :: num_enthalpy_vars = 4 ! index for enthalpy flux associated with liquid precipitation - integer, parameter, public :: hliq_idx = 1 ! index for enthalpy flux associated with liquid precipitation - integer, parameter, public :: hice_idx = 2 ! index for enthalpy flux associated with frozen precipiation - integer, parameter, public :: fliq_idx = 3 ! index for flux of liquid precipitation - integer, parameter, public :: fice_idx = 4 ! index for flux of frozen precipitation - - private :: air_species_info - - integer, parameter :: unseti = -HUGE(1) - real(r8), parameter :: unsetr = HUGE(1.0_r8) - - ! composition of air - ! - integer, parameter :: num_names_max = 20 ! Should match namelist definition - character(len=6) :: dry_air_species(num_names_max) - character(len=6) :: water_species_in_air(num_names_max) - - integer, protected, public :: dry_air_species_num - integer, protected, public :: water_species_in_air_num - - ! Thermodynamic variables - integer, protected, public :: thermodynamic_active_species_num = unseti - integer, allocatable, protected, public :: thermodynamic_active_species_idx(:) - integer, allocatable, public :: thermodynamic_active_species_idx_dycore(:) - real(r8), allocatable, protected, public :: thermodynamic_active_species_cp(:) - real(r8), allocatable, protected, public :: thermodynamic_active_species_cv(:) - real(r8), allocatable, protected, public :: thermodynamic_active_species_R(:) - ! thermodynamic_active_species_mwi: inverse molecular weights dry air - real(r8), allocatable, protected, public :: thermodynamic_active_species_mwi(:) - ! thermodynamic_active_species_kv: molecular diffusion - real(r8), allocatable, protected, public :: thermodynamic_active_species_kv(:) - ! thermodynamic_active_species_kc: thermal conductivity - real(r8), allocatable, protected, public :: thermodynamic_active_species_kc(:) - ! - ! for energy computations liquid and ice species need to be identified - ! - ! thermodynamic_active_species_liq_num: number of liquid water species - integer, protected, public :: thermodynamic_active_species_liq_num = unseti - ! thermodynamic_active_species_ice_num: number of frozen water species - integer, protected, public :: thermodynamic_active_species_ice_num = unseti - ! thermodynamic_active_species_liq_idx: index of liquid water species - integer, allocatable, protected, public :: thermodynamic_active_species_liq_idx(:) - ! thermodynamic_active_species_liq_idx_dycore: index of liquid water species - integer, allocatable, public :: thermodynamic_active_species_liq_idx_dycore(:) - ! thermodynamic_active_species_ice_idx: index of ice water species - integer, allocatable, protected, public :: thermodynamic_active_species_ice_idx(:) - ! thermodynamic_active_species_ice_idx_dycore: index of ice water species - integer, allocatable, public :: thermodynamic_active_species_ice_idx_dycore(:) - ! enthalpy_reference_state: choices: 'ice', 'liq', 'vap' !tht:'wv'->'vap' (stick to three characters, 'water' is presumably implicit in all of these...) - character(len=3), public, protected :: enthalpy_reference_state = 'ice' - - integer, protected, public :: wv_idx = -1 ! Water vapor index - - !------------- Variables for consistent themodynamics -------------------- - ! - - ! standard dry air (constant composition) - real(r8), public, protected :: mmro2 = unsetr ! Mass mixing ratio of O2 - real(r8), public, protected :: mmrn2 = unsetr ! Mass mixing ratio of N2 - real(r8), public, protected :: o2_mwi = unsetr ! Inverse mol. weight of O2 - real(r8), public, protected :: n2_mwi = unsetr ! Inverse mol. weight of N2 - real(r8), public, protected :: mbar = unsetr ! Mean mass at mid level - -!tht: explicitly declare reference enthalpies and temperatures for atmosphere and ocean - real(r8), public, protected :: t00o ! Water enthalpy reference temperature, ocean (K) - real(r8), public, protected :: t00a ! Water enthalpy reference temperature, atmosphere (K) - real(r8), public, protected :: h00o ! Material enthalpy zero, liquid reference state, ocean water (J/kg) - real(r8), public, protected :: h00a ! Material enthalpy zero, liquid reference state, atmos water (J/kg) - real(r8), public, protected :: h00a_vap ! Material enthalpy zero, vapor reference state, atmos (J/kg) - real(r8), public, protected :: h00a_ice ! Material enthalpy zero, vapor reference state, atmos (J/kg) - - ! coefficients in expressions for molecular diffusion coefficients - ! kv1,..,kv3 are coefficients for kmvis calculation - ! kc1,..,kc3 are coefficients for kmcnd calculation - ! Liu, H.-L., et al. (2010), Thermosphere extension of the Whole Atmosphere Community Climate Model, - ! J. Geophys. Res., 115, A12302, doi:10.1029/2010JA015586. - real(r8), public, parameter :: kv1 = 4.03_r8 * 1.e-7_r8 - real(r8), public, parameter :: kv2 = 3.42_r8 * 1.e-7_r8 - real(r8), public, parameter :: kv3 = 3.9_r8 * 1.e-7_r8 - real(r8), public, parameter :: kc1 = 56._r8 * 1.e-5_r8 - real(r8), public, parameter :: kc2 = 56._r8 * 1.e-5_r8 - real(r8), public, parameter :: kc3 = 75.9_r8 * 1.e-5_r8 - - real(r8), public, parameter :: kv_temp_exp = 0.69_r8 - real(r8), public, parameter :: kc_temp_exp = 0.69_r8 - - ! cpairv: composition dependent specific heat at constant pressure - real(r8), public, protected, allocatable :: cpairv(:,:,:) - ! rairv: composition dependent gas "constant" - real(r8), public, protected, allocatable :: rairv(:,:,:) - ! cappav: rairv / cpairv - real(r8), public, protected, allocatable :: cappav(:,:,:) - ! mbarv: composition dependent atmosphere mean mass - real(r8), public, protected, allocatable :: mbarv(:,:,:) - ! cp_or_cv_dycore: enthalpy or internal energy scaling factor for - ! energy consistency - real(r8), public, protected, allocatable :: cp_or_cv_dycore(:,:,:) - real(r8), public , allocatable :: te_init(:,:,:)!xxx to be removed - ! - ! Interfaces for public routines - interface get_cp_dry - module procedure get_cp_dry_1hd - module procedure get_cp_dry_2hd - end interface get_cp_dry - - interface get_cp - module procedure get_cp_1hd - module procedure get_cp_2hd - end interface get_cp - - interface get_R_dry - module procedure get_R_dry_1hd - module procedure get_R_dry_2hd - end interface get_R_dry - - interface get_R - module procedure get_R_1hd - module procedure get_R_2hd - end interface get_R - - interface get_mbarv - module procedure get_mbarv_1hd - end interface get_mbarv - -CONTAINS - - ! Read namelist variables. - subroutine air_composition_readnl(nlfile) - use namelist_utils, only: find_group_name - use spmd_utils, only: masterproc, mpicom, masterprocid - use spmd_utils, only: mpi_character, mpi_logical - use cam_logfile, only: iulog - - ! Dummy argument: filepath for file containing namelist input - character(len=*), intent(in) :: nlfile - - ! Local variables - integer :: unitn, ierr, indx - integer, parameter :: lsize = 76 - character(len=*), parameter :: subname = 'air_composition_readnl :: ' - character(len=lsize) :: banner - character(len=lsize) :: bline - - ! Variable components of dry air and water species in air - namelist /air_composition_nl/ dry_air_species, water_species_in_air, compute_enthalpy_flux - !----------------------------------------------------------------------- - - banner = repeat('*', lsize) - bline = "***"//repeat(' ', lsize - 6)//"***" - - ! Read variable components of dry air and water species in air - dry_air_species = (/ (' ', indx = 1, num_names_max) /) - water_species_in_air = (/ (' ', indx = 1, num_names_max) /) - - if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old') - call find_group_name(unitn, 'air_composition_nl', status=ierr) - if (ierr == 0) then - read(unitn, air_composition_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname//'ERROR reading namelist, air_composition_nl') - end if - end if - close(unitn) - end if - - call mpi_bcast(compute_enthalpy_flux, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: compute_enthalpy_flux") - - call mpi_bcast(dry_air_species, len(dry_air_species)*num_names_max, & - mpi_character, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: dry_air_species") - call mpi_bcast(water_species_in_air, & - len(water_species_in_air)*num_names_max, mpi_character, & - masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: water_species_in_air") - - dry_air_species_num = 0 - water_species_in_air_num = 0 - do indx = 1, num_names_max - if ( (LEN_TRIM(dry_air_species(indx)) > 0) .and. & - (TRIM(dry_air_species(indx)) /= 'N2')) then - dry_air_species_num = dry_air_species_num + 1 - end if - if (LEN_TRIM(water_species_in_air(indx)) > 0) then - water_species_in_air_num = water_species_in_air_num + 1 - end if - end do - - ! Initialize number of thermodynamically active species - thermodynamic_active_species_num = & - dry_air_species_num + water_species_in_air_num - - if (masterproc) then - if (compute_enthalpy_flux) then - write(iulog, *) "Computing enthalpy flux: compute_enthalpy_flux=",compute_enthalpy_flux - endif - write(iulog, *) banner - write(iulog, *) bline - - if (dry_air_species_num == 0) then - write(iulog, *) " Thermodynamic properties of dry air are ", & - "fixed at troposphere values" - else - write(iulog, *) " Thermodynamic properties of dry air are ", & - "based on variable composition of the following species:" - do indx = 1, dry_air_species_num - write(iulog, *) ' ', trim(dry_air_species(indx)) - end do - write(iulog,*) ' ' - end if - write(iulog,*) " Thermodynamic properties of moist air are ", & - "based on variable composition of the following water species:" - do indx = 1, water_species_in_air_num - write(iulog, *) ' ', trim(water_species_in_air(indx)) - end do - write(iulog, *) bline - write(iulog, *) banner - end if - - end subroutine air_composition_readnl - - !=========================================================================== - - subroutine air_composition_init() - use string_utils, only: int2str - use spmd_utils, only: masterproc - use cam_logfile, only: iulog - use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry, cpwv, latice, latvap, tmelt - use constituents, only: cnst_get_ind, cnst_mw - use ppgrid, only: pcols, pver, begchunk, endchunk - integer :: icnst, ix, isize, ierr, idx - integer :: liq_num, ice_num - integer :: liq_idx(water_species_in_air_num) - integer :: ice_idx(water_species_in_air_num) - logical :: has_liq, has_ice - real(r8) :: mw - - character(len=*), parameter :: subname = 'composition_init' - character(len=*), parameter :: errstr = subname//": failed to allocate " - - ! - ! define cp and R for species in species_name - ! - ! Last major species in namelist dry_air_species is derived from the - ! other major species (since the sum of dry mixing ratios for - ! major species of dry air add must add to one) - ! - ! cv = R * dofx / 2; cp = R * (1 + (dofx / 2)) - ! DOF == Degrees of Freedom - ! dof1 = monatomic ideal gas, 3 translational DOF - real(r8), parameter :: dof1 = 3._r8 - real(r8), parameter :: cv1 = 0.5_r8 * r_universal * dof1 - real(r8), parameter :: cp1 = 0.5_r8 * r_universal * (2._r8 + dof1) - ! dof2 = diatomic ideal gas, 3 translational + 2 rotational = 5 DOF - real(r8), parameter :: dof2 = 5._r8 - real(r8), parameter :: cv2 = 0.5_r8 * r_universal * dof2 - real(r8), parameter :: cp2 = 0.5_r8 * r_universal * (2._r8 + dof2) - ! dof3 = polyatomic ideal gas, 3 translational + 3 rotational = 6 DOF - real(r8), parameter :: dof3 = 6._r8 - real(r8), parameter :: cv3 = 0.5_r8 * r_universal * dof3 - real(r8), parameter :: cp3 = 0.5_r8 * r_universal * (2._r8 + dof3) - - liq_num = 0 - ice_num = 0 - has_liq = .false. - has_ice = .false. - ! standard dry air (constant composition) - o2_mwi = 1._r8 / 32._r8 - n2_mwi = 1._r8 / 28._r8 - mmro2 = 0.235_r8 - mmrn2 = 0.765_r8 - mbar = 1._r8 / ((mmro2 * o2_mwi) + (mmrn2 * n2_mwi)) - - ! init for variable composition dry air - - isize = dry_air_species_num + water_species_in_air_num - allocate(thermodynamic_active_species_idx(isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_idx") - end if - allocate(thermodynamic_active_species_idx_dycore(isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_idx_dycore") - end if - allocate(thermodynamic_active_species_cp(0:isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_cp") - end if - allocate(thermodynamic_active_species_cv(0:isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_cv") - end if - allocate(thermodynamic_active_species_R(0:isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_R") - end if - - isize = dry_air_species_num - allocate(thermodynamic_active_species_mwi(0:isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_mwi") - end if - allocate(thermodynamic_active_species_kv(0:isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_kv") - end if - allocate(thermodynamic_active_species_kc(0:isize), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_kc") - end if - !------------------------------------------------------------------------ - ! Allocate constituent dependent properties - !------------------------------------------------------------------------ - allocate(cpairv(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"cpairv") - end if - allocate(rairv(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"rairv") - end if - allocate(cappav(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"cappav") - end if - allocate(mbarv(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"mbarv") - end if - allocate(cp_or_cv_dycore(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"cp_or_cv_dycore") - end if - allocate(te_init(pcols,4,begchunk:endchunk), stat=ierr)!xxx to be removed - thermodynamic_active_species_idx = -HUGE(1) - thermodynamic_active_species_idx_dycore = -HUGE(1) - thermodynamic_active_species_cp = 0.0_r8 - thermodynamic_active_species_cv = 0.0_r8 - thermodynamic_active_species_R = 0.0_r8 - thermodynamic_active_species_mwi = 0.0_r8 - thermodynamic_active_species_kv = 0.0_r8 - thermodynamic_active_species_kc = 0.0_r8 - !------------------------------------------------------------------------ - ! Initialize constituent dependent properties - !------------------------------------------------------------------------ - cpairv(:pcols, :pver, begchunk:endchunk) = cpair - rairv(:pcols, :pver, begchunk:endchunk) = rair - cappav(:pcols, :pver, begchunk:endchunk) = rair / cpair - mbarv(:pcols, :pver, begchunk:endchunk) = mwdry - ! - if (dry_air_species_num > 0) then - ! - ! The last major species in dry_air_species is derived from the - ! others and constants associated with it are initialized here - ! - if (TRIM(dry_air_species(dry_air_species_num + 1)) == 'N2') then - call air_species_info('N', ix, mw) - mw = 2.0_r8 * mw - icnst = 0 ! index for the derived tracer N2 - thermodynamic_active_species_cp(icnst) = cp2 / mw - thermodynamic_active_species_cv(icnst) = cv2 / mw !N2 - thermodynamic_active_species_R (icnst) = r_universal / mw - thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw - thermodynamic_active_species_kv(icnst) = kv2 - thermodynamic_active_species_kc(icnst) = kc2 - ! - ! if last major species is not N2 then add code here - ! - else - write(iulog, *) subname, ' derived major species not found: ', & - dry_air_species(dry_air_species_num) - call endrun(subname//': derived major species not found') - end if - else - ! - ! dry air is not species dependent - ! - icnst = 0 - thermodynamic_active_species_cp (icnst) = cpair - thermodynamic_active_species_cv (icnst) = cpair - rair - thermodynamic_active_species_R (icnst) = rair - end if - ! - !************************************************************************ - ! - ! add prognostic components of dry air - ! - !************************************************************************ - ! - icnst = 1 - do idx = 1, dry_air_species_num - select case (TRIM(dry_air_species(idx))) - ! - ! O - ! - case('O') - call air_species_info('O', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cp1 / mw - thermodynamic_active_species_cv (icnst) = cv1 / mw - thermodynamic_active_species_R (icnst) = r_universal / mw - thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw - thermodynamic_active_species_kv(icnst) = kv3 - thermodynamic_active_species_kc(icnst) = kc3 - icnst = icnst + 1 - ! - ! O2 - ! - case('O2') - call air_species_info('O2', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cp2 / mw - thermodynamic_active_species_cv (icnst) = cv2 / mw - thermodynamic_active_species_R (icnst) = r_universal / mw - thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw - thermodynamic_active_species_kv(icnst) = kv1 - thermodynamic_active_species_kc(icnst) = kc1 - icnst = icnst + 1 - ! - ! H - ! - case('H') - call air_species_info('H', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cp1 / mw - thermodynamic_active_species_cv (icnst) = cv1 / mw - thermodynamic_active_species_R (icnst) = r_universal / mw - thermodynamic_active_species_mwi(icnst) = 1.0_r8 / mw - ! Hydrogen not included in calculation of diffusivity and conductivity - thermodynamic_active_species_kv(icnst) = 0.0_r8 - thermodynamic_active_species_kc(icnst) = 0.0_r8 - icnst = icnst + 1 - ! - ! If support for more major species is to be included add code here - ! - case default - write(iulog, *) subname, ' dry air component not found: ', & - dry_air_species(idx) - call endrun(subname//': dry air component not found') - end select - - if (masterproc) then - write(iulog, *) "Dry air composition ", & - TRIM(dry_air_species(idx)), & - icnst-1,thermodynamic_active_species_idx(icnst-1), & - thermodynamic_active_species_mwi(icnst-1), & - thermodynamic_active_species_cp(icnst-1), & - thermodynamic_active_species_cv(icnst-1) - end if - end do - isize = dry_air_species_num+1 - icnst = 0 ! N2 - if(isize > 0) then - if(masterproc) then - write(iulog, *) "Dry air composition ", & - TRIM(dry_air_species(idx)), & - icnst, -1, thermodynamic_active_species_mwi(icnst), & - thermodynamic_active_species_cp(icnst), & - thermodynamic_active_species_cv(icnst) - end if - end if - ! - !************************************************************************ - ! - ! Add non-dry components of moist air (water vapor and condensates) - ! - !************************************************************************ - ! - icnst = dry_air_species_num + 1 - do idx = 1, water_species_in_air_num - select case (TRIM(water_species_in_air(idx))) - ! - ! Q - ! - case('Q') - call air_species_info('Q', ix, mw) - wv_idx = ix - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cpwv - thermodynamic_active_species_cv (icnst) = cv3 / mw - thermodynamic_active_species_R (icnst) = rh2o - icnst = icnst + 1 - ! - ! CLDLIQ - ! - case('CLDLIQ') - call air_species_info('CLDLIQ', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cpliq - thermodynamic_active_species_cv (icnst) = cpliq - liq_num = liq_num+1 - liq_idx (liq_num) = ix - icnst = icnst + 1 - has_liq = .true. - ! - ! CLDICE - ! - case('CLDICE') - call air_species_info('CLDICE', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cpice - thermodynamic_active_species_cv (icnst) = cpice - ice_num = ice_num+1 - ice_idx(ice_num) = ix - icnst = icnst + 1 - has_ice = .true. - ! - ! RAINQM - ! - case('RAINQM') - call air_species_info('RAINQM', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cpliq - thermodynamic_active_species_cv (icnst) = cpliq - liq_num = liq_num+1 - liq_idx(liq_num) = ix - icnst = icnst + 1 - has_liq = .true. - ! - ! SNOWQM - ! - case('SNOWQM') - call air_species_info('SNOWQM', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cpice - thermodynamic_active_species_cv (icnst) = cpice - ice_num = ice_num+1 - ice_idx(ice_num) = ix - icnst = icnst + 1 - has_ice = .true. - ! - ! GRAUQM - ! - case('GRAUQM') - call air_species_info('GRAUQM', ix, mw) - thermodynamic_active_species_idx(icnst) = ix - thermodynamic_active_species_cp (icnst) = cpice - thermodynamic_active_species_cv (icnst) = cpice - ice_num = ice_num+1 - ice_idx(ice_num) = ix - icnst = icnst + 1 - has_ice = .true. - ! - ! If support for more major species is to be included add code here - ! - case default - write(iulog, *) subname, ' moist air component not found: ', & - water_species_in_air(idx) - call endrun(subname//': moist air component not found') - end select - ! - ! - ! - if (masterproc) then - write(iulog, *) "Thermodynamic active species ", & - TRIM(water_species_in_air(idx)) - write(iulog, *) " global index : ", & - icnst-1 - write(iulog, *) " thermodynamic_active_species_idx : ", & - thermodynamic_active_species_idx(icnst-1) - write(iulog, *) " cp : ", & - thermodynamic_active_species_cp(icnst-1) - write(iulog, *) " cv : ", & - thermodynamic_active_species_cv(icnst-1) - if (has_liq) then - write(iulog, *) " register phase (liquid or ice) :", & - " liquid" - end if - if (has_ice) then - write(iulog, *) " register phase (liquid or ice) :", & - " ice" - end if - write(iulog, *) " " - end if - has_liq = .false. - has_ice = .false. - end do - - allocate(thermodynamic_active_species_liq_idx(liq_num), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_liq_idx") - end if - allocate(thermodynamic_active_species_liq_idx_dycore(liq_num), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_liq_idx_dycore") - end if - allocate(thermodynamic_active_species_ice_idx(ice_num), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_ice_idx") - end if - allocate(thermodynamic_active_species_ice_idx_dycore(ice_num), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"thermodynamic_active_species_ice_idx_dycore") - end if - - thermodynamic_active_species_liq_idx = liq_idx(1:liq_num) - thermodynamic_active_species_liq_num = liq_num - - ! array initialized by the dycore - thermodynamic_active_species_liq_idx_dycore = -99 - - thermodynamic_active_species_ice_idx = ice_idx(1:ice_num) - thermodynamic_active_species_ice_num = ice_num - - ! array initialized by the dycore - thermodynamic_active_species_ice_idx_dycore = -99 - - if (water_species_in_air_num /= 1 + liq_num+ice_num) then - write(iulog, '(2a,2(i0,a))') subname, & - " water_species_in_air_num = ", & - water_species_in_air_num, ", should be ", & - (1 + liq_num + ice_num), " (1 + liq_num + ice_num)" - call endrun(subname//': water_species_in_air_num /= 1+liq_num+ice_num') - end if - -!tht: nasty hard-wiring here - enthalpy_reference_state = 'ice' - if (masterproc) then - write(iulog, *) 'Enthalpy reference state : ', & - TRIM(enthalpy_reference_state) - end if - -!tht: initialising t00's, h00's here - ! N.B. latent heats should be adjusted to t00a, but unless t00a=tmelt, - ! this will break all physics - ! physics and SE dycore make different, mutually inconsistent, - ! hard-wired assumptions on t00 and h00: - ! physics : t00=tmelt, h00(ice)=L(ice; liq, T=tmelt) - ! dynamics (SE): t00=0, h00=0 - ! As a result, any water non-conservation in the dycore results in fixer - ! increments, proportional to h00a as set below. - - !ocean choice for enthalpy at T=0 (liquid reference phase) - t00o = tmelt - h00o = -cpliq*t00o - - !atmo choices for enthalpy at T=0 (liquid ref. phase): - if(.not.compute_enthalpy_flux)then - t00a = 0._r8 - h00a = 0._r8 - h00a_ice = 0._r8 - h00a_vap = 0._r8 - else - t00a = tmelt - h00a = -cpliq*t00a - if (enthalpy_reference_state.eq.'ice') then - !h00a =-((cpliq-cpice)*t00a - latice) ! cam default h00a_ice=0 (minimizes fixer increments) - h00a = -cpliq*t00a ! conserve single formula for global energy - else if (enthalpy_reference_state.eq.'vap') then - h00a =-((cpliq-cpwv )*t00a + latvap) - endif - ! the following ensure that the value of atmospheric enthalpy is independent of reference state - h00a_vap= h00a+((cpliq-cpwv )*t00a + latvap) - h00a_ice= h00a+((cpliq-cpice)*t00a - latice) - endif - - if (masterproc) then - write(iulog, *) ' ocean t00o: ', t00o - write(iulog, *) ' ocean h00o: ', h00o - write(iulog, *) 'atmos. enthalpy_reference_state: ', trim(enthalpy_reference_state) - write(iulog, *) ' t00a: ', t00a - write(iulog, *) ' h00a: ', h00a - write(iulog, *) ' h00a_ice: ', h00a_ice - write(iulog, *) ' h00a_vap: ', h00a_vap - endif - ! call MPI_bcast(t00o , 1, mpi_real8, masterprocid, mpicom, ierr) - ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: t00o ") - ! call MPI_bcast(h00o , 1, mpi_real8, masterprocid, mpicom, ierr) - ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00o ") - ! call MPI_bcast(t00a , 1, mpi_real8, masterprocid, mpicom, ierr) - ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: t00a ") - ! call MPI_bcast(h00a , 1, mpi_real8, masterprocid, mpicom, ierr) - ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00a ") - ! call MPI_bcast(h00a_ice, 1, mpi_real8, masterprocid, mpicom, ierr) - ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00a_ice") - ! call MPI_bcast(h00a_vap, 1, mpi_real8, masterprocid, mpicom, ierr) - ! if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: h00a_vap") -!-tht - - end subroutine air_composition_init - - !=========================================================================== - !----------------------------------------------------------------------- - ! dry_air_composition_update: Update the physics "constants" that vary - !------------------------------------------------------------------------- - !=========================================================================== - - subroutine dry_air_composition_update(mmr, lchnk, ncol, to_dry_factor) - use cam_abortutils, only: endrun - !(mmr = dry mixing ratio, if not, use to_dry_factor to convert!) - real(r8), intent(in) :: mmr(:,:,:) ! mixing ratios for species dependent dry air - integer, intent(in) :: lchnk ! Chunk number - integer, intent(in) :: ncol ! number of columns - real(r8), optional, intent(in) :: to_dry_factor(:,:) - - call get_R_dry(mmr(:ncol, :, :), thermodynamic_active_species_idx, & - rairv(:ncol, :, lchnk), fact=to_dry_factor) - call get_cp_dry(mmr(:ncol,:,:), thermodynamic_active_species_idx, & - cpairv(:ncol,:,lchnk), fact=to_dry_factor) - call get_mbarv(mmr(:ncol,:,:), thermodynamic_active_species_idx, & - mbarv(:ncol,:,lchnk), fact=to_dry_factor) - cappav(:ncol,:,lchnk) = rairv(:ncol,:,lchnk) / cpairv(:ncol,:,lchnk) - end subroutine dry_air_composition_update - - !=========================================================================== - !--------------------------------------------------------------------------- - ! water_composition_update: Update generalized cp or cv depending on dycore - !--------------------------------------------------------------------------- - !=========================================================================== - - subroutine water_composition_update(mmr, lchnk, ncol, vcoord, to_dry_factor) - use cam_abortutils, only: endrun - use string_utils, only: int2str - use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure - real(r8), intent(in) :: mmr(:,:,:) ! constituents array - integer, intent(in) :: lchnk ! Chunk number - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: vcoord - real(r8), optional, intent(in) :: to_dry_factor(:,:) - - character(len=*), parameter :: subname = 'water_composition_update' - - if (vcoord==vc_dry_pressure) then - call get_cp(mmr(:ncol,:,:),.false.,cp_or_cv_dycore(:ncol,:,lchnk), factor=to_dry_factor, & - active_species_idx_dycore=thermodynamic_active_species_idx,cpdry=cpairv(:ncol,:,lchnk)) - else if (vcoord==vc_height) then - call get_R(mmr(:ncol,:,:), thermodynamic_active_species_idx, & - cp_or_cv_dycore(:ncol,:,lchnk), fact=to_dry_factor, Rdry=rairv(:ncol,:,lchnk)) - ! - ! internal energy coefficient for MPAS - ! (equation 92 in Eldred et al. 2023; https://rmets.onlinelibrary.wiley.com/doi/epdf/10.1002/qj.4353) - ! - cp_or_cv_dycore(:ncol,:,lchnk)=cp_or_cv_dycore(:ncol,:,lchnk)*& - (cpairv(:ncol,:,lchnk)-rairv(:ncol,:,lchnk)) /rairv(:ncol,:,lchnk) - else if (vcoord==vc_moist_pressure) then - ! no update needed for moist pressure vcoord - else - call endrun(subname//" vertical coordinate not supported; vcoord="// int2str(vcoord)) - end if - end subroutine water_composition_update - - !=========================================================================== - !*************************************************************************** - ! - ! get_cp_dry: Compute dry air heat capacity under constant pressure - ! - !*************************************************************************** - ! - subroutine get_cp_dry_1hd(tracer, active_species_idx, cp_dry, fact) - use cam_abortutils, only: endrun - use string_utils, only: int2str - use physconst, only: cpair - - ! Dummy arguments - ! tracer: tracer array - real(r8), intent(in) :: tracer(:,:,:) - integer, intent(in) :: active_species_idx(:) - ! fact: optional dry pressure level thickness - real(r8), optional, intent(in) :: fact(:,:) - ! cp_dry: dry air heat capacity under constant pressure - real(r8), intent(out) :: cp_dry(:,:) - - ! Local variables - integer :: idx, kdx , m_cnst, qdx - ! factor: dry pressure level thickness - real(r8) :: factor(SIZE(cp_dry, 1), SIZE(cp_dry, 2)) - real(r8) :: residual(SIZE(cp_dry, 1), SIZE(cp_dry, 2)) - real(r8) :: mmr - character(len=*), parameter :: subname = 'get_cp_dry_1hd: ' - - if (dry_air_species_num == 0) then - ! dry air heat capacity not species dependent - cp_dry = cpair - else - ! dry air heat capacity is species dependent - if (present(fact)) then - if (SIZE(fact, 1) /= SIZE(factor, 1)) then - call endrun(subname//"SIZE mismatch in dimension 1 "// & - int2str(SIZE(fact, 1))//' /= '//int2str(SIZE(factor, 1))) - end if - if (SIZE(fact, 2) /= SIZE(factor, 2)) then - call endrun(subname//"SIZE mismatch in dimension 2 "// & - int2str(SIZE(fact, 2))//' /= '//int2str(SIZE(factor, 2))) - end if - factor = fact(:,:) - else - factor = 1.0_r8 - end if - - cp_dry = 0.0_r8 - residual = 1.0_r8 - do qdx = 1, dry_air_species_num - m_cnst = active_species_idx(qdx) - do kdx = 1, SIZE(cp_dry, 2) - do idx = 1, SIZE(cp_dry, 1) - mmr = tracer(idx, kdx, m_cnst) * factor(idx, kdx) - cp_dry(idx, kdx) = cp_dry(idx, kdx) + & - (thermodynamic_active_species_cp(qdx) * mmr) - residual(idx, kdx) = residual(idx, kdx) - mmr - end do - end do - end do - qdx = 0 ! N2 - do kdx = 1, SIZE(cp_dry, 2) - do idx = 1, SIZE(cp_dry, 1) - cp_dry(idx, kdx) = cp_dry(idx, kdx) + & - (thermodynamic_active_species_cp(qdx) * residual(idx, kdx)) - end do - end do - end if - end subroutine get_cp_dry_1hd - - !=========================================================================== - - subroutine get_cp_dry_2hd(tracer, active_species_idx, cp_dry, fact) - ! Version of get_cp_dry for arrays that have a second horizontal index - - ! Dummy arguments - ! tracer: tracer array - real(r8), intent(in) :: tracer(:,:,:,:) - integer, intent(in) :: active_species_idx(:) - ! fact: optional dry pressure level thickness - real(r8), optional, intent(in) :: fact(:,:,:) - ! cp_dry: dry air heat capacity under constant pressure - real(r8), intent(out) :: cp_dry(:,:,:) - - ! Local variable - integer :: jdx - - do jdx = 1, SIZE(cp_dry, 2) - if (present(fact)) then - call get_cp_dry(tracer(:,jdx,:,:), active_species_idx, & - cp_dry(:,jdx,:), fact=fact(:,jdx,:)) - else - call get_cp_dry(tracer(:,jdx,:,:), active_species_idx, & - cp_dry(:,jdx,:)) - end if - end do - - end subroutine get_cp_dry_2hd - - !=========================================================================== - ! - !*************************************************************************** - ! - ! get_cp: Compute generalized heat capacity at constant pressure - ! - !*************************************************************************** - ! - subroutine get_cp_1hd(tracer, inv_cp, cp, factor, active_species_idx_dycore, cpdry) - use cam_abortutils, only: endrun - use string_utils, only: int2str - - ! Dummy arguments - ! tracer: Tracer array - ! - ! factor not present then tracer must be dry mixing ratio - ! if factor present tracer*factor must be dry mixing ratio - ! - real(r8), intent(in) :: tracer(:,:,:) - ! inv_cp: output inverse cp instead of cp - logical, intent(in) :: inv_cp - real(r8), intent(out) :: cp(:,:) - ! dp: if provided then tracer is mass not mixing ratio - real(r8), optional, intent(in) :: factor(:,:) - ! active_species_idx_dycore: array of indices for index of - ! thermodynamic active species in dycore tracer array - ! (if different from physics index) - integer, optional, intent(in) :: active_species_idx_dycore(:) - real(r8),optional, intent(in) :: cpdry(:,:) - - ! LOCAL VARIABLES - integer :: qdx, itrac - real(r8) :: sum_species(SIZE(cp, 1), SIZE(cp, 2)) - real(r8) :: sum_cp(SIZE(cp, 1), SIZE(cp, 2)) - real(r8) :: factor_local(SIZE(cp, 1), SIZE(cp, 2)) - integer :: idx_local(thermodynamic_active_species_num) - character(LEN=*), parameter :: subname = 'get_cp_1hd: ' - - if (present(active_species_idx_dycore)) then - if (SIZE(active_species_idx_dycore) /= & - thermodynamic_active_species_num) then - call endrun(subname//"SIZE mismatch "// & - int2str(SIZE(active_species_idx_dycore))//' /= '// & - int2str(thermodynamic_active_species_num)) - end if - idx_local = active_species_idx_dycore - else - idx_local = thermodynamic_active_species_idx - end if - - if (present(factor)) then - factor_local = factor - else - factor_local = 1.0_r8 - end if - - sum_species = 1.0_r8 ! all dry air species sum to 1 - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - itrac = idx_local(qdx) - sum_species(:,:) = sum_species(:,:) + (tracer(:,:,itrac) * factor_local(:,:)) - end do - - if (dry_air_species_num == 0) then - sum_cp = thermodynamic_active_species_cp(0) - else if (present(cpdry)) then - ! - ! if cpdry is known don't recompute - ! - sum_cp = cpdry - else - call get_cp_dry(tracer, idx_local, sum_cp, fact=factor_local) - end if - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - itrac = idx_local(qdx) - sum_cp(:,:) = sum_cp(:,:)+ & - thermodynamic_active_species_cp(qdx) * tracer(:,:,itrac)* factor_local(:,:) - end do - if (inv_cp) then - cp = sum_species / sum_cp - else - cp = sum_cp / sum_species - end if - end subroutine get_cp_1hd - - !=========================================================================== - - subroutine get_cp_2hd(tracer, inv_cp, cp, factor, active_species_idx_dycore, cpdry) - ! Version of get_cp for arrays that have a second horizontal index - use cam_abortutils, only: endrun - use string_utils, only: int2str - - ! Dummy arguments - ! tracer: Tracer array - ! - real(r8), intent(in) :: tracer(:,:,:,:) - ! inv_cp: output inverse cp instead of cp - logical, intent(in) :: inv_cp - real(r8), intent(out) :: cp(:,:,:) - real(r8), optional, intent(in) :: factor(:,:,:) - real(r8), optional, intent(in) :: cpdry(:,:,:) - - ! active_species_idx_dycore: array of indicies for index of - ! thermodynamic active species in dycore tracer array - ! (if different from physics index) - integer, optional, intent(in) :: active_species_idx_dycore(:) - - ! Local variables - integer :: jdx - integer :: idx_local(thermodynamic_active_species_num) - character(len=*), parameter :: subname = 'get_cp_2hd: ' - - do jdx = 1, SIZE(cp, 2) - if (present(factor).and.present(cpdry)) then - call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& - factor=factor(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore, cpdry=cpdry(:,jdx,:)) - else if (present(factor)) then - call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& - factor=factor(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore) - else if (present(cpdry)) then - call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& - active_species_idx_dycore=active_species_idx_dycore, cpdry=cpdry(:,jdx,:)) - else - call get_cp(tracer(:, jdx, :, :), inv_cp, cp(:, jdx, :),& - active_species_idx_dycore=active_species_idx_dycore) - end if - end do - - end subroutine get_cp_2hd - - !=========================================================================== - - !*************************************************************************** - ! - ! get_R_dry: Compute generalized dry air gas constant R - ! - !*************************************************************************** - ! - subroutine get_R_dry_1hd(tracer, active_species_idx_dycore, R_dry, fact) - use physconst, only: rair - - ! tracer: tracer array - real(r8), intent(in) :: tracer(:, :, :) - ! active_species_idx_dycore: index of active species in tracer - integer, intent(in) :: active_species_idx_dycore(:) - ! R_dry: dry air R - real(r8), intent(out) :: R_dry(:, :) - ! fact: optional factor for converting tracer to dry mixing ratio - real(r8), optional, intent(in) :: fact(:, :) - - ! Local variables - integer :: idx, kdx, m_cnst, qdx - real(r8) :: factor(SIZE(tracer, 1), SIZE(tracer, 2)) - real(r8) :: residual(SIZE(R_dry, 1), SIZE(R_dry, 2)) - real(r8) :: mmr - - if (dry_air_species_num == 0) then - ! - ! dry air not species dependent - ! - R_dry = rair - else - if (present(fact)) then - factor = fact(:,:) - else - factor = 1.0_r8 - end if - - R_dry = 0.0_r8 - residual = 1.0_r8 - do qdx = 1, dry_air_species_num - m_cnst = active_species_idx_dycore(qdx) - do kdx = 1, SIZE(R_dry, 2) - do idx = 1, SIZE(R_dry, 1) - mmr = tracer(idx, kdx, m_cnst) * factor(idx, kdx) - R_dry(idx, kdx) = R_dry(idx, kdx) + & - (thermodynamic_active_species_R(qdx) * mmr) - residual(idx, kdx) = residual(idx, kdx) - mmr - end do - end do - end do - ! - ! N2 derived from the others - ! - qdx = 0 - do kdx = 1, SIZE(R_dry, 2) - do idx = 1, SIZE(R_dry, 1) - R_dry(idx, kdx) = R_dry(idx, kdx) + & - (thermodynamic_active_species_R(qdx) * residual(idx, kdx)) - end do - end do - end if - end subroutine get_R_dry_1hd - - !=========================================================================== - - subroutine get_R_dry_2hd(tracer, active_species_idx_dycore, R_dry, fact) - ! Version of get_R_dry for arrays that have a second horizontal index - - ! tracer: tracer array - real(r8), intent(in) :: tracer(:, :, :, :) - ! active_species_idx_dycore: index of active species in tracer - integer, intent(in) :: active_species_idx_dycore(:) - ! R_dry: dry air R - real(r8), intent(out) :: R_dry(:, :, :) - ! fact: optional factor for converting tracer to dry mixing ratio - real(r8), optional, intent(in) :: fact(:, :, :) - - ! Local variable - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(fact)) then - call get_R_dry(tracer(:, jdx, :, :), active_species_idx_dycore, & - R_dry(:, jdx, :), fact=fact(:, jdx, :)) - else - call get_R_dry(tracer(:, jdx, :, :), active_species_idx_dycore, & - R_dry(:, jdx, :)) - end if - end do - - end subroutine get_R_dry_2hd - - !=========================================================================== - ! - !*************************************************************************** - ! - ! get_R: Compute generalized R - ! This code (both 1hd and 2hd) is currently unused and untested - ! - !*************************************************************************** - ! - subroutine get_R_1hd(tracer, active_species_idx, R, fact, Rdry) - use cam_abortutils, only: endrun - use string_utils, only: int2str - use physconst, only: rair - - ! Dummy arguments - ! tracer: !tracer array - real(r8), intent(in) :: tracer(:, :, :) - ! active_species_idx: index of active species in tracer - integer, intent(in) :: active_species_idx(:) - ! R: generalized gas constant - real(r8), intent(out) :: R(:, :) - ! fact: optional factor for converting tracer to dry mixing ratio - real(r8), optional, intent(in) :: fact(:, :) - real(r8), optional, intent(in) :: Rdry(:, :) - - ! Local variables - integer :: qdx, itrac - real(r8) :: factor(SIZE(tracer, 1), SIZE(tracer, 2)) - real(r8) :: sum_species(SIZE(R, 1), SIZE(R, 2)) - integer :: idx_local(thermodynamic_active_species_num) - - character(len=*), parameter :: subname = 'get_R_1hd: ' - - if (present(fact)) then - if (SIZE(fact, 1) /= SIZE(factor, 1)) then - call endrun(subname//"SIZE mismatch in dimension 1 "// & - int2str(SIZE(fact, 1))//' /= '//int2str(SIZE(factor, 1))) - end if - if (SIZE(fact, 2) /= SIZE(factor, 2)) then - call endrun(subname//"SIZE mismatch in dimension 2 "// & - int2str(SIZE(fact, 2))//' /= '//int2str(SIZE(factor, 2))) - end if - factor = fact(:,:) - else - factor = 1.0_r8 - end if - - if (dry_air_species_num == 0) then - R = rair - else if (present(Rdry)) then - R = Rdry - else - call get_R_dry(tracer, active_species_idx, R, fact=factor) - end if - - idx_local = active_species_idx - sum_species = 1.0_r8 ! all dry air species sum to 1 - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - itrac = idx_local(qdx) - sum_species(:,:) = sum_species(:,:) + & - (tracer(:,:,itrac) * factor(:,:)) - end do - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - itrac = idx_local(qdx) - R(:,:) = R(:,:) + & - (thermodynamic_active_species_R(qdx) * tracer(:,:,itrac) * & - factor(:,:)) - end do - R = R / sum_species - end subroutine get_R_1hd - - !=========================================================================== - - subroutine get_R_2hd(tracer, active_species_idx, R, fact) - - ! Dummy arguments - ! tracer: !tracer array - real(r8), intent(in) :: tracer(:, :, :, :) - ! active_species_idx: index of active species in tracer - integer, intent(in) :: active_species_idx(:) - ! R: generalized gas constant - real(r8), intent(out) :: R(:, :, :) - ! fact: optional factor for converting tracer to dry mixing ratio - real(r8), optional, intent(in) :: fact(:, :, :) - - ! Local variable - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(fact)) then - call get_R(tracer(:, jdx, :, :), active_species_idx, & - R(:, jdx, :), fact=fact(:, jdx, :)) - else - call get_R(tracer(:, jdx, :, :), active_species_idx, & - R(:, jdx, :)) - end if - end do - - end subroutine get_R_2hd - - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute molecular weight dry air - ! - !************************************************************************************************************************* - ! - subroutine get_mbarv_1hd(tracer, active_species_idx, mbarv_in, fact) - use physconst, only: mwdry - real(r8), intent(in) :: tracer(:,:,:) !tracer array - integer, intent(in) :: active_species_idx(:) !index of active species in tracer - real(r8), intent(out) :: mbarv_in(:,:) !molecular weight of dry air - real(r8), optional, intent(in) :: fact(:,:) !factor for converting tracer to dry mixing ratio - - integer :: idx, kdx, m_cnst, qdx - real(r8):: factor(SIZE(mbarv_in, 1), SIZE(mbarv_in, 2)) - real(r8):: residual(SIZE(tracer, 1), SIZE(mbarv_in, 2)) - real(r8):: mm - ! - ! dry air not species dependent - ! - if (dry_air_species_num==0) then - mbarv_in = mwdry - else - if (present(fact)) then - factor(:,:) = fact(:,:) - else - factor(:,:) = 1.0_r8 - endif - - mbarv_in = 0.0_r8 - residual = 1.0_r8 - do qdx = 1, dry_air_species_num - m_cnst = active_species_idx(qdx) - do kdx = 1, SIZE(mbarv_in, 2) - do idx = 1, SIZE(mbarv_in, 1) - mm = tracer(idx, kdx, m_cnst) * factor(idx, kdx) - mbarv_in(idx, kdx) = mbarv_in(idx, kdx) + thermodynamic_active_species_mwi(qdx) * mm - residual(idx, kdx) = residual(idx, kdx) - mm - end do - end do - end do - qdx = 0 ! N2 - do kdx = 1, SIZE(mbarv_in, 2) - do idx = 1, SIZE(mbarv_in, 1) - mbarv_in(idx, kdx) = mbarv_in(idx, kdx) + thermodynamic_active_species_mwi(qdx) * residual(idx, kdx) - end do - end do - mbarv_in(:,:) = 1.0_r8 / mbarv_in(:,:) - end if - end subroutine get_mbarv_1hd - - !=========================================================================== - - subroutine air_species_info(name, index, molec_weight, caller) - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use constituents, only: cnst_get_ind, cnst_mw - ! Find the constituent index of and return it in - ! . Return the constituent molecular weight in - ! - - ! Dummy arguments - character(len=*), intent(in) :: name - integer, intent(out) :: index - real(r8), intent(out) :: molec_weight - character(len=*), optional, intent(in) :: caller - ! Local parameter - character(len=*), parameter :: subname = 'air_species_info: ' - - call cnst_get_ind(trim(name), index, abort=.false.) - if (index < 1) then - if (present(caller)) then - write(iulog, *) trim(caller), ": air component not found, '", & - trim(name), "'" - call endrun(trim(caller)//": air component not found, '"// & - trim(name)//"'") - else - write(iulog, *) subname, "air component not found, '", & - trim(name), "'" - call endrun(subname//"air component not found, '"// & - trim(name)//"'") - end if - else - molec_weight = cnst_mw(index) - end if - - end subroutine air_species_info - - -end module air_composition diff --git a/src/utils/air_composition.F90 b/src/utils/air_composition.F90 index 6046ffebf1..43ae6efa0d 100644 --- a/src/utils/air_composition.F90 +++ b/src/utils/air_composition.F90 @@ -1,7 +1,8 @@ -! air_composition module defines major species of the atmosphere and manages -! the physical properties that are dependent on the composition of air module air_composition + ! air_composition module defines major species of the atmosphere and manages + ! the physical properties that are dependent on the composition of air + use shr_kind_mod, only: r8 => shr_kind_r8 use cam_abortutils, only: endrun @@ -25,6 +26,16 @@ module air_composition ! get_mbarv: molecular weight of dry air public :: get_mbarv + logical, public :: compute_enthalpy_flux + ! + ! for book keeping of enthalpy variables in physics buffer + ! + integer, parameter, public :: num_enthalpy_vars = 4 ! index for enthalpy flux associated with liquid precipitation + integer, parameter, public :: hliq_idx = 1 ! index for enthalpy flux associated with liquid precipitation + integer, parameter, public :: hice_idx = 2 ! index for enthalpy flux associated with frozen precipiation + integer, parameter, public :: fliq_idx = 3 ! index for flux of liquid precipitation + integer, parameter, public :: fice_idx = 4 ! index for flux of frozen precipitation + private :: air_species_info integer, parameter :: unseti = -HUGE(1) @@ -67,8 +78,9 @@ module air_composition integer, allocatable, protected, public :: thermodynamic_active_species_ice_idx(:) ! thermodynamic_active_species_ice_idx_dycore: index of ice water species integer, allocatable, public :: thermodynamic_active_species_ice_idx_dycore(:) - ! enthalpy_reference_state: choices: 'ice', 'liq', 'wv' - character(len=3), public, protected :: enthalpy_reference_state = 'xxx' + ! enthalpy_reference_state: choices: 'ice', 'liq', 'vap' + ! 'wv'->'vap' (stick to three characters, 'water' is presumably implicit in all of these...) + character(len=3), public, protected :: enthalpy_reference_state = 'ice' integer, protected, public :: wv_idx = -1 ! Water vapor index @@ -82,6 +94,14 @@ module air_composition real(r8), public, protected :: n2_mwi = unsetr ! Inverse mol. weight of N2 real(r8), public, protected :: mbar = unsetr ! Mean mass at mid level + ! explicitly declare reference enthalpies and temperatures for atmosphere and ocean + real(r8), public, protected :: t00o ! Water enthalpy reference temperature, ocean (K) + real(r8), public, protected :: t00a ! Water enthalpy reference temperature, atmosphere (K) + real(r8), public, protected :: h00o ! Material enthalpy zero, liquid reference state, ocean water (J/kg) + real(r8), public, protected :: h00a ! Material enthalpy zero, liquid reference state, atmos water (J/kg) + real(r8), public, protected :: h00a_vap ! Material enthalpy zero, vapor reference state, atmos (J/kg) + real(r8), public, protected :: h00a_ice ! Material enthalpy zero, vapor reference state, atmos (J/kg) + ! coefficients in expressions for molecular diffusion coefficients ! kv1,..,kv3 are coefficients for kmvis calculation ! kc1,..,kc3 are coefficients for kmcnd calculation @@ -105,9 +125,10 @@ module air_composition real(r8), public, protected, allocatable :: cappav(:,:,:) ! mbarv: composition dependent atmosphere mean mass real(r8), public, protected, allocatable :: mbarv(:,:,:) - ! cp_or_cv_dycore: enthalpy or internal energy scaling factor for + ! cp_or_cv_dycore: enthalpy or internal energy scaling factor for ! energy consistency real(r8), public, protected, allocatable :: cp_or_cv_dycore(:,:,:) + real(r8), public , allocatable :: te_init(:,:,:)!xxx to be removed ! ! Interfaces for public routines interface get_cp_dry @@ -140,7 +161,7 @@ module air_composition subroutine air_composition_readnl(nlfile) use namelist_utils, only: find_group_name use spmd_utils, only: masterproc, mpicom, masterprocid - use spmd_utils, only: mpi_character + use spmd_utils, only: mpi_character, mpi_logical use cam_logfile, only: iulog ! Dummy argument: filepath for file containing namelist input @@ -154,7 +175,7 @@ subroutine air_composition_readnl(nlfile) character(len=lsize) :: bline ! Variable components of dry air and water species in air - namelist /air_composition_nl/ dry_air_species, water_species_in_air + namelist /air_composition_nl/ dry_air_species, water_species_in_air, compute_enthalpy_flux !----------------------------------------------------------------------- banner = repeat('*', lsize) @@ -176,6 +197,9 @@ subroutine air_composition_readnl(nlfile) close(unitn) end if + call mpi_bcast(compute_enthalpy_flux, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: compute_enthalpy_flux") + call mpi_bcast(dry_air_species, len(dry_air_species)*num_names_max, & mpi_character, masterprocid, mpicom, ierr) if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: dry_air_species") @@ -201,6 +225,9 @@ subroutine air_composition_readnl(nlfile) dry_air_species_num + water_species_in_air_num if (masterproc) then + if (compute_enthalpy_flux) then + write(iulog, *) "Computing enthalpy flux: compute_enthalpy_flux=",compute_enthalpy_flux + endif write(iulog, *) banner write(iulog, *) bline @@ -232,7 +259,7 @@ subroutine air_composition_init() use string_utils, only: int2str use spmd_utils, only: masterproc use cam_logfile, only: iulog - use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry + use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry, cpwv, latice, latvap, tmelt use constituents, only: cnst_get_ind, cnst_mw use ppgrid, only: pcols, pver, begchunk, endchunk integer :: icnst, ix, isize, ierr, idx @@ -338,7 +365,7 @@ subroutine air_composition_init() if (ierr /= 0) then call endrun(errstr//"cp_or_cv_dycore") end if - + allocate(te_init(pcols,4,begchunk:endchunk), stat=ierr)!xxx to be removed thermodynamic_active_species_idx = -HUGE(1) thermodynamic_active_species_idx_dycore = -HUGE(1) thermodynamic_active_species_cp = 0.0_r8 @@ -619,11 +646,57 @@ subroutine air_composition_init() (1 + liq_num + ice_num), " (1 + liq_num + ice_num)" call endrun(subname//': water_species_in_air_num /= 1+liq_num+ice_num') end if + + ! hard-wiring here enthalpy_reference_state = 'ice' if (masterproc) then - write(iulog, *) 'Enthalpy reference state : ', & - TRIM(enthalpy_reference_state) + write(iulog,'(a)')'Enthalpy reference state : '//trim(enthalpy_reference_state) end if + + ! Initialising t00's, h00's here + ! N.B. latent heats should be adjusted to t00a, but unless t00a=tmelt, + ! this will break all physics + ! physics and SE dycore make different, mutually inconsistent, + ! hard-wired assumptions on t00 and h00: + ! physics : t00=tmelt, h00(ice)=L(ice; liq, T=tmelt) + ! dynamics (SE): t00=0, h00=0 + ! As a result, any water non-conservation in the dycore results in fixer + ! increments, proportional to h00a as set below. + + ! ocean choice for enthalpy at T=0 (liquid reference phase) + t00o = tmelt + h00o = -cpliq*t00o + + ! atmo choices for enthalpy at T=0 (liquid ref. phase): + if (.not.compute_enthalpy_flux)then + t00a = 0._r8 + h00a = 0._r8 + h00a_ice = 0._r8 + h00a_vap = 0._r8 + else + t00a = tmelt + h00a = -cpliq*t00a + if (enthalpy_reference_state == 'ice') then + !h00a =-((cpliq-cpice)*t00a - latice) ! cam default h00a_ice=0 (minimizes fixer increments) + h00a = -cpliq*t00a ! conserve single formula for global energy + else if (enthalpy_reference_state.eq.'vap') then + h00a =-((cpliq-cpwv )*t00a + latvap) + endif + ! the following ensure that the value of atmospheric enthalpy is independent of reference state + h00a_vap = h00a + ((cpliq-cpwv )*t00a + latvap) + h00a_ice = h00a + ((cpliq-cpice)*t00a - latice) + endif + + if (masterproc) then + write(iulog, *) ' ocean t00o: ', t00o + write(iulog, *) ' ocean h00o: ', h00o + write(iulog, *) 'atmos. enthalpy_reference_state: ', trim(enthalpy_reference_state) + write(iulog, *) ' t00a: ', t00a + write(iulog, *) ' h00a: ', h00a + write(iulog, *) ' h00a_ice: ', h00a_ice + write(iulog, *) ' h00a_vap: ', h00a_vap + endif + end subroutine air_composition_init !=========================================================================== @@ -674,7 +747,7 @@ subroutine water_composition_update(mmr, lchnk, ncol, vcoord, to_dry_factor) call get_R(mmr(:ncol,:,:), thermodynamic_active_species_idx, & cp_or_cv_dycore(:ncol,:,lchnk), fact=to_dry_factor, Rdry=rairv(:ncol,:,lchnk)) ! - ! internal energy coefficient for MPAS + ! internal energy coefficient for MPAS ! (equation 92 in Eldred et al. 2023; https://rmets.onlinelibrary.wiley.com/doi/epdf/10.1002/qj.4353) ! cp_or_cv_dycore(:ncol,:,lchnk)=cp_or_cv_dycore(:ncol,:,lchnk)*& From 31d5ede3356dd8d47e5256f661b9d85c2cb44c42 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 16 Aug 2025 23:29:24 +0200 Subject: [PATCH 07/78] refactored src/control/camsrfexch.F90 --- src/control/camsrfexch.F90 | 319 +++++--- .../camnor_phys/physics/camsrfexch.F90 | 708 ------------------ 2 files changed, 214 insertions(+), 813 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/camsrfexch.F90 diff --git a/src/control/camsrfexch.F90 b/src/control/camsrfexch.F90 index fbbb7a20c2..512ab818a4 100644 --- a/src/control/camsrfexch.F90 +++ b/src/control/camsrfexch.F90 @@ -16,6 +16,7 @@ module camsrfexch active_Fall_flxdst1, active_Fall_flxvoc, active_Fall_flxfire use cam_control_mod, only: aqua_planet, simple_phys + implicit none private @@ -25,7 +26,7 @@ module camsrfexch public atm2hub_deallocate public hub2atm_deallocate public cam_export - + public get_prec_vars ! Public data types public cam_out_t ! Data from atmosphere public cam_in_t ! Merged surface data @@ -52,6 +53,11 @@ module camsrfexch real(r8) :: precsl(pcols) ! real(r8) :: precc(pcols) ! real(r8) :: precl(pcols) ! + real(r8) :: hrain(pcols) ! material enth. flx for liquid precip + real(r8) :: hsnow(pcols) ! material enth. flx for frozen precip + real(r8) :: hevap(pcols) ! material enth. flx for evaporation + real(r8) :: hmat (pcols) ! material enth. flx at surface, total + real(r8) :: hlat (pcols) ! variable latent heat component of hmat real(r8) :: soll(pcols) ! real(r8) :: sols(pcols) ! real(r8) :: solld(pcols) ! @@ -115,6 +121,8 @@ module camsrfexch real(r8) :: icefrac(pcols) ! sea-ice areal fraction real(r8) :: ocnfrac(pcols) ! ocean areal fraction real(r8) :: cflx(pcols,pcnst) ! constituent flux (emissions) + real(r8) :: evap_ocn(pcols) ! evaporation over ocean + real(r8) :: hrof(pcols) ! enthalpy from river runoff real(r8) :: ustar(pcols) ! atm/ocn saved version of ustar real(r8) :: re(pcols) ! atm/ocn saved version of re real(r8) :: ssq(pcols) ! atm/ocn saved version of ssq @@ -250,6 +258,7 @@ subroutine hub2atm_alloc( cam_in ) cam_in(c)%meganflx(:,:) = 0.0_r8 cam_in(c)%cflx (:,:) = 0._r8 + cam_in(c)%evap_ocn (:) = 0._r8 cam_in(c)%ustar (:) = 0._r8 cam_in(c)%re (:) = 0._r8 cam_in(c)%ssq (:) = 0._r8 @@ -329,20 +338,17 @@ subroutine atm2hub_alloc( cam_out ) cam_out(c)%dstwet3(:) = 0._r8 cam_out(c)%dstdry4(:) = 0._r8 cam_out(c)%dstwet4(:) = 0._r8 + cam_out(c)%hevap(:) = 0._r8 nullify(cam_out(c)%nhx_nitrogen_flx) nullify(cam_out(c)%noy_nitrogen_flx) - - if (.not. (simple_phys .or. aqua_planet)) then - - allocate (cam_out(c)%nhx_nitrogen_flx(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error nhx_nitrogen_flx') - cam_out(c)%nhx_nitrogen_flx(:) = 0._r8 - - allocate (cam_out(c)%noy_nitrogen_flx(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error noy_nitrogen_flx') - cam_out(c)%noy_nitrogen_flx(:) = 0._r8 - + if (.not.(simple_phys .or. aqua_planet)) then + allocate (cam_out(c)%nhx_nitrogen_flx(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error nhx_nitrogen_flx') + cam_out(c)%nhx_nitrogen_flx(:) = 0._r8 + allocate (cam_out(c)%noy_nitrogen_flx(pcols), stat=ierror) + if ( ierror /= 0 ) call endrun(sub//': allocation error noy_nitrogen_flx') + cam_out(c)%noy_nitrogen_flx(:) = 0._r8 endif end do @@ -410,7 +416,7 @@ end subroutine hub2atm_deallocate !====================================================================== -subroutine cam_export(state,cam_out,pbuf) +subroutine cam_export(state,cam_in,cam_out,pbuf) ! Transfer atmospheric fields into necessary surface data structures @@ -419,16 +425,20 @@ subroutine cam_export(state,cam_out,pbuf) use cam_history, only: outfld use chem_surfvals, only: chem_surfvals_get use co2_cycle, only: co2_transport, c_i - use physconst, only: rair, mwdry, mwco2, gravit, mwo3 + use physconst, only: rair, mwdry, mwco2, gravit, mwo3, cpliq, cpice, cpwv, tmelt use constituents, only: pcnst - use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc, pbuf_set_field use rad_constituents, only: rad_cnst_get_gas use cam_control_mod, only: simple_phys - + use air_composition, only: t00a, t00o, h00a, h00o + use air_composition, only: hliq_idx, hice_idx, fliq_idx, fice_idx + use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars + use cam_history, only: outfld !xxx debug implicit none ! Input arguments type(physics_state), intent(in) :: state + type (cam_in_t ), intent(in) :: cam_in type (cam_out_t), intent(inout) :: cam_out type(physics_buffer_desc), pointer :: pbuf(:) @@ -439,23 +449,23 @@ subroutine cam_export(state,cam_out,pbuf) integer :: lchnk ! Chunk index integer :: ncol integer :: psl_idx - integer :: prec_dp_idx, snow_dp_idx, prec_sh_idx, snow_sh_idx - integer :: prec_sed_idx,snow_sed_idx,prec_pcw_idx,snow_pcw_idx integer :: srf_ozone_idx, lightning_idx + integer :: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx + real(r8):: ubot, vbot real(r8), pointer :: psl(:) - real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8), pointer :: snow_dp(:) ! snow from ZM convection - real(r8), pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8), pointer :: snow_sh(:) ! snow from Hack convection - real(r8), pointer :: prec_sed(:) ! total precipitation from ZM convection - real(r8), pointer :: snow_sed(:) ! snow from ZM convection - real(r8), pointer :: prec_pcw(:) ! total precipitation from Hack convection - real(r8), pointer :: snow_pcw(:) ! snow from Hack convection real(r8), pointer :: o3_ptr(:,:), srf_o3_ptr(:) real(r8), pointer :: lightning_ptr(:) + + ! enthalpy variables (if applicable) + real(r8), dimension(:,:), pointer :: enthalpy_prec_ac + real(r8), dimension(:) , pointer :: hevap_ocn + real(r8), dimension(pcols) :: fliq_tot, fice_tot + real(r8), dimension(pcols,num_enthalpy_vars) :: enthalpy_prec_bc + + character(len=*), parameter :: sub = 'cam_export' !----------------------------------------------------------------------- lchnk = state%lchnk @@ -464,42 +474,73 @@ subroutine cam_export(state,cam_out,pbuf) psl_idx = pbuf_get_index('PSL') call pbuf_get_field(pbuf, psl_idx, psl) - prec_dp_idx = pbuf_get_index('PREC_DP', errcode=i) - snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=i) - prec_sh_idx = pbuf_get_index('PREC_SH', errcode=i) - snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=i) - prec_sed_idx = pbuf_get_index('PREC_SED', errcode=i) - snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=i) - prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=i) - snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=i) + if (compute_enthalpy_flux) then + enthalpy_prec_bc_idx = pbuf_get_index('ENTHALPY_PREC_BC', errcode=i) + enthalpy_prec_ac_idx = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) + if (enthalpy_prec_bc_idx==0.or.enthalpy_prec_ac_idx==0) then + call endrun(sub//": pbufs for enthalpy flux not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) + + !------------------------------------------------------------------ + ! + ! compute precipitation fluxes and set associated physics buffers + ! + !------------------------------------------------------------------ + call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot,& + precc_out=cam_out%precc,precl_out=cam_out%precl,& + precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) + + ! fliq_tot holds liquid precipitation from tphysbc and + ! tphysac from previous physics time-step: back out fliq_bc + ! Idem for ice + enthalpy_prec_bc(:ncol,fice_idx) = fice_tot(:ncol) -enthalpy_prec_ac(:ncol,fice_idx) ! out of atm + enthalpy_prec_bc(:ncol,fliq_idx) = fliq_tot(:ncol) -enthalpy_prec_ac(:ncol,fliq_idx) ! out of atm + + ! compute precipitation enthalpy fluxes from tphysbc + ! correct for reference T of latent heats (liquid reference state), and use tbot (=T(pver), updated later below) + enthalpy_prec_bc(:ncol,hice_idx) = -enthalpy_prec_bc(:ncol,fice_idx)*(cpice*(state%T(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) + enthalpy_prec_bc(:ncol,hliq_idx) = -enthalpy_prec_bc(:ncol,fliq_idx)*(cpliq*(state%T(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) + + ! export all prec_bc to pbuf + call pbuf_set_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) + + ! Compute enthalpy fluxes for the coupler: + cam_out%hsnow(:ncol) = enthalpy_prec_bc(:ncol,hice_idx)+enthalpy_prec_ac(:ncol,hice_idx) ! into atm + cam_out%hrain(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hliq_idx) ! into atm + + ! change enthalpy flux to sign convention of ocean model and change zero points + cam_out%hsnow(:ncol) = -cam_out%hsnow(:ncol) + fice_tot(:ncol)*((h00o-h00a)+(cpliq-cpice)*(t00o-t00a)) ! into ocn; fice_tot is out of atm + cam_out%hrain(:ncol) = -cam_out%hrain(:ncol) + fliq_tot(:ncol)* (h00o-h00a)! +0. ! into ocn; fliq_tot is out of atm + + ! hevap is one time-step old, consistently with rest of enthalpy_prec_ac + enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP', errcode=i) + if (enthalpy_evop_idx==0) then + call endrun(sub//": pbuf for enthalpy evop not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_evop_idx, hevap_ocn) + cam_out%hevap(:ncol) = -hevap_ocn(:ncol) - cam_in%evap_ocn(:ncol)*((h00o-h00a)+(cpliq-cpwv )*(t00o-t00a)) ! into ocn; cflux is into atm + + !call outfld("hsnow_liq_ref" , cam_out%hsnow, pcols ,lchnk )! debug + !call outfld("hrain_liq_ref" , cam_out%hrain, pcols ,lchnk )! debug + !call outfld("hevap_liq_ref" , cam_out%hevap, pcols ,lchnk )! debug + + cam_out%hmat(:ncol) = cam_out%hsnow(:ncol) + cam_out%hrain(:ncol) + cam_out%hevap(:ncol) ! this is into ocean + ! variable latent heat component + ! N.B.: approximate due to difference between ts and tbot, also note lagged SST + cam_out%hlat(:ncol) = cam_in%evap_ocn(:ncol)*(cpliq-cpwv )*(cam_in%sst(:ncol)-t00a) & + -fice_tot (:ncol)*(cpliq-cpice)*(cam_in%sst(:ncol)-t00a) + else + call get_prec_vars(ncol,pbuf,& + precc_out=cam_out%precc,precl_out=cam_out%precl,& + precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) + cam_out%hmat(:ncol) = 0._r8 + cam_out%hlat(:ncol) = 0._r8 + end if + srf_ozone_idx = pbuf_get_index('SRFOZONE', errcode=i) lightning_idx = pbuf_get_index('LGHT_FLASH_FREQ', errcode=i) - if (prec_dp_idx > 0) then - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) - end if - if (snow_dp_idx > 0) then - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) - end if - if (prec_sh_idx > 0) then - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) - end if - if (snow_sh_idx > 0) then - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) - end if - if (prec_sed_idx > 0) then - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) - end if - if (snow_sed_idx > 0) then - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) - end if - if (prec_pcw_idx > 0) then - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) - end if - if (snow_pcw_idx > 0) then - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) - end if - do i=1,ncol cam_out%tbot(i) = state%t(i,pver) cam_out%thbot(i) = state%t(i,pver) * state%exner(i,pver) @@ -510,7 +551,6 @@ subroutine cam_export(state,cam_out,pbuf) cam_out%pbot(i) = state%pmid(i,pver) cam_out%psl(i) = psl(i) cam_out%rho(i) = cam_out%pbot(i)/(rair*cam_out%tbot(i)) - ! Direction of bottom level wind ubot = state%u(i,pver) vbot = state%v(i,pver) @@ -547,51 +587,120 @@ subroutine cam_export(state,cam_out,pbuf) call pbuf_get_field(pbuf, lightning_idx, lightning_ptr) cam_out%lightning_flash_freq(:ncol) = lightning_ptr(:ncol) end if - - ! - ! Precipation and snow rates from shallow convection, deep convection and stratiform processes. - ! Compute total convective and stratiform precipitation and snow rates - ! - do i=1,ncol - cam_out%precc (i) = 0._r8 - cam_out%precl (i) = 0._r8 - cam_out%precsc(i) = 0._r8 - cam_out%precsl(i) = 0._r8 - if (prec_dp_idx > 0) then - cam_out%precc (i) = cam_out%precc (i) + prec_dp(i) - end if - if (prec_sh_idx > 0) then - cam_out%precc (i) = cam_out%precc (i) + prec_sh(i) - end if - if (prec_sed_idx > 0) then - cam_out%precl (i) = cam_out%precl (i) + prec_sed(i) - end if - if (prec_pcw_idx > 0) then - cam_out%precl (i) = cam_out%precl (i) + prec_pcw(i) - end if - if (snow_dp_idx > 0) then - cam_out%precsc(i) = cam_out%precsc(i) + snow_dp(i) - end if - if (snow_sh_idx > 0) then - cam_out%precsc(i) = cam_out%precsc(i) + snow_sh(i) - end if - if (snow_sed_idx > 0) then - cam_out%precsl(i) = cam_out%precsl(i) + snow_sed(i) - end if - if (snow_pcw_idx > 0) then - cam_out%precsl(i) = cam_out%precsl(i) + snow_pcw(i) - end if - - ! jrm These checks should not be necessary if they exist in the parameterizations - if (cam_out%precc(i) .lt.0._r8) cam_out%precc(i)=0._r8 - if (cam_out%precl(i) .lt.0._r8) cam_out%precl(i)=0._r8 - if (cam_out%precsc(i).lt.0._r8) cam_out%precsc(i)=0._r8 - if (cam_out%precsl(i).lt.0._r8) cam_out%precsl(i)=0._r8 - if (cam_out%precsc(i).gt.cam_out%precc(i)) cam_out%precsc(i)=cam_out%precc(i) - if (cam_out%precsl(i).gt.cam_out%precl(i)) cam_out%precsl(i)=cam_out%precl(i) - - end do - end subroutine cam_export +! +! Precipation and snow rates from shallow convection, deep convection and stratiform processes. +! Compute total convective and stratiform precipitation and snow rates +! +subroutine get_prec_vars(ncol,pbuf,fliq,fice, precc_out,precl_out,precsc_out,precsl_out) + use ppgrid, only: pcols + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc + + integer, intent(in) :: ncol + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), dimension(pcols) , optional, intent(out):: fliq!rain flux (out of atm) in SI units + real(r8), dimension(pcols) , optional, intent(out):: fice!snow flux (out of atm) in SI units + + real(r8), dimension(pcols), optional, intent(out):: precc_out !total precipitation from convection + real(r8), dimension(pcols), optional, intent(out):: precl_out !total large scale precipitation + real(r8), dimension(pcols), optional, intent(out):: precsc_out!frozen precipitation from convection + real(r8), dimension(pcols), optional, intent(out):: precsl_out!frozen large scale precipitation + + integer :: i + + real(r8), pointer :: prec_dp(:) !total precipitation from from deep convection + real(r8), pointer :: snow_dp(:) !frozen precipitation from deep convection + real(r8), pointer :: prec_sh(:) !total precipitation from shallow convection + real(r8), pointer :: snow_sh(:) !frozen precipitation from from shallow convection + real(r8), pointer :: prec_sed(:) !total precipitation from cloud sedimentation + real(r8), pointer :: snow_sed(:) !frozen precipitation from sedimentation + real(r8), pointer :: prec_pcw(:) !total precipitation from from microphysics + real(r8), pointer :: snow_pcw(:) !frozen precipitation from from microphysics + + real(r8), dimension(pcols):: precc, precl, precsc, precsl + integer :: prec_dp_idx, snow_dp_idx, prec_sh_idx, snow_sh_idx + integer :: prec_sed_idx,snow_sed_idx,prec_pcw_idx,snow_pcw_idx + ! + ! get fields from pbuf + ! + prec_dp_idx = pbuf_get_index('PREC_DP', errcode=i) + snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=i) + prec_sh_idx = pbuf_get_index('PREC_SH', errcode=i) + snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=i) + prec_sed_idx = pbuf_get_index('PREC_SED', errcode=i) + snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=i) + prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=i) + snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=i) + + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) + end if + if (snow_dp_idx > 0) then + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) + end if + if (snow_sh_idx > 0) then + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) + end if + if (prec_sed_idx > 0) then + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) + end if + if (snow_sed_idx > 0) then + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) + end if + if (prec_pcw_idx > 0) then + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) + end if + if (snow_pcw_idx > 0) then + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) + end if + + precc = 0._r8 + precl = 0._r8 + precsc = 0._r8 + precsl = 0._r8 + if (prec_dp_idx > 0) then + precc(:ncol) = precc(:ncol) + prec_dp(:ncol) + end if + if (prec_sh_idx > 0) then + precc(:ncol) = precc(:ncol) + prec_sh(:ncol) + end if + if (prec_sed_idx > 0) then + precl(:ncol) = precl(1:ncol) + prec_sed(:ncol) + end if + if (prec_pcw_idx > 0) then + precl(:ncol) = precl(1:ncol) + prec_pcw(:ncol) + end if + if (snow_dp_idx > 0) then + precsc(:ncol) = precsc(:ncol) + snow_dp(:ncol) + end if + if (snow_sh_idx > 0) then + precsc(:ncol) = precsc(:ncol) + snow_sh(:ncol) + end if + if (snow_sed_idx > 0) then + precsl(:ncol) = precsl(:ncol) + snow_sed(:ncol) + end if + if (snow_pcw_idx > 0) then + precsl(:ncol)= precsl(:ncol) + snow_pcw(:ncol) + end if + + do i=1,ncol + precc(i) = MAX(precc(i), 0.0_r8) + precl(i) = MAX(precl(i), 0.0_r8) + precsc(i) = MAX(precsc(i),0.0_r8) + precsl(i) = MAX(precsl(i),0.0_r8) + if (precsc(i).gt.precc(i)) precsc(i)=precc(i) + if (precsl(i).gt.precl(i)) precsl(i)=precl(i) + end do + if (present(precc_out )) precc_out (:ncol) = precc (:ncol) + if (present(precl_out )) precl_out (:ncol) = precl (:ncol) + if (present(precsc_out)) precsc_out(:ncol) = precsc(:ncol) + if (present(precsl_out)) precsl_out(:ncol) = precsl(:ncol) + + if (present(fice)) fice(:ncol) = 1000.0_r8*(precsc(:ncol)+precsl(:ncol)) !snow flux + if (present(fliq)) fliq(:ncol) = 1000.0_r8*(precc (:ncol)-precsc(:ncol)+precl(:ncol)-precsl(:ncol))!rain flux + end subroutine get_prec_vars end module camsrfexch diff --git a/src/physics/camnor_phys/physics/camsrfexch.F90 b/src/physics/camnor_phys/physics/camsrfexch.F90 deleted file mode 100644 index 1dea2a7d10..0000000000 --- a/src/physics/camnor_phys/physics/camsrfexch.F90 +++ /dev/null @@ -1,708 +0,0 @@ -module camsrfexch - - !----------------------------------------------------------------------- - ! Module to handle data that is exchanged between the CAM atmosphere - ! model and the surface models (land, sea-ice, and ocean). - !----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use constituents, only: pcnst - use ppgrid, only: pcols, begchunk, endchunk - use phys_grid, only: get_ncols_p, phys_grid_initialized - use infnan, only: posinf, assignment(=) - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use srf_field_check, only: active_Sl_ram1, active_Sl_fv, active_Sl_soilw, & - active_Fall_flxdst1, active_Fall_flxvoc, active_Fall_flxfire - use cam_control_mod, only: aqua_planet, simple_phys - - - implicit none - private - - ! Public interfaces - public atm2hub_alloc ! Atmosphere to surface data allocation method - public hub2atm_alloc ! Merged hub surface to atmosphere data allocation method - public atm2hub_deallocate - public hub2atm_deallocate - public cam_export - public get_prec_vars - ! Public data types - public cam_out_t ! Data from atmosphere - public cam_in_t ! Merged surface data - - !--------------------------------------------------------------------------- - ! This is the data that is sent from the atmosphere to the surface models - !--------------------------------------------------------------------------- - - type cam_out_t - integer :: lchnk ! chunk index - integer :: ncol ! number of columns in chunk - real(r8) :: tbot(pcols) ! bot level temperature - real(r8) :: zbot(pcols) ! bot level height above surface - real(r8) :: topo(pcols) ! surface topographic height (m) - real(r8) :: ubot(pcols) ! bot level u wind - real(r8) :: vbot(pcols) ! bot level v wind - real(r8) :: wind_dir(pcols) ! direction of bottom level wind - real(r8) :: qbot(pcols,pcnst) ! bot level specific humidity - real(r8) :: pbot(pcols) ! bot level pressure - real(r8) :: rho(pcols) ! bot level density - real(r8) :: netsw(pcols) ! - real(r8) :: flwds(pcols) ! - real(r8) :: precsc(pcols) ! - real(r8) :: precsl(pcols) ! - real(r8) :: precc(pcols) ! - real(r8) :: precl(pcols) ! - real(r8) :: hrain(pcols) ! material enth. flx for liquid precip - real(r8) :: hsnow(pcols) ! material enth. flx for frozen precip - real(r8) :: hevap(pcols) ! material enth. flx for evaporation - real(r8) :: hmat (pcols) ! material enth. flx at surface, total - real(r8) :: hlat (pcols) ! variable latent heat component of hmat - real(r8) :: soll(pcols) ! - real(r8) :: sols(pcols) ! - real(r8) :: solld(pcols) ! - real(r8) :: solsd(pcols) ! - real(r8) :: thbot(pcols) ! - real(r8) :: co2prog(pcols) ! prognostic co2 - real(r8) :: co2diag(pcols) ! diagnostic co2 - real(r8) :: ozone(pcols) ! surface ozone concentration (mole/mole) - real(r8) :: lightning_flash_freq(pcols) ! cloud-to-ground lightning flash frequency (/min) - real(r8) :: psl(pcols) - real(r8) :: bcphiwet(pcols) ! wet deposition of hydrophilic black carbon - real(r8) :: bcphidry(pcols) ! dry deposition of hydrophilic black carbon - real(r8) :: bcphodry(pcols) ! dry deposition of hydrophobic black carbon - real(r8) :: ocphiwet(pcols) ! wet deposition of hydrophilic organic carbon - real(r8) :: ocphidry(pcols) ! dry deposition of hydrophilic organic carbon - real(r8) :: ocphodry(pcols) ! dry deposition of hydrophobic organic carbon - real(r8) :: dstwet1(pcols) ! wet deposition of dust (bin1) - real(r8) :: dstdry1(pcols) ! dry deposition of dust (bin1) - real(r8) :: dstwet2(pcols) ! wet deposition of dust (bin2) - real(r8) :: dstdry2(pcols) ! dry deposition of dust (bin2) - real(r8) :: dstwet3(pcols) ! wet deposition of dust (bin3) - real(r8) :: dstdry3(pcols) ! dry deposition of dust (bin3) - real(r8) :: dstwet4(pcols) ! wet deposition of dust (bin4) - real(r8) :: dstdry4(pcols) ! dry deposition of dust (bin4) - real(r8), pointer, dimension(:) :: nhx_nitrogen_flx ! nitrogen deposition fluxes (kgN/m2/s) - real(r8), pointer, dimension(:) :: noy_nitrogen_flx ! nitrogen deposition fluxes (kgN/m2/s) - end type cam_out_t - - !--------------------------------------------------------------------------- - ! This is the merged state of sea-ice, land and ocean surface parameterizations - !--------------------------------------------------------------------------- - - type cam_in_t - integer :: lchnk ! chunk index - integer :: ncol ! number of active columns - real(r8) :: asdir(pcols) ! albedo: shortwave, direct - real(r8) :: asdif(pcols) ! albedo: shortwave, diffuse - real(r8) :: aldir(pcols) ! albedo: longwave, direct - real(r8) :: aldif(pcols) ! albedo: longwave, diffuse - real(r8) :: lwup(pcols) ! longwave up radiative flux - real(r8) :: lhf(pcols) ! latent heat flux - real(r8) :: shf(pcols) ! sensible heat flux - real(r8) :: wsx(pcols) ! surface u-stress (N) - real(r8) :: wsy(pcols) ! surface v-stress (N) - real(r8) :: tref(pcols) ! ref height surface air temp - real(r8) :: qref(pcols) ! ref height specific humidity - real(r8) :: u10(pcols) ! 10m wind speed - real(r8) :: ugustOut(pcols) ! gustiness added - real(r8) :: u10withGusts(pcols) ! 10m wind speed with gusts added - real(r8) :: ts(pcols) ! merged surface temp - real(r8) :: sst(pcols) ! sea surface temp - real(r8) :: snowhland(pcols) ! snow depth (liquid water equivalent) over land - real(r8) :: snowhice(pcols) ! snow depth over ice - real(r8) :: fco2_lnd(pcols) ! co2 flux from lnd - real(r8) :: fco2_ocn(pcols) ! co2 flux from ocn - real(r8) :: fdms(pcols) ! dms flux from ocn - real(r8) :: fbrf(pcols) ! bromoform flux from ocn - real(r8) :: fn2o_ocn(pcols) ! n2o flux from ocn - real(r8) :: fnh3_ocn(pcols) ! nh3 flux from ocn - real(r8) :: landfrac(pcols) ! land area fraction - real(r8) :: icefrac(pcols) ! sea-ice areal fraction - real(r8) :: ocnfrac(pcols) ! ocean areal fraction - real(r8) :: cflx(pcols,pcnst) ! constituent flux (emissions) - real(r8) :: evap_ocn(pcols) !+tht evaporation over ocean - real(r8) :: hrof (pcols) !+tht evaporation over ocean - real(r8) :: ustar(pcols) ! atm/ocn saved version of ustar - real(r8) :: re(pcols) ! atm/ocn saved version of re - real(r8) :: ssq(pcols) ! atm/ocn saved version of ssq - real(r8), pointer, dimension(:) :: ram1 !aerodynamical resistance (s/m) (pcols) - real(r8), pointer, dimension(:) :: fv !friction velocity (m/s) (pcols) - real(r8), pointer, dimension(:) :: soilw !volumetric soil water (m3/m3) - real(r8), pointer, dimension(:,:) :: depvel ! deposition velocities - real(r8), pointer, dimension(:,:) :: dstflx ! dust fluxes - real(r8), pointer, dimension(:,:) :: meganflx ! MEGAN fluxes - real(r8), pointer, dimension(:,:) :: fireflx ! wild fire emissions - real(r8), pointer, dimension(:) :: fireztop ! wild fire emissions vert distribution top - end type cam_in_t - -!=============================================================================== -CONTAINS -!=============================================================================== - - subroutine hub2atm_alloc( cam_in ) - - ! Allocate space for the surface to atmosphere data type. And initialize - ! the values. - - use shr_drydep_mod, only: n_drydep - use shr_megan_mod, only: shr_megan_mechcomps_n - use shr_fire_emis_mod,only: shr_fire_emis_mechcomps_n - - ! ARGUMENTS: - type(cam_in_t), pointer :: cam_in(:) ! Merged surface state - - ! LOCAL VARIABLES: - integer :: c ! chunk index - integer :: ierror ! Error code - character(len=*), parameter :: sub = 'hub2atm_alloc' - !----------------------------------------------------------------------- - - if ( .not. phys_grid_initialized() ) call endrun(sub//": phys_grid not called yet") - allocate (cam_in(begchunk:endchunk), stat=ierror) - if ( ierror /= 0 )then - write(iulog,*) sub//': Allocation error: ', ierror - call endrun(sub//': allocation error') - end if - - do c = begchunk,endchunk - nullify(cam_in(c)%ram1) - nullify(cam_in(c)%fv) - nullify(cam_in(c)%soilw) - nullify(cam_in(c)%depvel) - nullify(cam_in(c)%dstflx) - nullify(cam_in(c)%meganflx) - nullify(cam_in(c)%fireflx) - nullify(cam_in(c)%fireztop) - enddo - do c = begchunk,endchunk - if (active_Sl_ram1) then - allocate (cam_in(c)%ram1(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error ram1') - endif - if (active_Sl_fv) then - allocate (cam_in(c)%fv(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error fv') - endif - if (active_Sl_soilw) then - allocate (cam_in(c)%soilw(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error soilw') - end if - if (active_Fall_flxdst1) then - ! Assume 4 bins from surface model .... - allocate (cam_in(c)%dstflx(pcols,4), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error dstflx') - endif - if (active_Fall_flxvoc .and. shr_megan_mechcomps_n>0) then - allocate (cam_in(c)%meganflx(pcols,shr_megan_mechcomps_n), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error meganflx') - endif - end do - - if (n_drydep>0) then - do c = begchunk,endchunk - allocate (cam_in(c)%depvel(pcols,n_drydep), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error depvel') - end do - endif - - if (active_Fall_flxfire .and. shr_fire_emis_mechcomps_n>0) then - do c = begchunk,endchunk - allocate(cam_in(c)%fireflx(pcols,shr_fire_emis_mechcomps_n), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error fireflx') - allocate(cam_in(c)%fireztop(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error fireztop') - enddo - endif - - do c = begchunk,endchunk - cam_in(c)%lchnk = c - cam_in(c)%ncol = get_ncols_p(c) - cam_in(c)%asdir (:) = 0._r8 - cam_in(c)%asdif (:) = 0._r8 - cam_in(c)%aldir (:) = 0._r8 - cam_in(c)%aldif (:) = 0._r8 - cam_in(c)%lwup (:) = 0._r8 - cam_in(c)%lhf (:) = 0._r8 - cam_in(c)%shf (:) = 0._r8 - cam_in(c)%wsx (:) = 0._r8 - cam_in(c)%wsy (:) = 0._r8 - cam_in(c)%tref (:) = 0._r8 - cam_in(c)%qref (:) = 0._r8 - cam_in(c)%u10 (:) = 0._r8 - cam_in(c)%ugustOut (:) = 0._r8 - cam_in(c)%u10withGusts (:) = 0._r8 - cam_in(c)%ts (:) = 0._r8 - cam_in(c)%sst (:) = 0._r8 - cam_in(c)%snowhland(:) = 0._r8 - cam_in(c)%snowhice (:) = 0._r8 - cam_in(c)%fco2_lnd (:) = 0._r8 - cam_in(c)%fco2_ocn (:) = 0._r8 - cam_in(c)%fdms (:) = 0._r8 - cam_in(c)%fbrf (:) = 0._r8 - cam_in(c)%fn2o_ocn (:) = 0._r8 - cam_in(c)%fnh3_ocn (:) = 0._r8 - cam_in(c)%landfrac (:) = posinf - cam_in(c)%icefrac (:) = posinf - cam_in(c)%ocnfrac (:) = posinf - - if (associated(cam_in(c)%ram1)) & - cam_in(c)%ram1 (:) = 0.1_r8 - if (associated(cam_in(c)%fv)) & - cam_in(c)%fv (:) = 0.1_r8 - if (associated(cam_in(c)%soilw)) & - cam_in(c)%soilw (:) = 0.0_r8 - if (associated(cam_in(c)%dstflx)) & - cam_in(c)%dstflx(:,:) = 0.0_r8 - if (associated(cam_in(c)%meganflx)) & - cam_in(c)%meganflx(:,:) = 0.0_r8 - - cam_in(c)%cflx (:,:) = 0._r8 - cam_in(c)%evap_ocn (:) = 0._r8 - cam_in(c)%ustar (:) = 0._r8 - cam_in(c)%re (:) = 0._r8 - cam_in(c)%ssq (:) = 0._r8 - if (n_drydep>0) then - cam_in(c)%depvel (:,:) = 0._r8 - endif - if (active_Fall_flxfire .and. shr_fire_emis_mechcomps_n>0) then - cam_in(c)%fireflx(:,:) = 0._r8 - cam_in(c)%fireztop(:) = 0._r8 - endif - end do - - end subroutine hub2atm_alloc - - !=============================================================================== - - subroutine atm2hub_alloc( cam_out ) - - ! Allocate space for the atmosphere to surface data type. And initialize - ! the values. - - ! ARGUMENTS: - type(cam_out_t), pointer :: cam_out(:) ! Atmosphere to surface input - - ! LOCAL VARIABLES: - integer :: c ! chunk index - integer :: ierror ! Error code - character(len=*), parameter :: sub = 'atm2hub_alloc' - !----------------------------------------------------------------------- - - if (.not. phys_grid_initialized()) call endrun(sub//": phys_grid not called yet") - allocate (cam_out(begchunk:endchunk), stat=ierror) - if ( ierror /= 0 )then - write(iulog,*) sub//': Allocation error: ', ierror - call endrun(sub//': allocation error: cam_out') - end if - - do c = begchunk,endchunk - cam_out(c)%lchnk = c - cam_out(c)%ncol = get_ncols_p(c) - cam_out(c)%tbot(:) = 0._r8 - cam_out(c)%zbot(:) = 0._r8 - cam_out(c)%topo(:) = 0._r8 - cam_out(c)%ubot(:) = 0._r8 - cam_out(c)%vbot(:) = 0._r8 - cam_out(c)%wind_dir(:) = 0._r8 - cam_out(c)%qbot(:,:) = 0._r8 - cam_out(c)%pbot(:) = 0._r8 - cam_out(c)%rho(:) = 0._r8 - cam_out(c)%netsw(:) = 0._r8 - cam_out(c)%flwds(:) = 0._r8 - cam_out(c)%precsc(:) = 0._r8 - cam_out(c)%precsl(:) = 0._r8 - cam_out(c)%precc(:) = 0._r8 - cam_out(c)%precl(:) = 0._r8 - cam_out(c)%soll(:) = 0._r8 - cam_out(c)%sols(:) = 0._r8 - cam_out(c)%solld(:) = 0._r8 - cam_out(c)%solsd(:) = 0._r8 - cam_out(c)%thbot(:) = 0._r8 - cam_out(c)%co2prog(:) = 0._r8 - cam_out(c)%co2diag(:) = 0._r8 - cam_out(c)%ozone(:) = 0._r8 - cam_out(c)%lightning_flash_freq(:) = 0._r8 - cam_out(c)%psl(:) = 0._r8 - cam_out(c)%bcphidry(:) = 0._r8 - cam_out(c)%bcphodry(:) = 0._r8 - cam_out(c)%bcphiwet(:) = 0._r8 - cam_out(c)%ocphidry(:) = 0._r8 - cam_out(c)%ocphodry(:) = 0._r8 - cam_out(c)%ocphiwet(:) = 0._r8 - cam_out(c)%dstdry1(:) = 0._r8 - cam_out(c)%dstwet1(:) = 0._r8 - cam_out(c)%dstdry2(:) = 0._r8 - cam_out(c)%dstwet2(:) = 0._r8 - cam_out(c)%dstdry3(:) = 0._r8 - cam_out(c)%dstwet3(:) = 0._r8 - cam_out(c)%dstdry4(:) = 0._r8 - cam_out(c)%dstwet4(:) = 0._r8 - - cam_out(c)%hevap(:) = 0._r8 !+tht - - nullify(cam_out(c)%nhx_nitrogen_flx) - nullify(cam_out(c)%noy_nitrogen_flx) - if (.not.(simple_phys .or. aqua_planet)) then - allocate (cam_out(c)%nhx_nitrogen_flx(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error nhx_nitrogen_flx') - cam_out(c)%nhx_nitrogen_flx(:) = 0._r8 - allocate (cam_out(c)%noy_nitrogen_flx(pcols), stat=ierror) - if ( ierror /= 0 ) call endrun(sub//': allocation error noy_nitrogen_flx') - cam_out(c)%noy_nitrogen_flx(:) = 0._r8 - endif - - end do - - end subroutine atm2hub_alloc - - !=============================================================================== - - subroutine atm2hub_deallocate(cam_out) - - type(cam_out_t), pointer :: cam_out(:) ! Atmosphere to surface input - !----------------------------------------------------------------------- - - if(associated(cam_out)) then - deallocate(cam_out) - end if - nullify(cam_out) - - end subroutine atm2hub_deallocate - - !=============================================================================== - - subroutine hub2atm_deallocate(cam_in) - - type(cam_in_t), pointer :: cam_in(:) ! Atmosphere to surface input - - integer :: c - !----------------------------------------------------------------------- - - if(associated(cam_in)) then - do c=begchunk,endchunk - if(associated(cam_in(c)%ram1)) then - deallocate(cam_in(c)%ram1) - nullify(cam_in(c)%ram1) - end if - if(associated(cam_in(c)%fv)) then - deallocate(cam_in(c)%fv) - nullify(cam_in(c)%fv) - end if - if(associated(cam_in(c)%soilw)) then - deallocate(cam_in(c)%soilw) - nullify(cam_in(c)%soilw) - end if - if(associated(cam_in(c)%dstflx)) then - deallocate(cam_in(c)%dstflx) - nullify(cam_in(c)%dstflx) - end if - if(associated(cam_in(c)%meganflx)) then - deallocate(cam_in(c)%meganflx) - nullify(cam_in(c)%meganflx) - end if - if(associated(cam_in(c)%depvel)) then - deallocate(cam_in(c)%depvel) - nullify(cam_in(c)%depvel) - end if - - enddo - - deallocate(cam_in) - end if - nullify(cam_in) - - end subroutine hub2atm_deallocate - - -!====================================================================== - -subroutine cam_export(state,cam_in,cam_out,pbuf) - - ! Transfer atmospheric fields into necessary surface data structures - - use physics_types, only: physics_state - use ppgrid, only: pver - use cam_history, only: outfld - use chem_surfvals, only: chem_surfvals_get - use co2_cycle, only: co2_transport, c_i - use physconst, only: rair, mwdry, mwco2, gravit, mwo3, cpliq, cpice, cpwv, tmelt - use air_composition, only: t00a, t00o, h00a, h00o - use constituents, only: pcnst - use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc, pbuf_set_field - use rad_constituents, only: rad_cnst_get_gas - use cam_control_mod, only: simple_phys - use air_composition, only: hliq_idx, hice_idx, fliq_idx, fice_idx - use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars - use cam_history, only: outfld!xxx debug - implicit none - - ! Input arguments - type(physics_state), intent(in) :: state - type (cam_in_t ), intent(in) :: cam_in - type (cam_out_t), intent(inout) :: cam_out - type(physics_buffer_desc), pointer :: pbuf(:) - - ! Local variables - - integer :: i ! Longitude index - integer :: m ! constituent index - integer :: lchnk ! Chunk index - integer :: ncol - integer :: psl_idx - integer :: srf_ozone_idx, lightning_idx - integer :: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx !tht - - real(r8):: ubot, vbot - - real(r8), pointer :: psl(:) - - real(r8), pointer :: o3_ptr(:,:), srf_o3_ptr(:) - real(r8), pointer :: lightning_ptr(:) - - ! enthalpy variables (if applicable) - real(r8), dimension(:,:), pointer :: enthalpy_prec_ac - real(r8), dimension(:) , pointer :: hevap_ocn - real(r8), dimension(pcols) :: fliq_tot, fice_tot - real(r8), dimension(pcols,num_enthalpy_vars) :: enthalpy_prec_bc - - character(len=*), parameter :: sub = 'cam_export' - !----------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - - psl_idx = pbuf_get_index('PSL') - call pbuf_get_field(pbuf, psl_idx, psl) - - if (compute_enthalpy_flux) then - enthalpy_prec_bc_idx = pbuf_get_index('ENTHALPY_PREC_BC', errcode=i) - enthalpy_prec_ac_idx = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) - if (enthalpy_prec_bc_idx==0.or.enthalpy_prec_ac_idx==0) then !tht - call endrun(sub//": pbufs for enthalpy flux not allocated") - end if - call pbuf_get_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) - - !------------------------------------------------------------------ - ! - ! compute precipitation fluxes and set associated physics buffers - ! - !------------------------------------------------------------------ - call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot,& - precc_out=cam_out%precc,precl_out=cam_out%precl,& - precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) - - ! fliq_tot holds liquid precipitation from tphysbc and - ! tphysac from previous physics time-step: back out fliq_bc - ! Idem for ice - enthalpy_prec_bc(:ncol,fice_idx) = fice_tot(:ncol) -enthalpy_prec_ac(:ncol,fice_idx) ! out of atm - enthalpy_prec_bc(:ncol,fliq_idx) = fliq_tot(:ncol) -enthalpy_prec_ac(:ncol,fliq_idx) ! out of atm - - ! compute precipitation enthalpy fluxes from tphysbc - !tht: correct for reference T of latent heats (liquid reference state), and use tbot (=T(pver), updated later below) - enthalpy_prec_bc(:ncol,hice_idx) = -enthalpy_prec_bc(:ncol,fice_idx)*(cpice*(state%T(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) - enthalpy_prec_bc(:ncol,hliq_idx) = -enthalpy_prec_bc(:ncol,fliq_idx)*(cpliq*(state%T(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) - - ! export all prec_bc to pbuf - call pbuf_set_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) - - ! Compute enthalpy fluxes for the coupler: - cam_out%hsnow(:ncol) = enthalpy_prec_bc(:ncol,hice_idx)+enthalpy_prec_ac(:ncol,hice_idx) ! into atm - cam_out%hrain(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hliq_idx) ! into atm - !tht: change enthalpy flux to sign convention of ocean model and change zero points - cam_out%hsnow(:ncol) = -cam_out%hsnow(:ncol) + fice_tot(:ncol)*((h00o-h00a)+(cpliq-cpice)*(t00o-t00a)) ! into ocn; fice_tot is out of atm - cam_out%hrain(:ncol) = -cam_out%hrain(:ncol) + fliq_tot(:ncol)* (h00o-h00a)! +0. ! into ocn; fliq_tot is out of atm - - !+tht: hevap is one time-step old, consistently with rest of enthalpy_prec_ac - enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP', errcode=i) - if (enthalpy_evop_idx==0) then - call endrun(sub//": pbuf for enthalpy evop not allocated") - end if - call pbuf_get_field(pbuf, enthalpy_evop_idx, hevap_ocn) - cam_out%hevap(:ncol) = -hevap_ocn(:ncol) - cam_in%evap_ocn(:ncol)*((h00o-h00a)+(cpliq-cpwv )*(t00o-t00a)) ! into ocn; cflux is into atm - !-tht - - !call outfld("hsnow_liq_ref" , cam_out%hsnow, pcols ,lchnk )!xxx debug - !call outfld("hrain_liq_ref" , cam_out%hrain, pcols ,lchnk )!xxx debug - !call outfld("hevap_liq_ref" , cam_out%hevap, pcols ,lchnk )!xxx debug - - cam_out%hmat(:ncol) = cam_out%hsnow(:ncol) + cam_out%hrain(:ncol) + cam_out%hevap(:ncol) !tht: this is into ocean -!+tht variable latent heat component -! N.B.: approximate due to difference between ts and tbot, also note lagged SST - cam_out%hlat(:ncol) = cam_in%evap_ocn(:ncol)*(cpliq-cpwv )*(cam_in%sst(:ncol)-t00a) & - -fice_tot (:ncol)*(cpliq-cpice)*(cam_in%sst(:ncol)-t00a) -!-tht - else - call get_prec_vars(ncol,pbuf,& - precc_out=cam_out%precc,precl_out=cam_out%precl,& - precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) - cam_out%hmat(:ncol) = 0._r8 - cam_out%hlat(:ncol) = 0._r8 - end if - - srf_ozone_idx = pbuf_get_index('SRFOZONE', errcode=i) - lightning_idx = pbuf_get_index('LGHT_FLASH_FREQ', errcode=i) - - do i=1,ncol - cam_out%tbot(i) = state%t(i,pver) - cam_out%thbot(i) = state%t(i,pver) * state%exner(i,pver) - cam_out%zbot(i) = state%zm(i,pver) - cam_out%topo(i) = state%phis(i) / gravit - cam_out%ubot(i) = state%u(i,pver) - cam_out%vbot(i) = state%v(i,pver) - cam_out%pbot(i) = state%pmid(i,pver) - cam_out%psl(i) = psl(i) - cam_out%rho(i) = cam_out%pbot(i)/(rair*cam_out%tbot(i)) - ! Direction of bottom level wind - ubot = state%u(i,pver) - vbot = state%v(i,pver) - if ((ubot == 0.0_r8) .and. (vbot == 0.0_r8)) then - cam_out%wind_dir(i) = 0.0_r8 ! Default to U for zero wind - else - cam_out%wind_dir(i) = atan2(vbot,ubot) - end if - end do - do m = 1, pcnst - do i = 1, ncol - cam_out%qbot(i,m) = state%q(i,pver,m) - end do - end do - - cam_out%co2diag(:ncol) = chem_surfvals_get('CO2VMR') * 1.0e+6_r8 - if (co2_transport()) then - do i=1,ncol - cam_out%co2prog(i) = state%q(i,pver,c_i(4)) * 1.0e+6_r8 *mwdry/mwco2 - end do - end if - - ! get bottom layer ozone concentrations to export to surface models - if (srf_ozone_idx > 0) then - call pbuf_get_field(pbuf, srf_ozone_idx, srf_o3_ptr) - cam_out%ozone(:ncol) = srf_o3_ptr(:ncol) - else if (.not.simple_phys) then - call rad_cnst_get_gas(0, 'O3', state, pbuf, o3_ptr) - cam_out%ozone(:ncol) = o3_ptr(:ncol,pver) * mwdry/mwo3 ! mole/mole - endif - - ! get cloud to ground lightning flash freq (/min) to export to surface models - if (lightning_idx>0) then - call pbuf_get_field(pbuf, lightning_idx, lightning_ptr) - cam_out%lightning_flash_freq(:ncol) = lightning_ptr(:ncol) - end if -end subroutine cam_export -! -! Precipation and snow rates from shallow convection, deep convection and stratiform processes. -! Compute total convective and stratiform precipitation and snow rates -! -subroutine get_prec_vars(ncol,pbuf,fliq,fice, precc_out,precl_out,precsc_out,precsl_out) - use ppgrid, only: pcols - use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc - - integer, intent(in) :: ncol - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), dimension(pcols) , optional, intent(out):: fliq!rain flux (out of atm) in SI units - real(r8), dimension(pcols) , optional, intent(out):: fice!snow flux (out of atm) in SI units - - real(r8), dimension(pcols), optional, intent(out):: precc_out !total precipitation from convection - real(r8), dimension(pcols), optional, intent(out):: precl_out !total large scale precipitation - real(r8), dimension(pcols), optional, intent(out):: precsc_out!frozen precipitation from convection - real(r8), dimension(pcols), optional, intent(out):: precsl_out!frozen large scale precipitation - - integer :: i - - real(r8), pointer :: prec_dp(:) !total precipitation from from deep convection - real(r8), pointer :: snow_dp(:) !frozen precipitation from deep convection - real(r8), pointer :: prec_sh(:) !total precipitation from shallow convection - real(r8), pointer :: snow_sh(:) !frozen precipitation from from shallow convection - real(r8), pointer :: prec_sed(:) !total precipitation from cloud sedimentation - real(r8), pointer :: snow_sed(:) !frozen precipitation from sedimentation - real(r8), pointer :: prec_pcw(:) !total precipitation from from microphysics - real(r8), pointer :: snow_pcw(:) !frozen precipitation from from microphysics - - real(r8), dimension(pcols):: precc, precl, precsc, precsl - integer :: prec_dp_idx, snow_dp_idx, prec_sh_idx, snow_sh_idx - integer :: prec_sed_idx,snow_sed_idx,prec_pcw_idx,snow_pcw_idx - ! - ! get fields from pbuf - ! - prec_dp_idx = pbuf_get_index('PREC_DP', errcode=i) - snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=i) - prec_sh_idx = pbuf_get_index('PREC_SH', errcode=i) - snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=i) - prec_sed_idx = pbuf_get_index('PREC_SED', errcode=i) - snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=i) - prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=i) - snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=i) - - if (prec_dp_idx > 0) then - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) - end if - if (snow_dp_idx > 0) then - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) - end if - if (prec_sh_idx > 0) then - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) - end if - if (snow_sh_idx > 0) then - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) - end if - if (prec_sed_idx > 0) then - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) - end if - if (snow_sed_idx > 0) then - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) - end if - if (prec_pcw_idx > 0) then - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) - end if - if (snow_pcw_idx > 0) then - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) - end if - - precc = 0._r8 - precl = 0._r8 - precsc = 0._r8 - precsl = 0._r8 - if (prec_dp_idx > 0) then - precc(:ncol) = precc(:ncol) + prec_dp(:ncol) - end if - if (prec_sh_idx > 0) then - precc(:ncol) = precc(:ncol) + prec_sh(:ncol) - end if - if (prec_sed_idx > 0) then - precl(:ncol) = precl(1:ncol) + prec_sed(:ncol) - end if - if (prec_pcw_idx > 0) then - precl(:ncol) = precl(1:ncol) + prec_pcw(:ncol) - end if - if (snow_dp_idx > 0) then - precsc(:ncol) = precsc(:ncol) + snow_dp(:ncol) - end if - if (snow_sh_idx > 0) then - precsc(:ncol) = precsc(:ncol) + snow_sh(:ncol) - end if - if (snow_sed_idx > 0) then - precsl(:ncol) = precsl(:ncol) + snow_sed(:ncol) - end if - if (snow_pcw_idx > 0) then - precsl(:ncol)= precsl(:ncol) + snow_pcw(:ncol) - end if - - do i=1,ncol - precc(i) = MAX(precc(i), 0.0_r8) - precl(i) = MAX(precl(i), 0.0_r8) - precsc(i) = MAX(precsc(i),0.0_r8) - precsl(i) = MAX(precsl(i),0.0_r8) - if (precsc(i).gt.precc(i)) precsc(i)=precc(i) - if (precsl(i).gt.precl(i)) precsl(i)=precl(i) - end do - if (present(precc_out )) precc_out (:ncol) = precc (:ncol) - if (present(precl_out )) precl_out (:ncol) = precl (:ncol) - if (present(precsc_out)) precsc_out(:ncol) = precsc(:ncol) - if (present(precsl_out)) precsl_out(:ncol) = precsl(:ncol) - - if (present(fice)) fice(:ncol) = 1000.0_r8*(precsc(:ncol)+precsl(:ncol)) !snow flux - if (present(fliq)) fliq(:ncol) = 1000.0_r8*(precc (:ncol)-precsc(:ncol)+precl(:ncol)-precsl(:ncol))!rain flux - end subroutine get_prec_vars - -end module camsrfexch From 603d4f4df7e552a27a90ab5bd305b57f8ad83cc6 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 17 Aug 2025 17:32:46 +0200 Subject: [PATCH 08/78] refactor of qneg_module such that seflx is now an optional argument --- src/chemistry/oslo_aero | 2 +- src/physics/cam/qneg_module.F90 | 19 +- src/physics/camnor_phys/physics/physpkg.F90 | 152 +++--- .../camnor_phys/physics/qneg_module.F90 | 493 ------------------ 4 files changed, 80 insertions(+), 586 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/qneg_module.F90 diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index cba0c7664c..5a030929b0 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit cba0c7664c70ee755e223cf80f5e8f5d9fe8abc9 +Subproject commit 5a030929b0387496e69b8b6e9e0c2a17f36f9bd6 diff --git a/src/physics/cam/qneg_module.F90 b/src/physics/cam/qneg_module.F90 index 773bf220a5..638b3d72c2 100644 --- a/src/physics/cam/qneg_module.F90 +++ b/src/physics/cam/qneg_module.F90 @@ -309,7 +309,7 @@ subroutine qneg3 (subnam, idx, ncol, ncold, lver, lconst_beg, & end subroutine qneg3 subroutine qneg4 (subnam, lchnk, ncol, ztodt, & - qbot, srfrpdel, shflx, lhflx, qflx) + qbot, srfrpdel, shflx, lhflx, qflx, seflx) !----------------------------------------------------------------------- ! ! Purpose: @@ -325,7 +325,7 @@ subroutine qneg4 (subnam, lchnk, ncol, ztodt, & ! Author: J. Olson ! !----------------------------------------------------------------------- - use physconst, only: gravit, latvap + use physconst, only: gravit, latvap, latice !+tht use constituents, only: qmin use cam_history, only: outfld @@ -343,9 +343,10 @@ subroutine qneg4 (subnam, lchnk, ncol, ztodt, & ! ! Input/Output arguments ! - real(r8), intent(inout) :: shflx(ncol) ! Surface sensible heat flux (J/m2/s) - real(r8), intent(inout) :: lhflx(ncol) ! Surface latent heat flux (J/m2/s) - real(r8), intent(inout) :: qflx (ncol,pcnst) ! surface water flux (kg/m^2/s) + real(r8), intent(inout) :: shflx(ncol) ! Surface sensible heat flux (J/m2/s) + real(r8), intent(inout) :: lhflx(ncol) ! Surface latent heat flux (J/m2/s) + real(r8), intent(inout) :: qflx (ncol,pcnst) ! surface water flux (kg/m^2/s) + real(r8), intent(inout), optional :: seflx(ncol) ! heat flux for energy checker (ice ref.state) ! !---------------------------Local workspace----------------------------- ! @@ -395,6 +396,14 @@ subroutine qneg4 (subnam, lchnk, ncol, ztodt, & end if end if end do + if (present(seflx)) then + do i = 1, ncol + if (excess(i) < 0._r8) then + seflx(i) = seflx(i) + excess(i)*(latvap+latice) + end if + end do + end if + ! Maybe output bad values if ((cnst_outfld((2*pcnst)+1)) .and. (worst < worst_reset)) then do i = 1, ncol diff --git a/src/physics/camnor_phys/physics/physpkg.F90 b/src/physics/camnor_phys/physics/physpkg.F90 index 8558c01adf..8471ac9e5e 100644 --- a/src/physics/camnor_phys/physics/physpkg.F90 +++ b/src/physics/camnor_phys/physics/physpkg.F90 @@ -77,17 +77,12 @@ module physpkg integer :: totliqini_idx = 0 integer :: toticeini_idx = 0 -!+pel integer :: enthalpy_prec_bc_idx = 0 integer :: enthalpy_prec_ac_idx = 0 - !integer :: enthalpy_evap_idx = 0 !!tht -!-pel -!+tht integer :: enthalpy_evop_idx = 0 integer :: qcsedten_idx=0, qrsedten_idx=0 integer :: qisedten_idx=0, qssedten_idx=0, qgsedten_idx=0 integer :: qrain_mg_idx=0, qsnow_mg_idx=0 -!-tht integer :: prec_str_idx = 0 integer :: snow_str_idx = 0 @@ -171,7 +166,7 @@ subroutine phys_register use surface_emissions_mod, only: surface_emissions_reg use elevated_emissions_mod, only: elevated_emissions_reg - use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars !+pel + use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars !---------------------------Local variables----------------------------- ! @@ -224,17 +219,13 @@ subroutine phys_register call pbuf_add_field('TOTLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), totliqini_idx) call pbuf_add_field('TOTICEINI', 'physpkg', dtype_r8, (/pcols,pver/), toticeini_idx) -!+pel if (compute_enthalpy_flux) then call pbuf_add_field('ENTHALPY_PREC_BC','physpkg', dtype_r8, (/pcols,num_enthalpy_vars/), enthalpy_prec_bc_idx) call pbuf_add_field('ENTHALPY_PREC_AC','global' , dtype_r8, (/pcols,num_enthalpy_vars/), enthalpy_prec_ac_idx) - !+tht call pbuf_add_field('ENTHALPY_EVOP' ,'global' , dtype_r8, (/pcols/), enthalpy_evop_idx) call pbuf_add_field('qrain_mg' , 'physpkg', dtype_r8, (/pcols,pver/), qrain_mg_idx) call pbuf_add_field('qsnow_mg' , 'physpkg', dtype_r8, (/pcols,pver/), qsnow_mg_idx) - !-tht end if -!-pel ! check energy package call check_energy_register @@ -1408,7 +1399,7 @@ subroutine tphysac (ztodt, cam_in, & use physconst, only: rhoh2o use aero_model, only: aero_model_drydep use check_energy, only: check_energy_timestep_init, check_energy_cam_chng - use check_energy, only: tot_energy_phys, enthalpy_adjustment !+pel/tht + use check_energy, only: tot_energy_phys, enthalpy_adjustment use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng use time_manager, only: get_nstep use cam_abortutils, only: endrun @@ -1459,11 +1450,9 @@ subroutine tphysac (ztodt, cam_in, & use cam_budget, only: thermo_budget_history use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure use air_composition, only: cpairv, cp_or_cv_dycore -!+pel/tht use air_composition, only: compute_enthalpy_flux use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx -!-pel/tht ! ! Arguments ! @@ -1570,14 +1559,13 @@ subroutine tphysac (ztodt, cam_in, & real(r8), pointer, dimension(:,:) :: dvcore real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction -!+tht variables for dme_energy_adjust + ! variables for dme_energy_adjust real(r8), pointer, dimension(:,:) :: qcsedten, qrsedten, qisedten, qssedten, qgsedten real(r8), pointer, dimension(:,:) :: qrain_mg , qsnow_mg real(r8), dimension(pcols,pver) :: qrain_mg_macmic , qsnow_mg_macmic integer :: m_cnst real(r8):: hflx_iref(pcols) character(50) :: physparname !(and a little extra log info) -!-tht !----------------------------------------------------------------------- lchnk = state%lchnk @@ -1688,11 +1676,11 @@ subroutine tphysac (ztodt, cam_in, & ! Check if latent heat flux exceeds the total moisture content of the ! lowest model layer, thereby creating negative moisture. - hflx_iref(:ncol) = cam_in%shf(:ncol) !+tht - call qneg4('TPHYSAC', lchnk, ncol, ztodt , & - state%q(1,pver,1), state%rpdel(1,pver), & - hflx_iref, & !+tht - cam_in%shf, cam_in%lhf, cam_in%cflx) + hflx_iref(:ncol) = cam_in%shf(:ncol) + call qneg4('TPHYSAC', lchnk, ncol, ztodt , & + state%q(1,pver,1), state%rpdel(1,pver), & + cam_in%shf, cam_in%lhf, cam_in%cflx), & + seflx=hflx_iref) call t_stopf('tphysac_init') @@ -1750,12 +1738,12 @@ subroutine tphysac (ztodt, cam_in, & snow_sed_macmic = 0._r8 prec_pcw_macmic = 0._r8 snow_pcw_macmic = 0._r8 -!+tht + if (compute_enthalpy_flux) then - qrain_mg_macmic(:ncol,:) = 0._r8 - qsnow_mg_macmic(:ncol,:) = 0._r8 + qrain_mg_macmic(:ncol,:) = 0._r8 + qsnow_mg_macmic(:ncol,:) = 0._r8 endif -!-tht + ! contrail parameterization ! see Chen et al., 2012: Global contrail coverage simulated ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES @@ -1791,10 +1779,10 @@ subroutine tphysac (ztodt, cam_in, & ! Since we "added" the reserved liquid back in this routine, we need ! to account for it in the energy checker flx_cnd(:ncol) = -1._r8*rliq(:ncol) -!+tht + !flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) - flx_heat(:ncol) = hflx_iref(:ncol) + det_s(:ncol) -!-tht + flx_heat(:ncol) = hflx_iref(:ncol) + det_s(:ncol) + ! Unfortunately, physics_update does not know what time period ! "tend" is supposed to cover, and therefore can't update it ! with substeps correctly. For now, work around this by scaling @@ -1817,12 +1805,11 @@ subroutine tphysac (ztodt, cam_in, & end if ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code -!+tht (a little extra log info) - !call check_energy_cam_chng(state, tend, "clubb_tend", nstep, ztodt, & + ! a little extra log info + !call check_energy_cam_chng(state, tend, "clubb_tend", nstep, ztodt, & write(physparname,"(i3)") macmic_it physparname="clubb_tend "//trim(physparname) call check_energy_cam_chng(state, tend, physparname, nstep, ztodt, & -!-tht cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & flx_cnd(:ncol)/cld_macmic_num_steps, & det_ice(:ncol)/cld_macmic_num_steps, & @@ -1954,12 +1941,11 @@ subroutine tphysac (ztodt, cam_in, & call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if -!+tht (a little extra log info) - !call check_energy_cam_chng(state, tend, "microp_tend", nstep, ztodt, & + ! a little extra log info + !call check_energy_cam_chng(state, tend, "microp_tend", nstep, ztodt, & write(physparname,"(i3)") macmic_it physparname="microp_tend "//trim(physparname) call check_energy_cam_chng(state, tend, physparname, nstep, ztodt, & -!-tht zero, prec_str(:ncol)/cld_macmic_num_steps, & snow_str(:ncol)/cld_macmic_num_steps, zero) @@ -1969,37 +1955,37 @@ subroutine tphysac (ztodt, cam_in, & snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) -!+tht + if (compute_enthalpy_flux) then - if(macmic_it.eq.1) then - qcsedten_idx = pbuf_get_index('QCSEDTEN' , errcode=i) - qrsedten_idx = pbuf_get_index('QRSEDTEN' , errcode=i) - qisedten_idx = pbuf_get_index('QISEDTEN' , errcode=i) - qssedten_idx = pbuf_get_index('QSSEDTEN' , errcode=i) - qgsedten_idx = pbuf_get_index('QGSEDTEN' , errcode=i) - endif - if (qcsedten_idx.gt.0) then - call pbuf_get_field(pbuf, qcsedten_idx, qcsedten) - qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qcsedten(:ncol,:) - endif - if (qrsedten_idx.gt.0) then - call pbuf_get_field(pbuf, qrsedten_idx, qrsedten) - qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qrsedten(:ncol,:) - endif - if (qisedten_idx.gt.0) then - call pbuf_get_field(pbuf, qisedten_idx, qisedten) - qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qisedten(:ncol,:) - endif - if (qssedten_idx.gt.0) then - call pbuf_get_field(pbuf, qssedten_idx, qssedten) - qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qssedten(:ncol,:) - endif - if (qgsedten_idx.gt.0) then - call pbuf_get_field(pbuf, qgsedten_idx, qgsedten) - qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qgsedten(:ncol,:) - endif + if(macmic_it.eq.1) then + qcsedten_idx = pbuf_get_index('QCSEDTEN' , errcode=i) + qrsedten_idx = pbuf_get_index('QRSEDTEN' , errcode=i) + qisedten_idx = pbuf_get_index('QISEDTEN' , errcode=i) + qssedten_idx = pbuf_get_index('QSSEDTEN' , errcode=i) + qgsedten_idx = pbuf_get_index('QGSEDTEN' , errcode=i) + endif + if (qcsedten_idx.gt.0) then + call pbuf_get_field(pbuf, qcsedten_idx, qcsedten) + qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qcsedten(:ncol,:) + endif + if (qrsedten_idx.gt.0) then + call pbuf_get_field(pbuf, qrsedten_idx, qrsedten) + qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qrsedten(:ncol,:) + endif + if (qisedten_idx.gt.0) then + call pbuf_get_field(pbuf, qisedten_idx, qisedten) + qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qisedten(:ncol,:) + endif + if (qssedten_idx.gt.0) then + call pbuf_get_field(pbuf, qssedten_idx, qssedten) + qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qssedten(:ncol,:) + endif + if (qgsedten_idx.gt.0) then + call pbuf_get_field(pbuf, qgsedten_idx, qgsedten) + qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qgsedten(:ncol,:) + endif endif -!-tht + end do ! end substepping over macrophysics/microphysics call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) @@ -2012,16 +1998,15 @@ subroutine tphysac (ztodt, cam_in, & snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) -!+tht + if (compute_enthalpy_flux) then - qrain_mg_idx = pbuf_get_index('qrain_mg' , errcode=i) - qsnow_mg_idx = pbuf_get_index('qsnow_mg' , errcode=i) - call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) - call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) - qrain_mg(:ncol,:) = qrain_mg_macmic(:ncol,:)/cld_macmic_num_steps - qsnow_mg(:ncol,:) = qsnow_mg_macmic(:ncol,:)/cld_macmic_num_steps + qrain_mg_idx = pbuf_get_index('qrain_mg' , errcode=i) + qsnow_mg_idx = pbuf_get_index('qsnow_mg' , errcode=i) + call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) + call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) + qrain_mg(:ncol,:) = qrain_mg_macmic(:ncol,:)/cld_macmic_num_steps + qsnow_mg(:ncol,:) = qsnow_mg_macmic(:ncol,:)/cld_macmic_num_steps endif -!-tht endif ! Add the precipitation from CARMA to the precipitation from stratiform. @@ -2488,16 +2473,16 @@ subroutine tphysac (ztodt, cam_in, & endif if (compute_enthalpy_flux) then -!+tht + ! conserve energy - if (.not.dycore_is('SE')) then + if (.not.dycore_is('SE')) then call endrun("Explicit enthalpy flux functionality only supported for SE dycore") end if call enthalpy_adjustment(ncol,lchnk,state,cam_in,cam_out,pbuf,ztodt,itim_old,& qini(:,:),totliqini(:,:),toticeini(:,:),tend) else - ! standard CAM (violate energy conservation) -!-tht + + ! standard CAM (violate energy conservation) !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! Save total energy for global fixer in next timestep ! @@ -2643,10 +2628,8 @@ subroutine tphysbc (ztodt, state, & use constituents, only: qmin use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx -!+tht use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars, cp_or_cv_dycore use physics_buffer, only: pbuf_set_field -!-tht use convect_deep, only: convect_deep_tend use time_manager, only: is_first_step, get_nstep use convect_diagnostics,only: convect_diagnostics_calc @@ -2666,10 +2649,9 @@ subroutine tphysbc (ztodt, state, & use dyn_tests_utils, only: vc_dycore use surface_emissions_mod,only: surface_emissions_set use elevated_emissions_mod,only: elevated_emissions_set -!+pel - use air_composition, only: te_init,cpairv,compute_enthalpy_flux !xxx - use cam_thermo, only: get_hydrostatic_energy !xxx -!-pel + use air_composition, only: te_init,cpairv,compute_enthalpy_flux !xxx + use cam_thermo, only: get_hydrostatic_energy !xxx + ! Arguments real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) @@ -2845,8 +2827,8 @@ subroutine tphysbc (ztodt, state, & m = thermodynamic_active_species_ice_idx(m_cnst) toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) end do -!+pel - ! compute energy variables for state at the beginning of physics - xxx + + ! compute energy variables for state at the beginning of physics - xxx if (compute_enthalpy_flux) then call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & @@ -2854,9 +2836,8 @@ subroutine tphysbc (ztodt, state, & vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & te = te_init(:ncol,1,lchnk), se=te_init(:ncol,2,lchnk), po=te_init(:ncol,3,lchnk), ke=te_init(:ncol,4,lchnk)) endif -!-pel -!+tht (postponed call to fixer) + ! postponed call to fixer !=================================================== ! Global mean total energy fixer !=================================================== @@ -2877,7 +2858,6 @@ subroutine tphysbc (ztodt, state, & call tot_energy_phys(state, 'dyBP',vc=vc_dycore) ! Save state for convective tendency calculations. call diag_conv_tend_ini(state, pbuf) -!-tht call outfld('TEOUT', teout , pcols, lchnk ) call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) @@ -3027,13 +3007,11 @@ subroutine tphysbc (ztodt, state, & prec_str = 0._r8 snow_str = 0._r8 -!+pel ! In first time-step tphysac variables need to be zero'd out if (compute_enthalpy_flux) then ifld = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) if (ifld>0) call pbuf_set_field(pbuf, ifld, 0._r8) end if -!-pel if (is_subcol_on()) then prec_str_sc = 0._r8 diff --git a/src/physics/camnor_phys/physics/qneg_module.F90 b/src/physics/camnor_phys/physics/qneg_module.F90 deleted file mode 100644 index 98b51e71f6..0000000000 --- a/src/physics/camnor_phys/physics/qneg_module.F90 +++ /dev/null @@ -1,493 +0,0 @@ -module qneg_module - - use shr_kind_mod, only: r8 => shr_kind_r8, CS => SHR_KIND_CS - use perf_mod, only: t_startf, t_stopf - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - use shr_sys_mod, only: shr_sys_flush - use cam_history_support, only: max_fieldname_len - use ppgrid, only: pcols - use constituents, only: pcnst, cnst_name - - implicit none - private - save - - ! Public interface. - - public :: qneg_readnl - public :: qneg_init - public :: qneg3 - public :: qneg4 - public :: qneg_print_summary - - ! Private module variables - character(len=8) :: print_qneg_warn - logical :: log_warnings = .false. - logical :: collect_stats = .false. - logical :: timestep_reset = .false. - - real(r8), parameter :: tol = 1.e-12_r8 - real(r8), parameter :: worst_reset = 1.e35_r8 - - ! Diagnostic field names - integer, parameter :: num_diag_fields = (2 * pcnst) + 1 - character(len=max_fieldname_len) :: diag_names(num_diag_fields) - logical :: cnst_out_calc = .false. - logical :: cnst_outfld(num_diag_fields) = .false. - - ! Summary buffers - integer, parameter :: num3_bins = 24 - integer, parameter :: num4_bins = 4 - character(len=CS) :: qneg3_warn_labels(num3_bins) = '' - character(len=CS) :: qneg4_warn_labels(num4_bins) = '' - integer :: qneg3_warn_num(pcnst, num3_bins) = 0 - integer :: qneg4_warn_num(num4_bins) = 0 - real(r8) :: qneg3_warn_worst(pcnst, num3_bins) = worst_reset - real(r8) :: qneg4_warn_worst(num4_bins) = worst_reset - - private :: calc_cnst_out - private :: find_index3 - private :: find_index4 - interface reset_stats - module procedure reset_stats_scalar - module procedure reset_stats_array - end interface reset_stats - -contains - - subroutine qneg_readnl(nlfile) - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_character, masterproc - ! File containing namelist input. - character(len=*), intent(in) :: nlfile - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: sub = 'qneg_readnl' - - namelist /qneg_nl/ print_qneg_warn - - print_qneg_warn = '' - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'qneg_nl', status=ierr) - if (ierr == 0) then - read(unitn, qneg_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub // ':: ERROR reading namelist qneg_nl') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - call mpi_bcast(print_qneg_warn, len(print_qneg_warn), mpi_character, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: print_qneg_warn") - - select case(trim(print_qneg_warn)) - case('summary') - collect_stats = .true. - timestep_reset = .false. - case('timestep') - collect_stats = .true. - timestep_reset = .true. - case('off') - collect_stats = .false. - timestep_reset = .false. - case default - call endrun(sub//" FATAL: '"//trim(print_qneg_warn)//"' is not a valid value for print_qneg_warn") - end select - - if (masterproc) then - if (collect_stats) then - if (timestep_reset) then - write(iulog, *) sub, ": QNEG statistics will be collected and printed for each timestep" - else - write(iulog, *) sub, ": QNEG statistics will be collected and printed at the end of the run" - end if - else - write(iulog, *) sub, ": QNEG statistics will not be collected" - end if - end if - - end subroutine qneg_readnl - - subroutine qneg_init() - use cam_history, only: addfld, horiz_only - use constituents, only: cnst_longname - - integer :: index - - do index = 1, pcnst - diag_names(index) = trim(cnst_name(index))//'_qneg3' - call addfld(diag_names(index), (/ 'lev' /), 'I', 'kg/kg', & - trim(cnst_longname(index))//' QNEG3 error (cell)') - diag_names(pcnst+index) = trim(cnst_name(index))//'_qneg3_col' - call addfld(diag_names(pcnst+index), horiz_only, 'I', 'kg/kg', & - trim(cnst_longname(index))//' QNEG3 error (column)') - end do - diag_names((2*pcnst) + 1) = 'qflux_exceeded' - call addfld(diag_names((2*pcnst) + 1), horiz_only, 'I', 'kg/m^2/s', & - 'qflux excess (QNEG4)') - - end subroutine qneg_init - - subroutine calc_cnst_out() - use cam_history, only: hist_fld_active, history_initialized - integer :: index - - if (history_initialized()) then - ! to protect against routines that call qneg3 too early - do index = 1, num_diag_fields - cnst_outfld(index) = hist_fld_active(trim(diag_names(index))) - end do - cnst_out_calc = .true. - end if - - end subroutine calc_cnst_out - - integer function find_index3(nam) result(index) - ! Find a valid or new index for 'nam' entries - character(len=*), intent(in) :: nam - - integer :: i - - index = -1 - do i = 1, num3_bins - if (trim(nam) == trim(qneg3_warn_labels(i))) then - ! We found this entry, return its index - index = i - exit - else if (len_trim(qneg3_warn_labels(i)) == 0) then - ! We have run out of known entries, use a new one and reset its stats - qneg3_warn_labels(i) = nam - index = i - call reset_stats(qneg3_warn_num(:, index), qneg3_warn_worst(:,index)) - exit - end if - end do - end function find_index3 - - integer function find_index4(nam) result(index) - ! Find a valid or new index for 'nam' entries - character(len=*), intent(in) :: nam - - integer :: i - - index = -1 - do i = 1, num4_bins - if (trim(nam) == trim(qneg4_warn_labels(i))) then - ! We found this entry, return its index - index = i - exit - else if (len_trim(qneg4_warn_labels(i)) == 0) then - ! We have run out of known entries, use a new one and reset its stats - qneg4_warn_labels(i) = nam - index = i - call reset_stats(qneg4_warn_num(index), qneg4_warn_worst(index)) - exit - end if - end do - end function find_index4 - - subroutine qneg3 (subnam, idx, ncol, ncold, lver, lconst_beg, & - lconst_end, qmin, q) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Check moisture and tracers for minimum value, reset any below - ! minimum value to minimum value and return information to allow - ! warning message to be printed. The global average is NOT preserved. - ! - ! Method: - ! - ! - ! - ! Author: J. Rosinski - ! - !----------------------------------------------------------------------- - use cam_history, only: outfld - - !------------------------------Arguments-------------------------------- - ! - ! Input arguments - ! - character(len=*), intent(in) :: subnam ! name of calling routine - - integer, intent(in) :: idx ! chunk/latitude index - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: ncold ! declared number of atmospheric columns - integer, intent(in) :: lver ! number of vertical levels in column - integer, intent(in) :: lconst_beg ! beginning constituent - integer, intent(in) :: lconst_end ! ending constituent - - real(r8), intent(in) :: qmin(lconst_beg:lconst_end) ! Global minimum constituent concentration - - ! - ! Input/Output arguments - ! - real(r8), intent(inout) :: q(ncold,lver,lconst_beg:lconst_end) ! moisture/tracer field - ! - !---------------------------Local workspace----------------------------- - ! - integer :: nvals ! number of values found < qmin - integer :: i, k ! longitude, level indices - integer :: index ! For storing stats - integer :: m ! constituent index - integer :: iw,kw ! i,k indices of worst violator - - logical :: found ! true => at least 1 minimum violator found - - real(r8) :: badvals(ncold, lver) ! Collector for outfld calls - real(r8) :: badcols(ncold) ! Column sum for outfld - real(r8) :: worst ! biggest violator - ! - !----------------------------------------------------------------------- - ! - - call t_startf ('qneg3') - ! The first time we call this, we need to determine whether to call outfld - if (.not. cnst_out_calc) then - call calc_cnst_out() - end if - - if (collect_stats) then - index = find_index3(trim(subnam)) - else - index = -1 - end if - - do m = lconst_beg, lconst_end - nvals = 0 - found = .false. - worst = worst_reset - badvals(:,:) = 0.0_r8 - iw = -1 - kw = -1 - ! - ! Test all field values for being less than minimum value. Set q = qmin - ! for all such points. Trace offenders and identify worst one. - ! - do k = 1, lver - do i = 1, ncol - if (q(i,k,m) < qmin(m)) then - found = .true. - nvals = nvals + 1 - badvals(i, k) = q(i, k, m) - if (index > 0) then - qneg3_warn_num(m, index) = qneg3_warn_num(m, index) + 1 - end if - if (q(i,k,m) < worst) then - worst = q(i,k,m) - iw = i - kw = k - if (index > 0) then - qneg3_warn_worst(m, index) = worst - end if - end if - q(i,k,m) = qmin(m) - end if - end do - end do - ! Maybe output bad values - if ((cnst_outfld(m)) .and. (worst < worst_reset)) then - call outfld(trim(diag_names(m)), badvals, pcols, idx) - end if - if ((cnst_outfld(pcnst+m)) .and. (worst < worst_reset)) then - do i = 1, pcols - badcols(i) = SUM(badvals(i,:)) - end do - call outfld(trim(diag_names(pcnst+m)), badcols, pcols, idx) - end if - end do - call t_stopf ('qneg3') - - end subroutine qneg3 - - subroutine qneg4 (subnam, lchnk, ncol, ztodt, & - !qbot, srfrpdel, shflx, lhflx, qflx) - qbot, srfrpdel, seflx, shflx, lhflx, qflx)!+tht - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Check if moisture flux into the ground is exceeding the total - ! moisture content of the lowest model layer (creating negative moisture - ! values). If so, then subtract the excess from the moisture and - ! latent heat fluxes and add it to the sensible heat flux. - ! - ! Method: - ! - ! - ! - ! Author: J. Olson - ! - !----------------------------------------------------------------------- - use physconst, only: gravit, latvap, latice !+tht - use constituents, only: qmin - use cam_history, only: outfld - - ! - ! Input arguments - ! - character(len=*), intent(in) :: subnam ! name of calling routine - ! - integer, intent(in) :: lchnk ! chunk index - integer, intent(in) :: ncol ! number of atmospheric columns - ! - real(r8), intent(in) :: ztodt ! two times model timestep (2 delta-t) - real(r8), intent(in) :: qbot(ncol,pcnst) ! moisture at lowest model level - real(r8), intent(in) :: srfrpdel(ncol) ! 1./(pint(K+1)-pint(K)) - ! - ! Input/Output arguments - ! - real(r8), intent(inout) :: seflx(ncol) !+tht: heat flux for energy checker (ice ref.state) - real(r8), intent(inout) :: shflx(ncol) ! Surface sensible heat flux (J/m2/s) - real(r8), intent(inout) :: lhflx(ncol) ! Surface latent heat flux (J/m2/s) - real(r8), intent(inout) :: qflx (ncol,pcnst) ! surface water flux (kg/m^2/s) - ! - !---------------------------Local workspace----------------------------- - ! - integer :: i ! column index - integer :: iw ! i index of worst violator - integer :: index ! caller bin index - ! - real(r8):: worst ! biggest violator - real(r8):: excess(ncol) ! Excess downward sfc latent heat flux - ! - !----------------------------------------------------------------------- - - call t_startf ('qneg4') - ! The first time we call this, we need to determine whether to call outfld - if (.not. cnst_out_calc) then - call calc_cnst_out() - end if - - if (collect_stats) then - index = find_index4(trim(subnam)) - else - index = -1 - end if - - ! - ! Compute excess downward (negative) q flux compared to a theoretical - ! maximum downward q flux. The theoretical max is based upon the - ! given moisture content of lowest level of the model atmosphere. - ! - worst = worst_reset - do i = 1, ncol - excess(i) = qflx(i,1) - (qmin(1) - qbot(i,1))/(ztodt*gravit*srfrpdel(i)) - ! - ! If there is an excess downward (negative) q flux, then subtract - ! excess from "qflx" and "lhflx" and add to "shflx". - ! - if (excess(i) < 0._r8) then - if (excess(i) < worst) then - iw = i - worst = excess(i) - end if - qflx (i,1) = qflx (i,1) - excess(i) - lhflx(i) = lhflx(i) - excess(i)*latvap - shflx(i) = shflx(i) + excess(i)*latvap - seflx(i) = seflx(i) + excess(i)*(latvap+latice) !+tht - if (index > 0) then - qneg4_warn_num(index) = qneg4_warn_num(index) + 1 - end if - end if - end do - ! Maybe output bad values - if ((cnst_outfld((2*pcnst)+1)) .and. (worst < worst_reset)) then - do i = 1, ncol - if (excess(i) > 0.0_r8) then - excess(i) = 0.0_r8 - end if - end do - call outfld(trim(diag_names((2*pcnst)+1)), excess(1:ncol), ncol, lchnk) - end if - call t_stopf ('qneg4') - - end subroutine qneg4 - - subroutine qneg_print_summary(end_of_run) - use spmd_utils, only: mpicom, masterprocid, masterproc - use spmd_utils, only: MPI_MIN, MPI_SUM, MPI_INTEGER, MPI_REAL8 - - logical, intent(in) :: end_of_run - - integer :: global_warn_num(pcnst) - real(r8) :: global_warn_worst(pcnst) - integer :: index, m - integer :: ierr - - if (collect_stats) then - if (timestep_reset .or. end_of_run) then - do index = 1, num3_bins - ! QNEG3 - call reset_stats(global_warn_num(:), global_warn_worst(:)) - call MPI_REDUCE(qneg3_warn_num(:, index), global_warn_num(:), & - pcnst, MPI_INTEGER, MPI_SUM, masterprocid, mpicom, ierr) - call MPI_REDUCE(qneg3_warn_worst(:, index), global_warn_worst(:),& - pcnst, MPI_REAL8, MPI_MIN, masterprocid, mpicom, ierr) - if (masterproc) then - do m = 1, pcnst - if ( (global_warn_num(m) > 0) .and. & - (abs(global_warn_worst(m)) > tol)) then - write(iulog, 9100) trim(qneg3_warn_labels(index)), & - trim(cnst_name(m)), global_warn_num(m), & - global_warn_worst(m) - end if - call shr_sys_flush(iulog) - end do - end if - call reset_stats(qneg3_warn_num(:,index), qneg3_warn_worst(:,index)) - end do - do index = 1, num4_bins - ! QNEG4 - call reset_stats(qneg4_warn_num(index), qneg4_warn_worst(index)) - call reset_stats(global_warn_num(1), global_warn_worst(1)) - call MPI_REDUCE(qneg4_warn_num(index), global_warn_num(1), & - 1, MPI_INTEGER, MPI_SUM, masterprocid, mpicom, ierr) - call MPI_REDUCE(qneg4_warn_worst(index), global_warn_worst(1), & - 1, MPI_REAL8, MPI_MIN, masterprocid, mpicom, ierr) - if (masterproc) then - if ( (global_warn_num(1) > 0) .and. & - (abs(global_warn_worst(1)) > tol)) then - write(iulog, 9101) trim(qneg4_warn_labels(index)), & - global_warn_num(1), global_warn_worst(1) - end if - call shr_sys_flush(iulog) - end if - call reset_stats(qneg4_warn_num(index), qneg4_warn_worst(index)) - end do - end if - end if - - return -9100 format(' QNEG3 from ', a, ':', a, & - ' Min. mixing ratio violated at ', i9, ' points. Worst = ', e10.1) -9101 format(' QNEG4 from ',a,': moisture flux exceeded at', & - i9, ' points. Worst = ', e10.1) - end subroutine qneg_print_summary - - subroutine reset_stats_array(num_array, worst_array) - ! Private routine to reset statistics - integer, intent(inout) :: num_array(:) - real(r8), intent(inout) :: worst_array(:) - - num_array(:) = 0 - worst_array(:) = worst_reset - end subroutine reset_stats_array - - subroutine reset_stats_scalar(num, worst) - ! Private routine to reset statistics - integer, intent(inout) :: num - real(r8), intent(inout) :: worst - - num = 0 - worst = worst_reset - end subroutine reset_stats_scalar - -end module qneg_module From d4d5533e65111bebf3b873dde9241f74085ede1f Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 21 Aug 2025 20:12:09 +0200 Subject: [PATCH 09/78] cleanup of comments and indentation --- .../camnor_phys/physics/cam_diagnostics.F90 | 112 ++++++++---------- .../camnor_phys/physics/check_energy.F90 | 24 ++-- 2 files changed, 64 insertions(+), 72 deletions(-) diff --git a/src/physics/camnor_phys/physics/cam_diagnostics.F90 b/src/physics/camnor_phys/physics/cam_diagnostics.F90 index dade72ed95..e2e537a106 100644 --- a/src/physics/camnor_phys/physics/cam_diagnostics.F90 +++ b/src/physics/camnor_phys/physics/cam_diagnostics.F90 @@ -191,12 +191,13 @@ subroutine diag_init_dry(pbuf2d) use cam_history, only: register_vector_field use tidal_diag, only: tidal_diag_init use cam_budget, only: cam_budget_em_snapshot, cam_budget_em_register, thermo_budget_history - use air_composition, only: compute_enthalpy_flux !+tht + use air_composition, only: compute_enthalpy_flux type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) - logical :: debug_enthalpy_flux=.true. !+tht + logical :: debug_enthalpy_flux=.false. integer :: istage + ! outfld calls in diag_phys_writeout call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) call addfld ('NSTEP', horiz_only, 'A', 'timestep', 'Model timestep') @@ -225,20 +226,19 @@ subroutine diag_init_dry(pbuf2d) call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') -!+tht + call addfld('EBREAK' , horiz_only, 'A','W/m2', & 'Global-mean energy-nonconservation (W/m2)' ) - !if (compute_enthalpy_flux) then - call addfld('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & - 'T-tendency due to water fluxes (end of tphysac)' ) - call addfld('IETEND_DME', horiz_only, 'A','W/m2 ', & - 'Column enthalpy tendency due to water fluxes (end of tphysac)' ) - call addfld('EFLX ' , horiz_only, 'A','W/m2 ', & - 'Surface water material enthalpy flux (end of tphysac)' ) - call addfld('MFLX ' , horiz_only, 'A','W/m2 ', & - 'Mass flux due to dry mass adjustment / water changes (end of tphysac)') - !endif -!-tht + !if (compute_enthalpy_flux) then + call addfld('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & + 'T-tendency due to water fluxes (end of tphysac)' ) + call addfld('IETEND_DME', horiz_only, 'A','W/m2 ', & + 'Column enthalpy tendency due to water fluxes (end of tphysac)' ) + call addfld('EFLX ' , horiz_only, 'A','W/m2 ', & + 'Surface water material enthalpy flux (end of tphysac)' ) + call addfld('MFLX ' , horiz_only, 'A','W/m2 ', & + 'Mass flux due to dry mass adjustment / water changes (end of tphysac)') + !end if ! outfld calls in diag_phys_tend_writeout call addfld ('UTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total zonal wind tendency') @@ -408,49 +408,43 @@ subroutine diag_init_dry(pbuf2d) call addfld( 'CPAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable specific heat cap air' ) call addfld( 'RAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable dry air gas constant' ) -!+tht temp diag for material enthalpy fluxes (debug) - !if (compute_enthalpy_flux) then - if(debug_enthalpy_flux) then - !+pel - call addfld('enth_prec_ac_hice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_ac_hliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_hice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_hliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_ac_fice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_ac_fliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_fice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_fliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fevap' ,horiz_only, 'A', 'W/m2', '' ) - !-pel - call addfld('enth_frain_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_frain_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_frain_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hevap_atm' ,horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hevap_ocn' ,horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hrain_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hrain_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hrain_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) - endif - !+pel - call addfld('te_tnd' , horiz_only, 'A', 'W/m2', 'Total column integrated energy tendency from CAM physics' ) - call addfld('dEdt_dme' , horiz_only, 'A', 'W/m2', 'Column integrated dEdt from water update') - call addfld('dEdt_physics' , horiz_only, 'A', 'W/m2', '' )!xxx diags will remove - call addfld('dEdt_efix_physics', horiz_only, 'A', 'W/m2', 'Column integrated physics energy fixer dEdt from enthalpy fixer' ) - !-pel - !endif -!-tht + if (compute_enthalpy_flux) then + if(debug_enthalpy_flux) then + call addfld('enth_prec_ac_hice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_hliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_hice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_hliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_fice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_fliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_fice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_fliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fevap' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hevap_atm' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hevap_ocn' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) + endif + call addfld('te_tnd' , horiz_only, 'A', 'W/m2', 'Total column integrated energy tendency from CAM physics' ) + call addfld('dEdt_dme' , horiz_only, 'A', 'W/m2', 'Column integrated dEdt from water update') + call addfld('dEdt_physics' , horiz_only, 'A', 'W/m2', '' )!xxx diags will remove + call addfld('dEdt_efix_physics', horiz_only, 'A', 'W/m2', 'Column integrated physics energy fixer dEdt from enthalpy fixer' ) + endif if (thermo_budget_history) then ! @@ -2104,7 +2098,7 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) real(r8) :: ftem2(pcols) ! Temporary workspace for outfld variables real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables real(r8) :: heat_glob ! global energy integral (FV only) - real(r8) :: tedif_glob ! tht energy flux from fixer + real(r8) :: tedif_glob ! energy flux from fixer ! CAM pointers to get variables from the physics buffer real(r8), pointer, dimension(:,:) :: t_ttend real(r8), pointer, dimension(:,:) :: t_utend @@ -2125,11 +2119,9 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) ! Total physics tendency for Temperature ! (remove global fixer tendency from total for FV and SE dycores) -!+tht call check_energy_get_integrals(heat_glob_out=heat_glob,tedif_glob_out=tedif_glob) !+tedif ftem2(:ncol) = tedif_glob/ztodt call outfld('EBREAK', ftem2, pcols, lchnk) -!-tht ftem2(:ncol) = heat_glob/cpair call outfld('TFIX', ftem2, pcols, lchnk) diff --git a/src/physics/camnor_phys/physics/check_energy.F90 b/src/physics/camnor_phys/physics/check_energy.F90 index 12e0ac3c99..e25e54b00b 100644 --- a/src/physics/camnor_phys/physics/check_energy.F90 +++ b/src/physics/camnor_phys/physics/check_energy.F90 @@ -957,8 +957,8 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, real(r8), dimension(pcols) :: variable_latent_heat_surface_ls_term !xxx diagnostics real(r8), dimension(pcols) :: variable_latent_heat_surface_lf_term !xxx diagnostics real(r8), dimension(pcols) :: enthalpy_flux_atm, enthalpy_flux_ocn !tht - real(r8), dimension(pcols,pver) :: tmp_t, pdel_rf, qinp, totliqinp, toticeinp - real(r8), dimension(pcols) :: zero, dsema, dcp_heat, iedme + real(r8), dimension(pcols,pver) :: tmp_t, pdel_rf, qinp, totliqinp, toticeinp + real(r8), dimension(pcols) :: zero, dsema, dcp_heat, iedme real(r8), dimension(pcols) :: water_flux_bc, water_flux_ac, enthalpy_flux_bc, enthalpy_flux_ac real(r8), dimension(pcols) :: eflx_out real(r8), dimension(pcols) :: mflx_out @@ -976,7 +976,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, real(r8), parameter :: eps=1.E-10_r8 - logical, parameter :: debug=.true. + logical, parameter :: debug_enthalpy=.false. logical, parameter :: use_nonlinear_evap_fraction=.false. integer :: i, k @@ -1001,7 +1001,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, !------------------------------------------------------------------------------------------- !=== start computation of material enthalpy fluxes === - ! evaporation enthalpy flux + ! evaporation enthalpy flux enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP' , errcode=i) if (enthalpy_evop_idx==0) then call endrun("pbufs for enthalpy evap flux not allocated") @@ -1029,11 +1029,11 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, tevp (:ncol)= cam_in%ts(:ncol) endif !tht: for ocean-only mat.enthalpy flux (passed to ocean) - hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) + hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) else ! not great but better than zeros hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm tevp (:ncol)= state%t(:ncol,pver) - hevap_ocn (:ncol)= hevap_atm(:ncol) ! out of ocn + hevap_ocn (:ncol)= hevap_atm(:ncol) ! out of ocn endif call pbuf_set_field(pbuf, enthalpy_evop_idx, hevap_ocn) @@ -1082,7 +1082,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, +hevap_atm (:ncol) water_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,fliq_idx)+enthalpy_prec_bc(:ncol,fice_idx) water_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,fliq_idx)+enthalpy_prec_ac(:ncol,fice_idx) & - -cam_in%cflx(:ncol,1) + -cam_in%cflx(:ncol,1) enthalpy_flux_atm(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & +hevap_atm (:ncol) @@ -1091,7 +1091,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, +hevap_ocn (:ncol) enthalpy_flux_ocn(:ncol) = cam_in%ocnfrac(:ncol)*enthalpy_flux_ocn(:ncol) - if (debug) then + if (debug_enthalpy) then call outfld("enth_prec_ac_hice" , enthalpy_prec_ac(:,hice_idx) , pcols ,lchnk ) call outfld("enth_prec_ac_hliq" , enthalpy_prec_ac(:,hliq_idx) , pcols ,lchnk ) call outfld("enth_prec_bc_hice" , enthalpy_prec_bc(:,hice_idx) , pcols ,lchnk ) @@ -1103,9 +1103,9 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, call outfld("enth_hevap_atm" , hevap_atm (:) , pcols ,lchnk ) call outfld("enth_hevap_ocn" , hevap_ocn (:) , pcols ,lchnk ) endif - !=== end computation of material enthalpy fluxes === + !=== end computation of material enthalpy fluxes === - !+++ diags + !+++ diags ! compute total energy after physics using equation 78 call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & @@ -1157,7 +1157,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & - te = te(:ncol), se=se(:ncol), po=po(:ncol), ke=ke(:ncol)) + te = te(:ncol), se=se(:ncol), po=po(:ncol), ke=ke(:ncol)) ! Save final energy for use with global fixer in next timestep -- note sign conventions, and coupling-dependent options state%te_cur(:ncol,dyn_te_idx) = te(:ncol) & ! *subtract* from this the h flux (sign: into atm) that is *not* passed to surface components -ztodt*(enthalpy_flux_atm(:ncol)-enthalpy_flux_ocn(:ncol)-cam_in%hrof(:ncol)) ! also remove enthalpy of run-off (if added to BLOM) @@ -1174,5 +1174,5 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, call outfld("dEdt_efix_physics" , dEdt_efix , pcols ,lchnk ) end subroutine enthalpy_adjustment - + end module check_energy From dede6adaabdce07c28293716767dfb1288500076 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 21 Aug 2025 20:15:25 +0200 Subject: [PATCH 10/78] updated oslo_aero in .gitmodules to point to mvertens fork --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index bc0c715f4a..fd06ee2877 100644 --- a/.gitmodules +++ b/.gitmodules @@ -76,8 +76,8 @@ [submodule "oslo_aero"] path = src/chemistry/oslo_aero - url = https://github.com/NorESMhub/OSLO_AERO - fxtag = oslo_aero_3_0a005 + url = https://github.com/mvertens/OSLO_AERO + fxtag = feature/cam_computes_enthalpy fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/OSLO_AERO.git From 9147bed988cfc937c3b505bce9d599ef1412ed27 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 21 Aug 2025 20:16:55 +0200 Subject: [PATCH 11/78] removed zm_conf*.F90 files --- .../camnor_phys/physics/zm_conv_evap.F90 | 262 -- .../camnor_phys/physics/zm_conv_intr.F90 | 969 ----- .../physics/zm_conv_intr.F90.enthalpy-only | 928 ----- src/physics/camnor_phys/physics/zm_convr.F90 | 3138 ----------------- 4 files changed, 5297 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/zm_conv_evap.F90 delete mode 100644 src/physics/camnor_phys/physics/zm_conv_intr.F90 delete mode 100644 src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only delete mode 100644 src/physics/camnor_phys/physics/zm_convr.F90 diff --git a/src/physics/camnor_phys/physics/zm_conv_evap.F90 b/src/physics/camnor_phys/physics/zm_conv_evap.F90 deleted file mode 100644 index 5e26d80e06..0000000000 --- a/src/physics/camnor_phys/physics/zm_conv_evap.F90 +++ /dev/null @@ -1,262 +0,0 @@ -module zm_conv_evap - - use ccpp_kinds, only: kind_phys - - implicit none - - save - private ! Make default type private to the module -! -! PUBLIC: interfaces -! - public zm_conv_evap_run ! evaporation of precip from ZM schemea - -contains - - -!=============================================================================== -!> \section arg_table_zm_conv_evap_run Argument Table -!! \htmlinclude zm_conv_evap_run.html -!! -subroutine zm_conv_evap_run(ncol, pver, pverp, & - gravit, latice, latvap, tmelt, & - cpres, ke, ke_lnd, & - t,pmid,pdel,q, & - landfrac, & - tend_s, tend_s_snwprd, tend_s_snwevmlt, tend_q, & - prdprec_gen, cldfrc, deltat, & - prec_gen, snow, ntprprd, ntsnprd, fsnow_conv, flxprec, flxsnow, scheme_name, errmsg, errflg) - -!----------------------------------------------------------------------- -! Compute tendencies due to evaporation of rain from ZM scheme -!-- -! Compute the total precipitation and snow fluxes at the surface. -! Add in the latent heat of fusion for snow formation and melt, since it not dealt with -! in the Zhang-MacFarlane parameterization. -! Evaporate some of the precip directly into the environment using a Sundqvist type algorithm -!----------------------------------------------------------------------- - - use wv_saturation, only: qsat - -!------------------------------Arguments-------------------------------- - integer,intent(in) :: ncol ! number of columns - integer,intent(in) :: pver, pverp - real(kind_phys),intent(in) :: gravit ! gravitational acceleration (m s-2) - real(kind_phys),intent(in) :: latice ! Latent heat of fusion (J kg-1) - real(kind_phys),intent(in) :: latvap ! Latent heat of vaporization (J kg-1) - real(kind_phys),intent(in) :: tmelt ! Freezing point of water (K) - real(kind_phys), intent(in) :: cpres ! specific heat at constant pressure in j/kg-degk. - real(kind_phys), intent(in) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke - real(kind_phys), intent(in) :: ke_lnd - real(kind_phys),intent(in), dimension(:,:) :: t ! temperature (K) (ncol,pver) - real(kind_phys),intent(in), dimension(:,:) :: pmid ! midpoint pressure (Pa) (ncol,pver) - real(kind_phys),intent(in), dimension(:,:) :: pdel ! layer thickness (Pa) (ncol,pver) - real(kind_phys),intent(in), dimension(:,:) :: q ! water vapor (kg/kg) (ncol,pver) - real(kind_phys),intent(in), dimension(:) :: landfrac ! land fraction (ncol) - - real(kind_phys),intent(out), dimension(:,:) :: tend_s ! heating rate (J/kg/s) (ncol,pver) - real(kind_phys),intent(out), dimension(:,:) :: tend_q ! water vapor tendency (kg/kg/s) (ncol,pver) - real(kind_phys),intent(out), dimension(:,:) :: tend_s_snwprd ! Heating rate of snow production (ncol,pver) - real(kind_phys),intent(out), dimension(:,:) :: tend_s_snwevmlt ! Heating rate of evap/melting of snow (ncol,pver) - - real(kind_phys), intent(in ) :: prdprec_gen(:,:)! precipitation production (kg/ks/s) (ncol,pver) - real(kind_phys), intent(in ) :: cldfrc(:,:) ! cloud fraction (ncol,pver) - real(kind_phys), intent(in ) :: deltat ! time step - real(kind_phys), intent(in ) :: fsnow_conv(:,:) ! snow fraction in precip production - - real(kind_phys), intent(inout) :: prec_gen(:) ! Convective-scale preciptn rate (ncol) - real(kind_phys), intent(out) :: snow(:) ! Convective-scale snowfall rate (ncol) - -! -!---------------------------Local storage------------------------------- - real(kind_phys), parameter :: density_fresh_water=1000._kind_phys - - real(kind_phys) :: es (ncol,pver) ! Saturation vapor pressure - real(kind_phys) :: qs (ncol,pver) ! saturation specific humidity - real(kind_phys),intent(out) :: flxprec(:,:) ! Convective-scale flux of precip at interfaces (kg/m2/s) ! (ncol,pverp) - real(kind_phys),intent(out) :: flxsnow(:,:) ! Convective-scale flux of snow at interfaces (kg/m2/s) ! (ncol,pverp) - real(kind_phys),intent(out) :: ntprprd(:,:) ! net precip production in layer ! (ncol,pver) - real(kind_phys),intent(out) :: ntsnprd(:,:) ! net snow production in layer ! (ncol,pver) - - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - character(len=40), intent(out) :: scheme_name - - real(kind_phys) :: work1 ! temp variable (pjr) - real(kind_phys) :: work2 ! temp variable (pjr) - - real(kind_phys) :: evpvint(ncol) ! vertical integral of evaporation - real(kind_phys) :: evpprec(ncol) ! evaporation of precipitation (kg/kg/s) - real(kind_phys) :: evpsnow(ncol) ! evaporation of snowfall (kg/kg/s) - real(kind_phys) :: snowmlt(ncol) ! snow melt tendency in layer - real(kind_phys) :: flxsntm(ncol) ! flux of snow into layer, after melting - - real(kind_phys) :: kemask - real(kind_phys) :: evplimit ! temp variable for evaporation limits - real(kind_phys) :: rlat(ncol) - real(kind_phys) :: dum - real(kind_phys) :: omsm - - integer :: i,k ! longitude,level indices - logical :: old_snow - -logical, parameter:: tht_tweaks=.false. - -!----------------------------------------------------------------------- - scheme_name = "zm_conv_evap_run" - errmsg = '' - errflg = 0 - - old_snow=.true. - -! convert input precip to kg/m2/s - prec_gen(:ncol) = prec_gen(:ncol)* density_fresh_water - -! determine saturation vapor pressure - do k = 1,pver - call qsat(t(1:ncol,k), pmid(1:ncol,k), es(1:ncol,k), qs(1:ncol,k), ncol) - end do - -! zero the flux integrals on the top boundary - flxprec(:ncol,1) = 0._kind_phys - flxsnow(:ncol,1) = 0._kind_phys - evpvint(:ncol) = 0._kind_phys - omsm=0.9999_kind_phys - - do k = 1, pver - do i = 1, ncol - -! Melt snow falling into layer, if necessary. - if( old_snow ) then - if (t(i,k) > tmelt) then - flxsntm(i) = 0._kind_phys - snowmlt(i) = flxsnow(i,k) * gravit/ pdel(i,k) - else - flxsntm(i) = flxsnow(i,k) - snowmlt(i) = 0._kind_phys - end if - else - ! make sure melting snow doesn't reduce temperature below threshold - if (t(i,k) > tmelt) then - dum = -latice/cpres*flxsnow(i,k)*gravit/pdel(i,k)*deltat - if (t(i,k) + dum .le. tmelt) then - dum = (t(i,k)-tmelt)*cpres/latice/deltat - dum = dum/(flxsnow(i,k)*gravit/pdel(i,k)) - dum = max(0._kind_phys,dum) - dum = min(1._kind_phys,dum) - else - dum = 1._kind_phys - end if - dum = dum*omsm - flxsntm(i) = flxsnow(i,k)*(1.0_kind_phys-dum) - snowmlt(i) = dum*flxsnow(i,k)*gravit/ pdel(i,k) - else - flxsntm(i) = flxsnow(i,k) - snowmlt(i) = 0._kind_phys - end if - end if - -! relative humidity depression must be > 0 for evaporation - if (tht_tweaks) then - !tht Q is a mixing ratio, QS a specific humidity: correcting - evplimit = max(1._kind_phys - q(i,k)/(1._kind_phys+q(i,k))/qs(i,k), 0._kind_phys) !+tht - else - evplimit = max(1._kind_phys - q(i,k)/qs(i,k), 0._kind_phys) - endif - if (tht_tweaks) then - !tht: default is inconsistent with use of separate KE and KE_LND parameters - kemask = ke * (1._kind_phys - landfrac(i)) + ke_lnd * landfrac(i) - else - kemask = ke - endif -!-tht - -! total evaporation depends on flux in the top of the layer -! flux prec is the net production above layer minus evaporation into environmet - evpprec(i) = kemask * (1._kind_phys - cldfrc(i,k)) * evplimit * sqrt(flxprec(i,k)) - -! Don't let evaporation supersaturate layer (approx). Layer may already be saturated. -! Currently does not include heating/cooling change to qs - if (tht_tweaks) then - evplimit = max(0._kind_phys, (qs(i,k)-q(i,k)/(1._kind_phys+q(i,k))) / deltat) !+tht - else - evplimit = max(0._kind_phys, (qs(i,k)-q(i,k)) / deltat) - endif - -! Don't evaporate more than is falling into the layer - do not evaporate rain formed -! in this layer but if precip production is negative, remove from the available precip -! Negative precip production occurs because of evaporation in downdrafts. - evplimit = min(evplimit, flxprec(i,k) * gravit / pdel(i,k)) - -! Total evaporation cannot exceed input precipitation - evplimit = min(evplimit, (prec_gen(i) - evpvint(i)) * gravit / pdel(i,k)) - - evpprec(i) = min(evplimit, evpprec(i)) - if( .not.old_snow ) then - evpprec(i) = max(0._kind_phys, evpprec(i)) - evpprec(i) = evpprec(i)*omsm - end if - - -! evaporation of snow depends on snow fraction of total precipitation in the top after melting - if (flxprec(i,k) > 0._kind_phys) then -! prevent roundoff problems - work1 = min(max(0._kind_phys,flxsntm(i)/flxprec(i,k)),1._kind_phys) - evpsnow(i) = evpprec(i) * work1 - else - evpsnow(i) = 0._kind_phys - end if - -! vertically integrated evaporation - evpvint(i) = evpvint(i) + evpprec(i) * pdel(i,k)/gravit - -! net precip production is production - evaporation - ntprprd(i,k) = prdprec_gen(i,k) - evpprec(i) -! net snow production is precip production * ice fraction - evaporation - melting -! the small amount added to flxprec in the work1 expression has been increased from -! 1e-36 to 8.64e-11 (1e-5 mm/day). This causes the temperature based partitioning -! scheme to be used for small flxprec amounts. This is to address error growth problems. - - if( old_snow ) then - if (flxprec(i,k).gt.0._kind_phys) then - work1 = min(max(0._kind_phys,flxsnow(i,k)/flxprec(i,k)),1._kind_phys) - else - work1 = 0._kind_phys - endif - - work2 = max(fsnow_conv(i,k), work1) - if (snowmlt(i).gt.0._kind_phys) work2 = 0._kind_phys - ntsnprd(i,k) = prdprec_gen(i,k)*work2 - evpsnow(i) - snowmlt(i) - tend_s_snwprd (i,k) = prdprec_gen(i,k)*work2*latice - tend_s_snwevmlt(i,k) = - ( evpsnow(i) + snowmlt(i) )*latice - end if - -! precipitation fluxes - flxprec(i,k+1) = flxprec(i,k) + ntprprd(i,k) * pdel(i,k)/gravit - flxsnow(i,k+1) = flxsnow(i,k) + ntsnprd(i,k) * pdel(i,k)/gravit - -! protect against rounding error - flxprec(i,k+1) = max(flxprec(i,k+1), 0._kind_phys) - flxsnow(i,k+1) = max(flxsnow(i,k+1), 0._kind_phys) - -! heating (cooling) and moistening due to evaporation -! - latent heat of vaporization for precip production has already been accounted for -! - snow is contained in prec - if( old_snow ) then - tend_s(i,k) =-evpprec(i)*latvap + ntsnprd(i,k)*latice - else - tend_s(i,k) =-evpprec(i)*latvap + tend_s_snwevmlt(i,k) - end if - tend_q(i,k) = evpprec(i) - end do - end do - -! set output precipitation rates (m/s) -! convert from 'kg m-2 s-1' to 'm s-1' - prec_gen(:ncol) = flxprec(:ncol,pverp) / density_fresh_water - snow(:ncol) = flxsnow(:ncol,pverp) / density_fresh_water - - end subroutine zm_conv_evap_run - - -end module zm_conv_evap diff --git a/src/physics/camnor_phys/physics/zm_conv_intr.F90 b/src/physics/camnor_phys/physics/zm_conv_intr.F90 deleted file mode 100644 index 984e2e348e..0000000000 --- a/src/physics/camnor_phys/physics/zm_conv_intr.F90 +++ /dev/null @@ -1,969 +0,0 @@ -module zm_conv_intr -!--------------------------------------------------------------------------------- -! Purpose: -! -! CAM interface to the Zhang-McFarlane deep convection scheme -! -! Author: D.B. Coleman -! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer -!--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8=>shr_kind_r8 - use physconst, only: cpair, cpliq, cpwv, epsilo, gravit, latvap, tmelt, rair - use ppgrid, only: pver, pcols, pverp, begchunk, endchunk - use zm_conv_evap, only: zm_conv_evap_run - use zm_convr, only: zm_convr_init, zm_convr_run - use zm_conv_convtran, only: zm_conv_convtran_run - use zm_conv_momtran, only: zm_conv_momtran_run - use cloud_fraction_fice, only: cloud_fraction_fice_run - - use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & - rad_cnst_get_aer_props, rad_cnst_get_mode_props !, & - use cam_abortutils, only: endrun - use physconst, only: pi - use spmd_utils, only: masterproc - use perf_mod - use cam_logfile, only: iulog - use constituents, only: cnst_add - use ref_pres, only: trop_cloud_top_lev - use phys_control, only: phys_getopts - - implicit none - private - save - - ! Public methods - - public ::& - zm_conv_register, &! register fields in physics buffer - zm_conv_readnl, &! read namelist - zm_conv_init, &! initialize donner_deep module - zm_conv_tend, &! return tendencies - zm_conv_tend_2 ! return tendencies - - public zmconv_ke, zmconv_ke_lnd ! needed by convect_shallow - - integer ::& ! indices for fields in the physics buffer - zm_mu_idx, & - zm_eu_idx, & - zm_du_idx, & - zm_md_idx, & - zm_ed_idx, & - zm_dp_idx, & - zm_dsubcld_idx, & - zm_jt_idx, & - zm_maxg_idx, & - zm_ideep_idx, & - dp_flxprc_idx, & - dp_flxsnw_idx, & - dp_cldliq_idx, & - dp_cldice_idx, & - dlfzm_idx, & ! detrained convective cloud water mixing ratio. - prec_dp_idx, & - snow_dp_idx, & - mconzm_idx ! convective mass flux -!+tht - integer :: dp_ntprp_idx = 0 - integer :: dp_ntsnp_idx = 0 -!-tht - - real(r8), parameter :: unset_r8 = huge(1.0_r8) - real(r8) :: zmconv_c0_lnd = unset_r8 - real(r8) :: zmconv_c0_ocn = unset_r8 - real(r8) :: zmconv_ke = unset_r8 - real(r8) :: zmconv_ke_lnd = unset_r8 - real(r8) :: zmconv_momcu = unset_r8 - real(r8) :: zmconv_momcd = unset_r8 - integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed - ! before the convection top and CAPE calculations are completed. - real(r8) :: zmconv_dmpdz = unset_r8 ! Parcel fractional mass entrainment rate - real(r8) :: zmconv_tiedke_add = unset_r8 ! Convective parcel temperature perturbation - real(r8) :: zmconv_capelmt = unset_r8 ! Triggering thereshold for ZM convection - logical :: zmconv_parcel_pbl = .false. ! switch for parcel pbl calculation - real(r8) :: zmconv_parcel_hscale = unset_r8! Fraction of PBL depth over which to mix initial parcel - real(r8) :: zmconv_tau = unset_r8 ! Timescale for convection -!+tht - real(r8) :: zmconv_tiedke_lnd = unset_r8 - real(r8) :: zmconv_entrmn = 2e-4_r8 - real(r8) :: zmconv_alfadet = 1e-1_r8 - real(r8) :: zmconv_plclmin = 6.e2_r8 - logical :: zmconv_tht_thermo = .false. - logical :: zmconv_retrigger = .false. -!-tht - -! indices for fields in the physics buffer - integer :: cld_idx = 0 - integer :: icwmrdp_idx = 0 - integer :: rprddp_idx = 0 - integer :: fracis_idx = 0 - integer :: nevapr_dpcu_idx = 0 - integer :: dgnum_idx = 0 - - integer :: nmodes - integer :: nbulk - -!========================================================================================= -contains -!========================================================================================= - -subroutine zm_conv_register - -!---------------------------------------- -! Purpose: register fields with the physics buffer -!---------------------------------------- - - use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 - - implicit none - - integer idx - - call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) - call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) - call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) - call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) - call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) - - ! wg layer thickness in mbs (between upper/lower interface). - call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) - - ! wg layer thickness in mbs between lcl and maxi. - call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) - - ! wg top level index of deep cumulus convection. - call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) - - ! wg gathered values of maxi. - call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) - - ! map gathered points to chunk index - call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) - -! Flux of precipitation from deep convection (kg/m2/s) - call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) -!+tht - call pbuf_add_field('dp_ntprp','physpkg',dtype_r8,(/pcols,pver /),dp_ntprp_idx) - call pbuf_add_field('dp_ntsnp','physpkg',dtype_r8,(/pcols,pver /),dp_ntsnp_idx) -!-tht - -! Flux of snow from deep convection (kg/m2/s) - call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) - - call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) - call pbuf_add_field('RPRDDP', 'physpkg',dtype_r8,(/pcols,pver/),rprddp_idx) - call pbuf_add_field('NEVAPR_DPCU','physpkg',dtype_r8,(/pcols,pver/),nevapr_dpcu_idx) - call pbuf_add_field('PREC_DP', 'physpkg',dtype_r8,(/pcols/), prec_dp_idx) - call pbuf_add_field('SNOW_DP', 'physpkg',dtype_r8,(/pcols/), snow_dp_idx) - - ! detrained convective cloud water mixing ratio. - call pbuf_add_field('DLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dlfzm_idx) - ! convective mass fluxes - call pbuf_add_field('CMFMC_DP', 'physpkg', dtype_r8, (/pcols,pverp/), mconzm_idx) - - -end subroutine zm_conv_register - -!========================================================================================= - -subroutine zm_conv_readnl(nlfile) - - use spmd_utils, only: mpicom, masterproc, masterprocid, mpi_real8, mpi_integer, mpi_logical - use namelist_utils, only: find_group_name - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'zm_conv_readnl' - - namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_num_cin, & - zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, & - zmconv_dmpdz, zmconv_tiedke_add, zmconv_capelmt, & - zmconv_tiedke_lnd, & !+tht additional param - zmconv_tht_thermo, & !+tht additional param - zmconv_retrigger , & !+tht additional param - zmconv_entrmn , & !+tht undeclared param (=2e-4_kind_phys) ! maximum convective entrainment rate - zmconv_alfadet , & !+tht undeclared param (=1e-1_kind_phys) ! convective detrainment/entrainment ratio - zmconv_plclmin , & !+tht undeclated param (=6.e2_kind_phys) ! don't convect if LCL above this level (p= 4.e3_r8) then - limcnv = 1 - else - do k=1,plev - if (pref_edge(k) < 4.e3_r8 .and. pref_edge(k+1) >= 4.e3_r8) then - limcnv = k - exit - end if - end do - if ( limcnv == 0 ) limcnv = plevp - end if - - if (masterproc) then - write(iulog,*)'ZM_CONV_INIT: Deep convection will be capped at intfc ',limcnv, & - ' which is ',pref_edge(limcnv),' pascals' - end if - - ! If thickness of bottom layer is less than dz_min, and zmconv_parcel_pbl=.false., - ! then issue a warning. - dz_bot_layer = scale_height * log(pref_edge(pverp)/pref_edge(pver)) - if (dz_bot_layer < dz_min .and. .not. zmconv_parcel_pbl) then - if (masterproc) then - write(iulog,*)'********** WARNING **********' - write(iulog,*)' ZM_CONV_INIT: Bottom layer thickness (m) is ', dz_bot_layer - write(iulog,*)' The namelist variable zmconv_parcel_pbl should be set to .true.' - write(iulog,*)' when the bottom layer thickness is < ', dz_min - write(iulog,*)'********** WARNING **********' - end if - end if - - no_deep_pbl = phys_deepconv_pbl() - call zm_convr_init(plev, plevp, cpair, cpliq, cpwv, epsilo, gravit, latvap, tmelt, rair, & - pref_edge,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, zmconv_num_cin, & - no_deep_pbl, zmconv_tiedke_add, & -!+tht - zmconv_tiedke_lnd,& - zmconv_entrmn ,& - zmconv_alfadet ,& - zmconv_plclmin ,& - zmconv_tht_thermo,& - zmconv_retrigger ,& -!-tht - zmconv_capelmt, zmconv_dmpdz, & - zmconv_parcel_pbl, zmconv_parcel_hscale, zmconv_tau, & - masterproc, iulog, errmsg, errflg) - - if (errflg /= 0) then - call endrun('From zm_convr_init:' // errmsg) - end if - - cld_idx = pbuf_get_index('CLD') - fracis_idx = pbuf_get_index('FRACIS') - -end subroutine zm_conv_init -!========================================================================================= -!subroutine zm_conv_tend(state, ptend, tdt) - -subroutine zm_conv_tend(pblh ,mcon ,cme , & - tpert ,zdu , & - rliq ,rice ,ztodt , & - jctop ,jcbot , & - state ,ptend_all ,landfrac, pbuf) - - - use cam_history, only: outfld - use physics_types, only: physics_state, physics_ptend - use physics_types, only: physics_ptend_init, physics_update - use physics_types, only: physics_state_copy, physics_state_dealloc - use physics_types, only: physics_ptend_sum, physics_ptend_dealloc - - use time_manager, only: get_nstep, is_first_step - use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx - use physics_buffer, only : pbuf_set_field !+tht - use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 - use physconst, only: gravit, latice, latvap, tmelt, cpwv, cpliq, rh2o - use phys_grid, only: get_rlat_all_p, get_rlon_all_p - - use phys_control, only: cam_physpkg_is - use ccpp_constituent_prop_mod, only: ccpp_const_props - - ! Arguments - - type(physics_state), intent(in),target :: state ! Physics state variables - type(physics_ptend), intent(out) :: ptend_all ! individual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - real(r8), intent(in) :: pblh(pcols) ! Planetary boundary layer height - real(r8), intent(in) :: tpert(pcols) ! Thermal temperature excess - real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac - - real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c - real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation - real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux - - real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals - real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldice) for energy integrals - - - ! Local variables - character(len=512) :: errmsg - integer :: errflg - - integer :: i,k,l,m - integer :: ilon ! global longitude index of a column - integer :: ilat ! global latitude index of a column - integer :: nstep - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: itim_old ! for physics buffer fields - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - real(r8) :: ntprprd(pcols,pver) ! evap outfld: net precip production in layer - real(r8) :: ntsnprd(pcols,pver) ! evap outfld: net snow production in layer - real(r8) :: tend_s_snwprd (pcols,pver) ! Heating rate of snow production - real(r8) :: tend_s_snwevmlt(pcols,pver) ! Heating rate of evap/melting of snow - real(r8) :: fake_dpdry(pcols,pver) ! used in convtran call - - ! physics types - type(physics_state) :: state1 ! locally modify for evaporation to use, not returned - type(physics_ptend),target :: ptend_loc ! package tendencies - - ! physics buffer fields - real(r8), pointer, dimension(:) :: prec ! total precipitation - real(r8), pointer, dimension(:) :: snow ! snow from ZM convection - real(r8), pointer, dimension(:,:) :: cld - real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. - real(r8), pointer, dimension(:,:) :: rprd ! rain production rate - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - real(r8), pointer, dimension(:,:) :: evapcdp ! Evaporation of deep convective precipitation - real(r8), pointer, dimension(:,:) :: flxprec ! Convective-scale flux of precip at interfaces (kg/m2/s) - real(r8), pointer, dimension(:,:) :: flxsnow ! Convective-scale flux of snow at interfaces (kg/m2/s) - real(r8), pointer :: dlf(:,:) ! detrained convective cloud water mixing ratio. - real(r8), pointer :: lambdadpcu(:,:) ! slope of cloud liquid size distr - real(r8), pointer :: mudpcu(:,:) ! width parameter of droplet size distr - real(r8), pointer :: mconzm(:,:) !convective mass fluxes - - real(r8), pointer :: mu(:,:) ! (pcols,pver) - real(r8), pointer :: eu(:,:) ! (pcols,pver) - real(r8), pointer :: du(:,:) ! (pcols,pver) - real(r8), pointer :: md(:,:) ! (pcols,pver) - real(r8), pointer :: ed(:,:) ! (pcols,pver) - real(r8), pointer :: dp(:,:) ! (pcols,pver) - real(r8), pointer :: dsubcld(:) ! (pcols) - integer, pointer :: jt(:) ! (pcols) - integer, pointer :: maxg(:) ! (pcols) - integer, pointer :: ideep(:) ! (pcols) - integer :: lengath - - real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. - real(r8) :: jcbot(pcols) ! o row of base of cloud indices passed out. - - real(r8) :: pcont(pcols), pconb(pcols), freqzm(pcols) - - real(r8) :: lat_all(pcols), long_all(pcols) - -!+tht - real(r8) :: eurt(pcols,pver) !+tht: entr.rate 3D -!-tht - - ! history output fields - real(r8) :: cape(pcols) ! w convective available potential energy. - real(r8) :: mu_out(pcols,pver) - real(r8) :: md_out(pcols,pver) - real(r8) :: dif(pcols,pver) - - ! used in momentum transport calculation - real(r8) :: pguallu(pcols, pver) - real(r8) :: pguallv(pcols, pver) - real(r8) :: pgdallu(pcols, pver) - real(r8) :: pgdallv(pcols, pver) - real(r8) :: icwuu(pcols,pver) - real(r8) :: icwuv(pcols,pver) - real(r8) :: icwdu(pcols,pver) - real(r8) :: icwdv(pcols,pver) - real(r8) :: seten(pcols, pver) - logical :: l_windt - real(r8) :: tfinal1, tfinal2 - integer :: ii - - real(r8) :: fice(pcols,pver) - real(r8) :: fsnow_conv(pcols,pver) - - logical :: lq(pcnst) - character(len=16) :: macrop_scheme - character(len=40) :: scheme_name - character(len=40) :: str - integer :: top_lev - - !---------------------------------------------------------------------- - - ! initialize - lchnk = state%lchnk - ncol = state%ncol - nstep = get_nstep() - - ftem = 0._r8 - mu_out(:,:) = 0._r8 - md_out(:,:) = 0._r8 - - call physics_state_copy(state,state1) ! copy state to local state1. - - lq(:) = .FALSE. - lq(1) = .TRUE. - call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr_run', ls=.true., lq=lq)! initialize local ptend type - -! -! Associate pointers with physics buffer fields -! - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, icwmrdp_idx, ql ) - call pbuf_get_field(pbuf, rprddp_idx, rprd ) - call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) - call pbuf_get_field(pbuf, prec_dp_idx, prec ) - call pbuf_get_field(pbuf, snow_dp_idx, snow ) - - call pbuf_get_field(pbuf, zm_mu_idx, mu) - call pbuf_get_field(pbuf, zm_eu_idx, eu) - call pbuf_get_field(pbuf, zm_du_idx, du) - call pbuf_get_field(pbuf, zm_md_idx, md) - call pbuf_get_field(pbuf, zm_ed_idx, ed) - call pbuf_get_field(pbuf, zm_dp_idx, dp) - call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) - 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) - - call pbuf_get_field(pbuf, dlfzm_idx, dlf) - call pbuf_get_field(pbuf, mconzm_idx, mconzm) - -! Begin with Zhang-McFarlane (1996) convection parameterization -! - call t_startf ('zm_convr_run') - -!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - ptend_loc%q(:,:,1) = 0._r8 - ptend_loc%s(:,:) = 0._r8 - dif(:,:) = 0._r8 - mcon(:,:) = 0._r8 - dlf(:,:) = 0._r8 - cme(:,:) = 0._r8 - cape(:) = 0._r8 - zdu(:,:) = 0._r8 - rprd(:,:) = 0._r8 - mu(:,:) = 0._r8 - eu(:,:) = 0._r8 - du(:,:) = 0._r8 - md(:,:) = 0._r8 - ed(:,:) = 0._r8 - dp(:,:) = 0._r8 - dsubcld(:) = 0._r8 - jctop(:) = 0._r8 - jcbot(:) = 0._r8 - prec(:) = 0._r8 - rliq(:) = 0._r8 - rice(:) = 0._r8 - ideep(:) = 0._r8 -!REMOVECAM_END - - - call get_rlat_all_p(lchnk, ncol, lat_all) - call get_rlon_all_p(lchnk, ncol, long_all) - - call zm_convr_run(ncol, pver, & - pverp, gravit, latice, cpwv, cpliq, rh2o, & - lat_all, long_all, & - state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), & - pblh(:ncol), state%zm(:ncol,:), state%phis(:ncol), state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & - ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & - ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), eurt(:ncol,:), & !tht - tpert(:ncol), dlf(:ncol,:), dif(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & - mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & - dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & - ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & - rice(:ncol), lengath, scheme_name, errmsg, errflg) - - if (errflg /= 0) then - write(str,*) 'From zm_convr_run: at chunk ',lchnk, ' : ' - call endrun(str // errmsg) - end if - - jctop(:) = real(pver,r8) - jcbot(:) = 1._r8 - do i = 1,lengath - jctop(ideep(i)) = real(jt(i), r8) - jcbot(ideep(i)) = real(maxg(i), r8) - end do - - call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output - call outfld('EURT', eurt(1,1), pcols, lchnk) !+tht - -! -! Output fractional occurance of ZM convection -! - freqzm(:) = 0._r8 - do i = 1,lengath - freqzm(ideep(i)) = 1.0_r8 - end do - call outfld('FREQZM ',freqzm ,pcols ,lchnk ) - - mconzm(:ncol,:pverp) = mcon(:ncol,:pverp) - - call outfld('CMFMC_DP', mconzm, pcols, lchnk) - - ! Store upward and downward mass fluxes in un-gathered arrays - ! + convert from mb/s to kg/m^2/s - do i=1,lengath - do k=1,pver - ii = ideep(i) - mu_out(ii,k) = mu(i,k) * 100._r8/gravit - md_out(ii,k) = md(i,k) * 100._r8/gravit - end do - end do - - call outfld('ZMMU', mu_out, pcols, lchnk) - call outfld('ZMMD', md_out, pcols, lchnk) - - ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair - call outfld('ZMDT ',ftem ,pcols ,lchnk ) - call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) - call t_stopf ('zm_convr_run') - - call outfld('DLFZM' ,dlf ,pcols, lchnk) - - pcont(:ncol) = state%ps(:ncol) - pconb(:ncol) = state%ps(:ncol) - do i = 1,lengath - if (maxg(i).gt.jt(i)) then - pcont(ideep(i)) = state%pmid(ideep(i),jt(i)) ! gathered array (or jctop ungathered) - pconb(ideep(i)) = state%pmid(ideep(i),maxg(i))! gathered array - endif - ! write(iulog,*) ' pcont, pconb ', pcont(i), pconb(i), cnt(i), cnb(i) - end do - call outfld('PCONVT ',pcont ,pcols ,lchnk ) - call outfld('PCONVB ',pconb ,pcols ,lchnk ) - - call physics_ptend_init(ptend_all, state%psetcols, 'zm_conv_tend') - - ! add tendency from this process to tendencies from other processes - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - ! update physics state type state1 with ptend_loc - call physics_update(state1, ptend_loc, ztodt) - - ! initialize ptend for next process - lq(:) = .FALSE. - lq(1) = .TRUE. - call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap_run', ls=.true., lq=lq) - - call t_startf ('zm_conv_evap_run') -! -! Determine the phase of the precipitation produced and add latent heat of fusion -! Evaporate some of the precip directly into the environment (Sundqvist) -! Allow this to use the updated state1 and the fresh ptend_loc type -! heating and specific humidity tendencies produced -! - - call pbuf_get_field(pbuf, dp_flxprc_idx, flxprec ) - call pbuf_get_field(pbuf, dp_flxsnw_idx, flxsnow ) -!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - flxprec(:,:) = 0._r8 - flxsnow(:,:) = 0._r8 - snow(:) = 0._r8 - fice(:,:) = 0._r8 - fsnow_conv(:,:) = 0._r8 -!REMOVECAM_END - - top_lev = 1 - call phys_getopts (macrop_scheme_out = macrop_scheme) - if ( .not. (macrop_scheme == "rk")) top_lev = trop_cloud_top_lev - - call cloud_fraction_fice_run(ncol, state1%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow_conv(:ncol,:), errmsg, errflg) - - call zm_conv_evap_run(state1%ncol, pver, pverp, & - gravit, latice, latvap, tmelt, & - cpair, zmconv_ke, zmconv_ke_lnd, & - state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & - landfrac(:ncol), & - ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & - rprd(:ncol,:), cld(:ncol,:), ztodt, & - prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), fsnow_conv(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:),& - scheme_name, errmsg, errflg) - - evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) -!+tht - call pbuf_set_field(pbuf, dp_ntprp_idx, ntprprd) - call pbuf_set_field(pbuf, dp_ntsnp_idx, ntsnprd) -!-tht - -! -! Write out variables from zm_conv_evap_run -! - ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair - call outfld('EVAPTZM ',ftem ,pcols ,lchnk ) - ftem(:ncol,:pver) = tend_s_snwprd (:ncol,:pver)/cpair - call outfld('FZSNTZM ',ftem ,pcols ,lchnk ) - ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver)/cpair - call outfld('EVSNTZM ',ftem ,pcols ,lchnk ) - call outfld('EVAPQZM ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) - call outfld('ZMFLXPRC', flxprec, pcols, lchnk) - call outfld('ZMFLXSNW', flxsnow, pcols, lchnk) - call outfld('ZMNTPRPD', ntprprd, pcols, lchnk) - call outfld('ZMNTSNPD', ntsnprd, pcols, lchnk) - call outfld('ZMEIHEAT', ptend_loc%s, pcols, lchnk) - call outfld('CMFMC_DP ',mcon , pcols ,lchnk ) - call outfld('PRECCDZM ',prec, pcols ,lchnk ) - - - call t_stopf ('zm_conv_evap_run') - - call outfld('PRECZ ', prec , pcols, lchnk) - - ! add tendency from this process to tend from other processes here - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - ! update physics state type state1 with ptend_loc - call physics_update(state1, ptend_loc, ztodt) - - - ! Momentum Transport - - call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) - - l_windt = .true. -!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - ptend_loc%s(:,:) = 0._r8 - ptend_loc%u(:,:) = 0._r8 - ptend_loc%v(:,:) = 0._r8 -!REMOVECAM_END - - call t_startf ('zm_conv_momtran_run') - - call zm_conv_momtran_run (ncol, pver, pverp, & - l_windt,state1%u(:ncol,:), state1%v(:ncol,:), mu(:ncol,:), md(:ncol,:), & - zmconv_momcu, zmconv_momcd, & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, ptend_loc%u(:ncol,:), ptend_loc%v(:ncol,:),& - pguallu(:ncol,:), pguallv(:ncol,:), pgdallu(:ncol,:), pgdallv(:ncol,:), & - icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:), & - scheme_name, errmsg, errflg) - call t_stopf ('zm_conv_momtran_run') - - ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) - - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - ! Output ptend variables before they are set to zero with physics_update - call outfld('ZMMTU', ptend_loc%u, pcols, lchnk) - call outfld('ZMMTV', ptend_loc%v, pcols, lchnk) - - ! update physics state type state1 with ptend_loc - call physics_update(state1, ptend_loc, ztodt) - - ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair - call outfld('ZMMTT', ftem , pcols, lchnk) - - ! Output apparent force from pressure gradient - call outfld('ZMUPGU', pguallu, pcols, lchnk) - call outfld('ZMUPGD', pgdallu, pcols, lchnk) - call outfld('ZMVPGU', pguallv, pcols, lchnk) - call outfld('ZMVPGD', pgdallv, pcols, lchnk) - - ! Output in-cloud winds - call outfld('ZMICUU', icwuu, pcols, lchnk) - call outfld('ZMICUD', icwdu, pcols, lchnk) - call outfld('ZMICVU', icwuv, pcols, lchnk) - call outfld('ZMICVD', icwdv, pcols, lchnk) - - ! Transport cloud water and ice only - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - lq(:) = .FALSE. - lq(2:) = cnst_is_convtran1(2:) - call physics_ptend_init(ptend_loc, state1%psetcols, 'convtran1', lq=lq) - - - ! dpdry is not used in this call to convtran since the cloud liquid and ice mixing - ! ratios are moist - fake_dpdry(:,:) = 0._r8 - - call t_startf ('convtran1') - -!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - ptend_loc%q(:,:,:) = 0._r8 -!REMOVECAM_END - - call zm_conv_convtran_run (ncol, pver, & - ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ccpp_const_props, & - scheme_name, errmsg, errflg) - call t_stopf ('convtran1') - - call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) - call outfld('ZMDLIQ ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk ) - - ! add tendency from this process to tend from other processes here - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - call physics_state_dealloc(state1) - call physics_ptend_dealloc(ptend_loc) - - - -end subroutine zm_conv_tend -!========================================================================================= - - -subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) - - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use time_manager, only: get_nstep - use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc - use constituents, only: pcnst, cnst_is_convtran2 - use ccpp_constituent_prop_mod, only: ccpp_const_props - - -! Arguments - type(physics_state), intent(in ) :: state ! Physics state variables - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - -! Local variables - integer :: i, lchnk, istat - integer :: lengath ! number of columns with deep convection - integer :: nstep - integer :: ncol - - real(r8), dimension(pcols,pver) :: dpdry - - ! physics buffer fields - real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - real(r8), pointer :: mu(:,:) ! (pcols,pver) - real(r8), pointer :: eu(:,:) ! (pcols,pver) - real(r8), pointer :: du(:,:) ! (pcols,pver) - real(r8), pointer :: md(:,:) ! (pcols,pver) - real(r8), pointer :: ed(:,:) ! (pcols,pver) - real(r8), pointer :: dp(:,:) ! (pcols,pver) - real(r8), pointer :: dsubcld(:) ! (pcols) - integer, pointer :: jt(:) ! (pcols) - integer, pointer :: maxg(:) ! (pcols) - integer, pointer :: ideep(:) ! (pcols) - - character(len=40) :: scheme_name - character(len=512) :: errmsg - integer :: errflg - - !----------------------------------------------------------------------------------- - - - call physics_ptend_init(ptend, state%psetcols, 'convtran2', lq=cnst_is_convtran2 ) - - call pbuf_get_field(pbuf, fracis_idx, fracis) - call pbuf_get_field(pbuf, zm_mu_idx, mu) - call pbuf_get_field(pbuf, zm_eu_idx, eu) - call pbuf_get_field(pbuf, zm_du_idx, du) - call pbuf_get_field(pbuf, zm_md_idx, md) - call pbuf_get_field(pbuf, zm_ed_idx, ed) - call pbuf_get_field(pbuf, zm_dp_idx, dp) - call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) - 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) - - - lchnk = state%lchnk - ncol = state%ncol - nstep = get_nstep() - - lengath = count(ideep > 0) - if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake - - if (any(ptend%lq(:))) then - ! initialize dpdry for call to convtran - ! it 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 t_startf ('convtran2') - -!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - ptend%q(:,:,:) = 0._r8 -!REMOVECAM_END - - call zm_conv_convtran_run (ncol, pver, & - ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ccpp_const_props, & - scheme_name, errmsg, errflg) - - if (errflg /= 0) then - call endrun('From zm_conv_convtran_run:' // errmsg) - end if - - call t_stopf ('convtran2') - end if - -end subroutine zm_conv_tend_2 - -!========================================================================================= - - -end module zm_conv_intr diff --git a/src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only b/src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only deleted file mode 100644 index 5d5b3ff95f..0000000000 --- a/src/physics/camnor_phys/physics/zm_conv_intr.F90.enthalpy-only +++ /dev/null @@ -1,928 +0,0 @@ -module zm_conv_intr -!--------------------------------------------------------------------------------- -! Purpose: -! -! CAM interface to the Zhang-McFarlane deep convection scheme -! -! Author: D.B. Coleman -! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer -!--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8=>shr_kind_r8 - use physconst, only: cpair, epsilo, gravit, latvap, tmelt, rair - use ppgrid, only: pver, pcols, pverp, begchunk, endchunk - use zm_conv_evap, only: zm_conv_evap_run - use zm_convr, only: zm_convr_init, zm_convr_run - use zm_conv_convtran, only: zm_conv_convtran_run - use zm_conv_momtran, only: zm_conv_momtran_run - use cloud_fraction_fice, only: cloud_fraction_fice_run - - use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & - rad_cnst_get_aer_props, rad_cnst_get_mode_props !, & - use cam_abortutils, only: endrun - use physconst, only: pi - use spmd_utils, only: masterproc - use perf_mod - use cam_logfile, only: iulog - use constituents, only: cnst_add - use ref_pres, only: trop_cloud_top_lev - use phys_control, only: phys_getopts - - implicit none - private - save - - ! Public methods - - public ::& - zm_conv_register, &! register fields in physics buffer - zm_conv_readnl, &! read namelist - zm_conv_init, &! initialize donner_deep module - zm_conv_tend, &! return tendencies - zm_conv_tend_2 ! return tendencies - - public zmconv_ke, zmconv_ke_lnd ! needed by convect_shallow - - integer ::& ! indices for fields in the physics buffer - zm_mu_idx, & - zm_eu_idx, & - zm_du_idx, & - zm_md_idx, & - zm_ed_idx, & - zm_dp_idx, & - zm_dsubcld_idx, & - zm_jt_idx, & - zm_maxg_idx, & - zm_ideep_idx, & - dp_flxprc_idx, & - dp_flxsnw_idx, & - dp_cldliq_idx, & - dp_cldice_idx, & - dlfzm_idx, & ! detrained convective cloud water mixing ratio. - prec_dp_idx, & - snow_dp_idx, & - mconzm_idx ! convective mass flux -!+tht - integer :: dp_ntprp_idx = 0 - integer :: dp_ntsnp_idx = 0 -!-tht - - real(r8), parameter :: unset_r8 = huge(1.0_r8) - real(r8) :: zmconv_c0_lnd = unset_r8 - real(r8) :: zmconv_c0_ocn = unset_r8 - real(r8) :: zmconv_ke = unset_r8 - real(r8) :: zmconv_ke_lnd = unset_r8 - real(r8) :: zmconv_momcu = unset_r8 - real(r8) :: zmconv_momcd = unset_r8 - integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed - ! before the convection top and CAPE calculations are completed. - real(r8) :: zmconv_dmpdz = unset_r8 ! Parcel fractional mass entrainment rate - real(r8) :: zmconv_tiedke_add = unset_r8 ! Convective parcel temperature perturbation - real(r8) :: zmconv_capelmt = unset_r8 ! Triggering thereshold for ZM convection - logical :: zmconv_parcel_pbl = .false. ! switch for parcel pbl calculation - real(r8) :: zmconv_parcel_hscale = unset_r8! Fraction of PBL depth over which to mix initial parcel - real(r8) :: zmconv_tau = unset_r8 ! Timescale for convection - - -! indices for fields in the physics buffer - integer :: cld_idx = 0 - integer :: icwmrdp_idx = 0 - integer :: rprddp_idx = 0 - integer :: fracis_idx = 0 - integer :: nevapr_dpcu_idx = 0 - integer :: dgnum_idx = 0 - - integer :: nmodes - integer :: nbulk - -!========================================================================================= -contains -!========================================================================================= - -subroutine zm_conv_register - -!---------------------------------------- -! Purpose: register fields with the physics buffer -!---------------------------------------- - - use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 - - implicit none - - integer idx - - call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) - call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) - call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) - call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) - call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) - - ! wg layer thickness in mbs (between upper/lower interface). - call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) - - ! wg layer thickness in mbs between lcl and maxi. - call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) - - ! wg top level index of deep cumulus convection. - call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) - - ! wg gathered values of maxi. - call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) - - ! map gathered points to chunk index - call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) - -! Flux of precipitation from deep convection (kg/m2/s) - call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) -!+tht - call pbuf_add_field('dp_ntprp','physpkg',dtype_r8,(/pcols,pver /),dp_ntprp_idx) - call pbuf_add_field('dp_ntsnp','physpkg',dtype_r8,(/pcols,pver /),dp_ntsnp_idx) -!-tht - -! Flux of snow from deep convection (kg/m2/s) - call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) - - call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) - call pbuf_add_field('RPRDDP', 'physpkg',dtype_r8,(/pcols,pver/),rprddp_idx) - call pbuf_add_field('NEVAPR_DPCU','physpkg',dtype_r8,(/pcols,pver/),nevapr_dpcu_idx) - call pbuf_add_field('PREC_DP', 'physpkg',dtype_r8,(/pcols/), prec_dp_idx) - call pbuf_add_field('SNOW_DP', 'physpkg',dtype_r8,(/pcols/), snow_dp_idx) - - ! detrained convective cloud water mixing ratio. - call pbuf_add_field('DLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dlfzm_idx) - ! convective mass fluxes - call pbuf_add_field('CMFMC_DP', 'physpkg', dtype_r8, (/pcols,pverp/), mconzm_idx) - -end subroutine zm_conv_register - -!========================================================================================= - -subroutine zm_conv_readnl(nlfile) - - use spmd_utils, only: mpicom, masterproc, masterprocid, mpi_real8, mpi_integer, mpi_logical - use namelist_utils, only: find_group_name - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'zm_conv_readnl' - - namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_num_cin, & - zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, & - zmconv_dmpdz, zmconv_tiedke_add, zmconv_capelmt, & - zmconv_parcel_hscale, & - zmconv_parcel_pbl, zmconv_tau - !----------------------------------------------------------------------------- - - if (masterproc) then - open( newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'zmconv_nl', status=ierr) - if (ierr == 0) then - read(unitn, zmconv_nl, 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(zmconv_num_cin, 1, mpi_integer, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_num_cin") - call mpi_bcast(zmconv_c0_lnd, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_c0_lnd") - call mpi_bcast(zmconv_c0_ocn, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_c0_ocn") - call mpi_bcast(zmconv_ke, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_ke") - call mpi_bcast(zmconv_ke_lnd, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_ke_lnd") - call mpi_bcast(zmconv_momcu, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcu") - call mpi_bcast(zmconv_momcd, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcd") - call mpi_bcast(zmconv_dmpdz, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_dmpdz") - call mpi_bcast(zmconv_tiedke_add, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_tiedke_add") - call mpi_bcast(zmconv_capelmt, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_capelmt") - call mpi_bcast(zmconv_parcel_pbl, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_parcel_pbl") - call mpi_bcast(zmconv_parcel_hscale, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_parcel_hscale") - call mpi_bcast(zmconv_tau, 1, mpi_real8, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_tau") - -end subroutine zm_conv_readnl - -!========================================================================================= - -subroutine zm_conv_init(pref_edge) - -!---------------------------------------- -! Purpose: declare output fields, initialize variables needed by convection -!---------------------------------------- - - use cam_history, only: addfld, add_default, horiz_only - use ppgrid, only: pcols, pver - use zm_convr, only: zm_convr_init - use pmgrid, only: plev,plevp - use spmd_utils, only: masterproc - use phys_control, only: phys_deepconv_pbl, phys_getopts, cam_physpkg_is - use physics_buffer, only: pbuf_get_index - - implicit none - - real(r8),intent(in) :: pref_edge(plevp) ! reference pressures at interfaces - - ! local variables - real(r8), parameter :: scale_height = 7000._r8 ! std atm scale height (m) - real(r8), parameter :: dz_min = 100._r8 ! minimum thickness for using - ! zmconv_parcel_pbl=.false. - real(r8) :: dz_bot_layer ! thickness of bottom layer (m) - - character(len=512) :: errmsg - integer :: errflg - - logical :: no_deep_pbl ! if true, no deep convection in PBL - integer limcnv ! top interface level limit for convection - integer k, istat - logical :: history_budget ! output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - integer :: history_budget_histfile_num ! output history file number for budget fields - -! -! Register fields with the output buffer -! - - call addfld ('PRECZ', horiz_only, 'A', 'm/s','total precipitation from ZM convection') - call addfld ('ZMDT', (/ 'lev' /), 'A', 'K/s','T tendency - Zhang-McFarlane moist convection') - call addfld ('ZMDQ', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Zhang-McFarlane moist convection') - call addfld ('ZMDICE', (/ 'lev' /), 'A', 'kg/kg/s','Cloud ice tendency - Zhang-McFarlane convection') - call addfld ('ZMDLIQ', (/ 'lev' /), 'A', 'kg/kg/s','Cloud liq tendency - Zhang-McFarlane convection') - call addfld ('EVAPTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Evaporation/snow prod from Zhang convection') - call addfld ('FZSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Rain to snow conversion from Zhang convection') - call addfld ('EVSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Snow to rain prod from Zhang convection') - call addfld ('EVAPQZM', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Evaporation from Zhang-McFarlane moist convection') - - call addfld ('ZMFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of precipitation from ZM convection' ) - call addfld ('ZMFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of snow from ZM convection' ) - call addfld ('ZMNTPRPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net precipitation production from ZM convection') - call addfld ('ZMNTSNPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net snow production from ZM convection' ) - call addfld ('ZMEIHEAT', (/ 'lev' /) , 'A', 'W/kg' ,'Heating by ice and evaporation in ZM convection') - - call addfld ('CMFMC_DP', (/ 'ilev' /), 'A', 'kg/m2/s','Convection mass flux from ZM deep ') - call addfld ('PRECCDZM', horiz_only, 'A', 'm/s','Convective precipitation rate from ZM deep') - - call addfld ('PCONVB', horiz_only , 'A', 'Pa' ,'convection base pressure') - call addfld ('PCONVT', horiz_only , 'A', 'Pa' ,'convection top pressure') - - call addfld ('CAPE', horiz_only, 'A', 'J/kg', 'Convectively available potential energy') - call addfld ('FREQZM', horiz_only , 'A', 'fraction', 'Fractional occurance of ZM convection') - - call addfld ('ZMMTT', (/ 'lev' /), 'A', 'K/s', 'T tendency - ZM convective momentum transport') - call addfld ('ZMMTU', (/ 'lev' /), 'A', 'm/s2', 'U tendency - ZM convective momentum transport') - call addfld ('ZMMTV', (/ 'lev' /), 'A', 'm/s2', 'V tendency - ZM convective momentum transport') - - call addfld ('ZMMU', (/ 'lev' /), 'A', 'kg/m2/s', 'ZM convection updraft mass flux') - call addfld ('ZMMD', (/ 'lev' /), 'A', 'kg/m2/s', 'ZM convection downdraft mass flux') - - call addfld ('ZMUPGU', (/ 'lev' /), 'A', 'm/s2', 'zonal force from ZM updraft pressure gradient term') - call addfld ('ZMUPGD', (/ 'lev' /), 'A', 'm/s2', 'zonal force from ZM downdraft pressure gradient term') - call addfld ('ZMVPGU', (/ 'lev' /), 'A', 'm/s2', 'meridional force from ZM updraft pressure gradient term') - call addfld ('ZMVPGD', (/ 'lev' /), 'A', 'm/s2', 'merdional force from ZM downdraft pressure gradient term') - - call addfld ('ZMICUU', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud U updrafts') - call addfld ('ZMICUD', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud U downdrafts') - call addfld ('ZMICVU', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud V updrafts') - call addfld ('ZMICVD', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud V downdrafts') - - call addfld ('DLFZM' ,(/ 'lev' /), 'A','kg/kg/s ','Detrained liquid water from ZM convection') - - call phys_getopts( history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num) - - if ( history_budget ) then - call add_default('EVAPTZM ', history_budget_histfile_num, ' ') - call add_default('EVAPQZM ', history_budget_histfile_num, ' ') - call add_default('ZMDT ', history_budget_histfile_num, ' ') - call add_default('ZMDQ ', history_budget_histfile_num, ' ') - call add_default('ZMDLIQ ', history_budget_histfile_num, ' ') - call add_default('ZMDICE ', history_budget_histfile_num, ' ') - call add_default('ZMMTT ', history_budget_histfile_num, ' ') - end if - -! -! Limit deep convection to regions below 40 mb -! Note this calculation is repeated in the shallow convection interface -! - limcnv = 0 ! null value to check against below - if (pref_edge(1) >= 4.e3_r8) then - limcnv = 1 - else - do k=1,plev - if (pref_edge(k) < 4.e3_r8 .and. pref_edge(k+1) >= 4.e3_r8) then - limcnv = k - exit - end if - end do - if ( limcnv == 0 ) limcnv = plevp - end if - - if (masterproc) then - write(iulog,*)'ZM_CONV_INIT: Deep convection will be capped at intfc ',limcnv, & - ' which is ',pref_edge(limcnv),' pascals' - end if - - ! If thickness of bottom layer is less than dz_min, and zmconv_parcel_pbl=.false., - ! then issue a warning. - dz_bot_layer = scale_height * log(pref_edge(pverp)/pref_edge(pver)) - if (dz_bot_layer < dz_min .and. .not. zmconv_parcel_pbl) then - if (masterproc) then - write(iulog,*)'********** WARNING **********' - write(iulog,*)' ZM_CONV_INIT: Bottom layer thickness (m) is ', dz_bot_layer - write(iulog,*)' The namelist variable zmconv_parcel_pbl should be set to .true.' - write(iulog,*)' when the bottom layer thickness is < ', dz_min - write(iulog,*)'********** WARNING **********' - end if - end if - - no_deep_pbl = phys_deepconv_pbl() - call zm_convr_init(plev, plevp, cpair, epsilo, gravit, latvap, tmelt, rair, & - pref_edge,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, zmconv_num_cin, & - no_deep_pbl, zmconv_tiedke_add, & - zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_parcel_hscale, zmconv_tau, & - masterproc, iulog, errmsg, errflg) - - if (errflg /= 0) then - call endrun('From zm_convr_init:' // errmsg) - end if - - cld_idx = pbuf_get_index('CLD') - fracis_idx = pbuf_get_index('FRACIS') - -end subroutine zm_conv_init -!========================================================================================= -!subroutine zm_conv_tend(state, ptend, tdt) - -subroutine zm_conv_tend(pblh ,mcon ,cme , & - tpert ,zdu , & - rliq ,rice ,ztodt , & - jctop ,jcbot , & - state ,ptend_all ,landfrac, pbuf) - - - use cam_history, only: outfld - use physics_types, only: physics_state, physics_ptend - use physics_types, only: physics_ptend_init, physics_update - use physics_types, only: physics_state_copy, physics_state_dealloc - use physics_types, only: physics_ptend_sum, physics_ptend_dealloc - - use time_manager, only: get_nstep, is_first_step - use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx - use physics_buffer, only : pbuf_set_field - use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 - use physconst, only: gravit, latice, latvap, tmelt, cpwv, cpliq, rh2o - use phys_grid, only: get_rlat_all_p, get_rlon_all_p - - use phys_control, only: cam_physpkg_is - use ccpp_constituent_prop_mod, only: ccpp_const_props - - ! Arguments - - type(physics_state), intent(in),target :: state ! Physics state variables - type(physics_ptend), intent(out) :: ptend_all ! individual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - real(r8), intent(in) :: pblh(pcols) ! Planetary boundary layer height - real(r8), intent(in) :: tpert(pcols) ! Thermal temperature excess - real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac - - real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c - real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation - real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux - - real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals - real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldice) for energy integrals - - - ! Local variables - character(len=512) :: errmsg - integer :: errflg - - integer :: i,k,l,m - integer :: ilon ! global longitude index of a column - integer :: ilat ! global latitude index of a column - integer :: nstep - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: itim_old ! for physics buffer fields - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - real(r8) :: ntprprd(pcols,pver) ! evap outfld: net precip production in layer - real(r8) :: ntsnprd(pcols,pver) ! evap outfld: net snow production in layer - real(r8) :: tend_s_snwprd (pcols,pver) ! Heating rate of snow production - real(r8) :: tend_s_snwevmlt(pcols,pver) ! Heating rate of evap/melting of snow - real(r8) :: fake_dpdry(pcols,pver) ! used in convtran call - - ! physics types - type(physics_state) :: state1 ! locally modify for evaporation to use, not returned - type(physics_ptend),target :: ptend_loc ! package tendencies - - ! physics buffer fields - real(r8), pointer, dimension(:) :: prec ! total precipitation - real(r8), pointer, dimension(:) :: snow ! snow from ZM convection - real(r8), pointer, dimension(:,:) :: cld - real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. - real(r8), pointer, dimension(:,:) :: rprd ! rain production rate - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - real(r8), pointer, dimension(:,:) :: evapcdp ! Evaporation of deep convective precipitation - real(r8), pointer, dimension(:,:) :: flxprec ! Convective-scale flux of precip at interfaces (kg/m2/s) - real(r8), pointer, dimension(:,:) :: flxsnow ! Convective-scale flux of snow at interfaces (kg/m2/s) - real(r8), pointer :: dlf(:,:) ! detrained convective cloud water mixing ratio. - real(r8), pointer :: lambdadpcu(:,:) ! slope of cloud liquid size distr - real(r8), pointer :: mudpcu(:,:) ! width parameter of droplet size distr - real(r8), pointer :: mconzm(:,:) !convective mass fluxes - - real(r8), pointer :: mu(:,:) ! (pcols,pver) - real(r8), pointer :: eu(:,:) ! (pcols,pver) - real(r8), pointer :: du(:,:) ! (pcols,pver) - real(r8), pointer :: md(:,:) ! (pcols,pver) - real(r8), pointer :: ed(:,:) ! (pcols,pver) - real(r8), pointer :: dp(:,:) ! (pcols,pver) - real(r8), pointer :: dsubcld(:) ! (pcols) - integer, pointer :: jt(:) ! (pcols) - integer, pointer :: maxg(:) ! (pcols) - integer, pointer :: ideep(:) ! (pcols) - integer :: lengath - - real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. - real(r8) :: jcbot(pcols) ! o row of base of cloud indices passed out. - - real(r8) :: pcont(pcols), pconb(pcols), freqzm(pcols) - - real(r8) :: lat_all(pcols), long_all(pcols) - - ! history output fields - real(r8) :: cape(pcols) ! w convective available potential energy. - real(r8) :: mu_out(pcols,pver) - real(r8) :: md_out(pcols,pver) - real(r8) :: dif(pcols,pver) - - ! used in momentum transport calculation - real(r8) :: pguallu(pcols, pver) - real(r8) :: pguallv(pcols, pver) - real(r8) :: pgdallu(pcols, pver) - real(r8) :: pgdallv(pcols, pver) - real(r8) :: icwuu(pcols,pver) - real(r8) :: icwuv(pcols,pver) - real(r8) :: icwdu(pcols,pver) - real(r8) :: icwdv(pcols,pver) - real(r8) :: seten(pcols, pver) - logical :: l_windt - real(r8) :: tfinal1, tfinal2 - integer :: ii - - real(r8) :: fice(pcols,pver) - real(r8) :: fsnow_conv(pcols,pver) - - logical :: lq(pcnst) - character(len=16) :: macrop_scheme - character(len=40) :: scheme_name - character(len=40) :: str - integer :: top_lev - - !---------------------------------------------------------------------- - - ! initialize - lchnk = state%lchnk - ncol = state%ncol - nstep = get_nstep() - - ftem = 0._r8 - mu_out(:,:) = 0._r8 - md_out(:,:) = 0._r8 - - call physics_state_copy(state,state1) ! copy state to local state1. - - lq(:) = .FALSE. - lq(1) = .TRUE. - call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr_run', ls=.true., lq=lq)! initialize local ptend type - -! -! Associate pointers with physics buffer fields -! - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, icwmrdp_idx, ql ) - call pbuf_get_field(pbuf, rprddp_idx, rprd ) - call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) - call pbuf_get_field(pbuf, prec_dp_idx, prec ) - call pbuf_get_field(pbuf, snow_dp_idx, snow ) - - call pbuf_get_field(pbuf, zm_mu_idx, mu) - call pbuf_get_field(pbuf, zm_eu_idx, eu) - call pbuf_get_field(pbuf, zm_du_idx, du) - call pbuf_get_field(pbuf, zm_md_idx, md) - call pbuf_get_field(pbuf, zm_ed_idx, ed) - call pbuf_get_field(pbuf, zm_dp_idx, dp) - call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) - 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) - - call pbuf_get_field(pbuf, dlfzm_idx, dlf) - call pbuf_get_field(pbuf, mconzm_idx, mconzm) - -! Begin with Zhang-McFarlane (1996) convection parameterization -! - call t_startf ('zm_convr_run') - -!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - ptend_loc%q(:,:,1) = 0._r8 - ptend_loc%s(:,:) = 0._r8 - dif(:,:) = 0._r8 - mcon(:,:) = 0._r8 - dlf(:,:) = 0._r8 - cme(:,:) = 0._r8 - cape(:) = 0._r8 - zdu(:,:) = 0._r8 - rprd(:,:) = 0._r8 - mu(:,:) = 0._r8 - eu(:,:) = 0._r8 - du(:,:) = 0._r8 - md(:,:) = 0._r8 - ed(:,:) = 0._r8 - dp(:,:) = 0._r8 - dsubcld(:) = 0._r8 - jctop(:) = 0._r8 - jcbot(:) = 0._r8 - prec(:) = 0._r8 - rliq(:) = 0._r8 - rice(:) = 0._r8 - ideep(:) = 0._r8 -!REMOVECAM_END - - - call get_rlat_all_p(lchnk, ncol, lat_all) - call get_rlon_all_p(lchnk, ncol, long_all) - - call zm_convr_run(ncol, pver, & - pverp, gravit, latice, cpwv, cpliq, rh2o, & - lat_all, long_all, & - state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), & - pblh(:ncol), state%zm(:ncol,:), state%phis(:ncol), state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & - ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & - ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), & - tpert(:ncol), dlf(:ncol,:), dif(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & - mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & - dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & - ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & - rice(:ncol), lengath, scheme_name, errmsg, errflg) - - if (errflg /= 0) then - write(str,*) 'From zm_convr_run: at chunk ',lchnk, ' : ' - call endrun(str // errmsg) - end if - - jctop(:) = real(pver,r8) - jcbot(:) = 1._r8 - do i = 1,lengath - jctop(ideep(i)) = real(jt(i), r8) - jcbot(ideep(i)) = real(maxg(i), r8) - end do - - call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output -! -! Output fractional occurance of ZM convection -! - freqzm(:) = 0._r8 - do i = 1,lengath - freqzm(ideep(i)) = 1.0_r8 - end do - call outfld('FREQZM ',freqzm ,pcols ,lchnk ) -! -! Convert mass flux from reported mb/s to kg/m^2/s -! done in convr now - !mcon(:ncol,:pverp) = mcon(:ncol,:pverp) * 100._r8/gravit - mconzm(:ncol,:pverp) = mcon(:ncol,:pverp) - - call outfld('CMFMC_DP', mconzm, pcols, lchnk) - - ! Store upward and downward mass fluxes in un-gathered arrays - ! + convert from mb/s to kg/m^2/s - do i=1,lengath - do k=1,pver - ii = ideep(i) - mu_out(ii,k) = mu(i,k) * 100._r8/gravit - md_out(ii,k) = md(i,k) * 100._r8/gravit - end do - end do - - call outfld('ZMMU', mu_out, pcols, lchnk) - call outfld('ZMMD', md_out, pcols, lchnk) - - ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair - call outfld('ZMDT ',ftem ,pcols ,lchnk ) - call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) - call t_stopf ('zm_convr_run') - - call outfld('DLFZM' ,dlf ,pcols, lchnk) - - pcont(:ncol) = state%ps(:ncol) - pconb(:ncol) = state%ps(:ncol) - do i = 1,lengath - if (maxg(i).gt.jt(i)) then - pcont(ideep(i)) = state%pmid(ideep(i),jt(i)) ! gathered array (or jctop ungathered) - pconb(ideep(i)) = state%pmid(ideep(i),maxg(i))! gathered array - endif - ! write(iulog,*) ' pcont, pconb ', pcont(i), pconb(i), cnt(i), cnb(i) - end do - call outfld('PCONVT ',pcont ,pcols ,lchnk ) - call outfld('PCONVB ',pconb ,pcols ,lchnk ) - - call physics_ptend_init(ptend_all, state%psetcols, 'zm_conv_tend') - - ! add tendency from this process to tendencies from other processes - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - ! update physics state type state1 with ptend_loc - call physics_update(state1, ptend_loc, ztodt) - - ! initialize ptend for next process - lq(:) = .FALSE. - lq(1) = .TRUE. - call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap_run', ls=.true., lq=lq) - - call t_startf ('zm_conv_evap_run') -! -! Determine the phase of the precipitation produced and add latent heat of fusion -! Evaporate some of the precip directly into the environment (Sundqvist) -! Allow this to use the updated state1 and the fresh ptend_loc type -! heating and specific humidity tendencies produced -! - - call pbuf_get_field(pbuf, dp_flxprc_idx, flxprec ) - call pbuf_get_field(pbuf, dp_flxsnw_idx, flxsnow ) -!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - flxprec(:,:) = 0._r8 - flxsnow(:,:) = 0._r8 - snow(:) = 0._r8 - fice(:,:) = 0._r8 - fsnow_conv(:,:) = 0._r8 -!REMOVECAM_END - - top_lev = 1 - call phys_getopts (macrop_scheme_out = macrop_scheme) - !if ( .not. (macrop_scheme == "rk" .or. macrop_scheme == "SPCAM_sam1mom")) top_lev = trop_cloud_top_lev - if ( .not. (macrop_scheme == "rk")) top_lev = trop_cloud_top_lev - - call cloud_fraction_fice_run(ncol, state1%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow_conv(:ncol,:), errmsg, errflg) - - call zm_conv_evap_run(state1%ncol, pver, pverp, & - gravit, latice, latvap, tmelt, & - cpair, zmconv_ke, zmconv_ke_lnd, & - state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & - landfrac(:ncol), & - ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & - rprd(:ncol,:), cld(:ncol,:), ztodt, & - prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), fsnow_conv(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:),& - scheme_name, errmsg, errflg) - - evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) -!+tht - call pbuf_set_field(pbuf, dp_ntprp_idx, ntprprd) - call pbuf_set_field(pbuf, dp_ntsnp_idx, ntsnprd) -!-tht - -! -! Write out variables from zm_conv_evap_run -! - ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair - call outfld('EVAPTZM ',ftem ,pcols ,lchnk ) - ftem(:ncol,:pver) = tend_s_snwprd (:ncol,:pver)/cpair - call outfld('FZSNTZM ',ftem ,pcols ,lchnk ) - ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver)/cpair - call outfld('EVSNTZM ',ftem ,pcols ,lchnk ) - call outfld('EVAPQZM ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) - call outfld('ZMFLXPRC', flxprec, pcols, lchnk) - call outfld('ZMFLXSNW', flxsnow, pcols, lchnk) - call outfld('ZMNTPRPD', ntprprd, pcols, lchnk) - call outfld('ZMNTSNPD', ntsnprd, pcols, lchnk) - call outfld('ZMEIHEAT', ptend_loc%s, pcols, lchnk) - call outfld('CMFMC_DP ',mcon , pcols ,lchnk ) - call outfld('PRECCDZM ',prec, pcols ,lchnk ) - - call t_stopf ('zm_conv_evap_run') - - call outfld('PRECZ ', prec , pcols, lchnk) - - ! add tendency from this process to tend from other processes here - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - ! update physics state type state1 with ptend_loc - call physics_update(state1, ptend_loc, ztodt) - - - ! Momentum Transport - - call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) - - l_windt = .true. -!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - ptend_loc%s(:,:) = 0._r8 - ptend_loc%u(:,:) = 0._r8 - ptend_loc%v(:,:) = 0._r8 -!REMOVECAM_END - - call t_startf ('zm_conv_momtran_run') - - call zm_conv_momtran_run (ncol, pver, pverp, & - l_windt,state1%u(:ncol,:), state1%v(:ncol,:), mu(:ncol,:), md(:ncol,:), & - zmconv_momcu, zmconv_momcd, & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, ptend_loc%u(:ncol,:), ptend_loc%v(:ncol,:),& - pguallu(:ncol,:), pguallv(:ncol,:), pgdallu(:ncol,:), pgdallv(:ncol,:), & - icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:), & - scheme_name, errmsg, errflg) - call t_stopf ('zm_conv_momtran_run') - - ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) - - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - ! Output ptend variables before they are set to zero with physics_update - call outfld('ZMMTU', ptend_loc%u, pcols, lchnk) - call outfld('ZMMTV', ptend_loc%v, pcols, lchnk) - - ! update physics state type state1 with ptend_loc - call physics_update(state1, ptend_loc, ztodt) - - ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair - call outfld('ZMMTT', ftem , pcols, lchnk) - - ! Output apparent force from pressure gradient - call outfld('ZMUPGU', pguallu, pcols, lchnk) - call outfld('ZMUPGD', pgdallu, pcols, lchnk) - call outfld('ZMVPGU', pguallv, pcols, lchnk) - call outfld('ZMVPGD', pgdallv, pcols, lchnk) - - ! Output in-cloud winds - call outfld('ZMICUU', icwuu, pcols, lchnk) - call outfld('ZMICUD', icwdu, pcols, lchnk) - call outfld('ZMICVU', icwuv, pcols, lchnk) - call outfld('ZMICVD', icwdv, pcols, lchnk) - - ! Transport cloud water and ice only - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - lq(:) = .FALSE. - lq(2:) = cnst_is_convtran1(2:) - call physics_ptend_init(ptend_loc, state1%psetcols, 'convtran1', lq=lq) - - - ! dpdry is not used in this call to convtran since the cloud liquid and ice mixing - ! ratios are moist - fake_dpdry(:,:) = 0._r8 - - call t_startf ('convtran1') - -!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - ptend_loc%q(:,:,:) = 0._r8 -!REMOVECAM_END - - call zm_conv_convtran_run (ncol, pver, & - ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ccpp_const_props, & - scheme_name, errmsg, errflg) - call t_stopf ('convtran1') - - call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) - call outfld('ZMDLIQ ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk ) - - ! add tendency from this process to tend from other processes here - call physics_ptend_sum(ptend_loc,ptend_all, ncol) - - call physics_state_dealloc(state1) - call physics_ptend_dealloc(ptend_loc) - - - -end subroutine zm_conv_tend -!========================================================================================= - - -subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) - - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use time_manager, only: get_nstep - use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc - use constituents, only: pcnst, cnst_is_convtran2 - use ccpp_constituent_prop_mod, only: ccpp_const_props - - -! Arguments - type(physics_state), intent(in ) :: state ! Physics state variables - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - -! Local variables - integer :: i, lchnk, istat - integer :: lengath ! number of columns with deep convection - integer :: nstep - integer :: ncol - - real(r8), dimension(pcols,pver) :: dpdry - - ! physics buffer fields - real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - real(r8), pointer :: mu(:,:) ! (pcols,pver) - real(r8), pointer :: eu(:,:) ! (pcols,pver) - real(r8), pointer :: du(:,:) ! (pcols,pver) - real(r8), pointer :: md(:,:) ! (pcols,pver) - real(r8), pointer :: ed(:,:) ! (pcols,pver) - real(r8), pointer :: dp(:,:) ! (pcols,pver) - real(r8), pointer :: dsubcld(:) ! (pcols) - integer, pointer :: jt(:) ! (pcols) - integer, pointer :: maxg(:) ! (pcols) - integer, pointer :: ideep(:) ! (pcols) - - character(len=40) :: scheme_name - character(len=512) :: errmsg - integer :: errflg - - !----------------------------------------------------------------------------------- - - - call physics_ptend_init(ptend, state%psetcols, 'convtran2', lq=cnst_is_convtran2 ) - - call pbuf_get_field(pbuf, fracis_idx, fracis) - call pbuf_get_field(pbuf, zm_mu_idx, mu) - call pbuf_get_field(pbuf, zm_eu_idx, eu) - call pbuf_get_field(pbuf, zm_du_idx, du) - call pbuf_get_field(pbuf, zm_md_idx, md) - call pbuf_get_field(pbuf, zm_ed_idx, ed) - call pbuf_get_field(pbuf, zm_dp_idx, dp) - call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) - 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) - - - lchnk = state%lchnk - ncol = state%ncol - nstep = get_nstep() - - lengath = count(ideep > 0) - if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake - - if (any(ptend%lq(:))) then - ! initialize dpdry for call to convtran - ! it 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 t_startf ('convtran2') - -!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - ptend%q(:,:,:) = 0._r8 -!REMOVECAM_END - - call zm_conv_convtran_run (ncol, pver, & - ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ccpp_const_props, & - scheme_name, errmsg, errflg) - - if (errflg /= 0) then - call endrun('From zm_conv_convtran_run:' // errmsg) - end if - - call t_stopf ('convtran2') - end if - -end subroutine zm_conv_tend_2 - -!========================================================================================= - - -end module zm_conv_intr diff --git a/src/physics/camnor_phys/physics/zm_convr.F90 b/src/physics/camnor_phys/physics/zm_convr.F90 deleted file mode 100644 index 125e1f4c5a..0000000000 --- a/src/physics/camnor_phys/physics/zm_convr.F90 +++ /dev/null @@ -1,3138 +0,0 @@ -module zm_convr - - use ccpp_kinds, only: kind_phys -!+tht - use physconst, only: cpvir, zvir -!-tht - - implicit none - - save - private ! Make default type private to the module -! -! PUBLIC: interfaces -! - public zm_convr_init ! ZM schemea - public zm_convr_run ! ZM schemea - - real(kind_phys) rl ! wg latent heat of vaporization. - real(kind_phys) cpres ! specific heat at constant pressure in j/kg-degk. - real(kind_phys) :: capelmt ! namelist configurable: - ! threshold value for cape for deep convection. - real(kind_phys) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke - real(kind_phys) :: ke_lnd - real(kind_phys) :: c0_lnd ! set from namelist input zmconv_c0_lnd - real(kind_phys) :: c0_ocn ! set from namelist input zmconv_c0_ocn - integer :: num_cin ! set from namelist input zmconv_num_cin - ! The number of negative buoyancy regions that are allowed - ! before the convection top and CAPE calculations are completed. - real(kind_phys) tau ! convective time scale - real(kind_phys) :: tfreez - real(kind_phys) :: eps1 - real(kind_phys) :: momcu - real(kind_phys) :: momcd - - logical :: no_deep_pbl ! default = .false. - ! no_deep_pbl = .true. eliminates deep convection entirely within PBL - - - real(kind_phys) :: rgrav ! reciprocal of grav - real(kind_phys) :: rgas ! gas constant for dry air - real(kind_phys) :: grav ! = gravit - real(kind_phys) :: cp ! = cpres = cpair - - integer limcnv ! top interface level limit for convection - - logical :: lparcel_pbl ! Switch to turn on mixing of parcel MSE air, and picking launch level to be the top of the PBL. - real(kind_phys) :: parcel_hscale - - real(kind_phys) :: tiedke_add ! namelist configurable - real(kind_phys) :: dmpdz_param ! namelist configurable - - real(kind_phys) :: dcol, zv, cpv ! tht_thermo - -!+tht - ! added parameters - logical :: retrigger =.true. & !+tht iterate parcel-plume calculation and trigger condition - ,tht_thermo =.true. !+tht latent heat of freezing added in plume ensemble - real(kind_phys) :: & - tiedke_lnd = 1.0_kind_phys & - ! previously undeclared parameters: - ,entrmn = 2e-4_kind_phys & !+tht maximum convective entrainment rate - ,alfadet = 0.1_kind_phys & !+tht convective detrainment/entrainment ratio - ,plclmin = 6.e2_kind_phys !+tht don't convect if LCL above this level (p \section arg_table_zm_convr_init Argument Table -!! \htmlinclude zm_convr_init.html -!! -subroutine zm_convr_init(plev, plevp, cpair, cpliq, cpwv, epsilo, gravit, latvap, tmelt, rair, & - pref_edge, zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, zmconv_num_cin, & - no_deep_pbl_in, zmconv_tiedke_add, & -!+tht - zmconv_tiedke_lnd,& - zmconv_entrmn ,& - zmconv_alfadet ,& - zmconv_plclmin ,& - zmconv_tht_thermo,& - zmconv_retrigger ,& -!-tht - zmconv_capelmt, zmconv_dmpdz, & - zmconv_parcel_pbl, zmconv_parcel_hscale, zmconv_tau, & - masterproc, iulog, errmsg, errflg) - - integer, intent(in) :: plev - integer, intent(in) :: plevp - - real(kind_phys), intent(in) :: cpair,cpliq,cpwv! specific heats (J K-1 kg-1) - real(kind_phys), intent(in) :: epsilo ! ratio of h2o to dry air molecular weights - real(kind_phys), intent(in) :: gravit ! gravitational acceleration (m s-2) - real(kind_phys), intent(in) :: latvap ! Latent heat of vaporization (J kg-1) - real(kind_phys), intent(in) :: tmelt ! Freezing point of water (K) - real(kind_phys), intent(in) :: rair ! Dry air gas constant (J K-1 kg-1) - real(kind_phys), intent(in) :: pref_edge(:) ! reference pressures at interfaces - integer, intent(in) :: zmconv_num_cin ! Number negative buoyancy regions that are allowed - ! before the convection top and CAPE calculations are completed. - real(kind_phys),intent(in) :: zmconv_c0_lnd - real(kind_phys),intent(in) :: zmconv_c0_ocn - real(kind_phys),intent(in) :: zmconv_ke - real(kind_phys),intent(in) :: zmconv_ke_lnd - real(kind_phys),intent(in) :: zmconv_momcu - real(kind_phys),intent(in) :: zmconv_momcd - logical ,intent(in) :: no_deep_pbl_in ! no_deep_pbl = .true. eliminates ZM convection entirely within PBL - real(kind_phys),intent(in) :: zmconv_tiedke_add - real(kind_phys),intent(in) :: zmconv_capelmt - real(kind_phys),intent(in) :: zmconv_dmpdz - logical ,intent(in) :: zmconv_parcel_pbl ! Should the parcel properties include PBL mixing? - real(kind_phys),intent(in) :: zmconv_parcel_hscale ! Fraction of PBL over which to mix ZM parcel. - real(kind_phys),intent(in) :: zmconv_tau -!+tht - real(kind_phys),intent(in) :: zmconv_tiedke_lnd - real(kind_phys),intent(in) :: zmconv_entrmn - real(kind_phys),intent(in) :: zmconv_alfadet - real(kind_phys),intent(in) :: zmconv_plclmin - logical ,intent(in) :: zmconv_tht_thermo - logical ,intent(in) :: zmconv_retrigger -!-tht - logical, intent(in) :: masterproc - integer, intent(in) :: iulog - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: k - - errmsg ='' - errflg = 0 - - ! Initialization of ZM constants - tfreez = tmelt - eps1 = epsilo - rl = latvap - cpres = cpair - rgrav = 1.0_kind_phys/gravit - rgas = rair - grav = gravit - cp = cpres - - c0_lnd = zmconv_c0_lnd - c0_ocn = zmconv_c0_ocn - num_cin = zmconv_num_cin - ke = zmconv_ke - ke_lnd = zmconv_ke_lnd - momcu = zmconv_momcu - momcd = zmconv_momcd - - tiedke_add = zmconv_tiedke_add - capelmt = zmconv_capelmt - dmpdz_param = zmconv_dmpdz - no_deep_pbl = no_deep_pbl_in - lparcel_pbl = zmconv_parcel_pbl - parcel_hscale = zmconv_parcel_hscale -!+tht - ! added parameters - tht_thermo = zmconv_tht_thermo - retrigger = zmconv_retrigger - ! previously undeclared parameters - entrmn = zmconv_entrmn - alfadet = zmconv_alfadet - plclmin = zmconv_plclmin - ! implied parameters - second_call= retrigger - tht_tweaks = (retrigger.or.tht_thermo) - ! set tiedke_lnd but ensure regression to standard ZM - if(tht_tweaks) then - tiedke_lnd = zmconv_tiedke_lnd - else - tiedke_lnd = tiedke_add - endif - ! auxiliary vars - if(tht_thermo) then - dcol=(cpliq-cpwv)/latvap - zv=zvir - cpv=cpvir - else - dcol=0._kind_phys - zv =0._kind_phys - cpv =0._kind_phys - endif -!-tht - - tau = zmconv_tau - - ! - ! Limit deep convection to regions below 40 mb - ! Note this calculation is repeated in the shallow convection interface - ! - limcnv = 0 ! null value to check against below - if (pref_edge(1) >= 4.e3_kind_phys) then - limcnv = 1 - else - do k=1,plev - if (pref_edge(k) < 4.e3_kind_phys .and. pref_edge(k+1) >= 4.e3_kind_phys) then - limcnv = k - exit - end if - end do - if ( limcnv == 0 ) limcnv = plevp - end if - - if ( masterproc ) then - write(iulog,*)'ZM_CONVR_INIT' - write(iulog,*)'tht algorithmic mods:' - !write(iulog,*) ' (tht) Apply CIN threshold condition to allow convect.: use_cin ',use_cin - write(iulog,*) ' (tht) Conservatively mix plume enthalpy not entropy : tht_tweaks ',tht_tweaks - write(iulog,*) ' (tht) Account for freezing in plume-ensemble buoyancy: tht_thermo ',tht_thermo - write(iulog,*) ' (tht) Iterate CAPE calculation using diagnosed entrnm: second_call',second_call - write(iulog,*) ' (tht) Retrigger ZM convection using diagnosed entrnm : retrigger ',retrigger - ! if (.not.tht_tweaks .and. (second_call.or.retrigger.or.tht_thermo)) & - !call endrun('**** ZM_CONVI : tht_tweaks must be T in order to use any other tht mods ****') - write(iulog,*)'Standard tuning parameters:' - write(iulog,*) ' zm_convr_init: tau',tau - write(iulog,*) ' zm_convr_init: c0_lnd',c0_lnd,' , c0_ocn', c0_ocn - write(iulog,*) ' zm_convr_init: num_cin', num_cin - write(iulog,*) ' zm_convr_init: ke',ke,' , ke_lnd', ke_lnd - write(iulog,*) ' zm_convr_init: no_deep_pbl',no_deep_pbl - write(iulog,*) ' zm_convr_init: zm_capelmt', capelmt - write(iulog,*) ' zm_convr_init: zm_tiedke_add', tiedke_add - write(iulog,*) ' zm_convr_init: zm_parcel_pbl', lparcel_pbl - if(.not.tht_tweaks) & - write(iulog,*)' zm_convr_init: zm_dmpdz', dmpdz_param - if( tht_tweaks) & - write(iulog,*)' (tht) Entrainment rate in initial test plume for CAPE:-dmpdz_param',-dmpdz_param - write(iulog,*)'Hard-wired parameters:' - write(iulog,*) ' convection capping: level ',limcnv,' at ',pref_edge(limcnv)/100.,' hPa' - write(iulog,*) ' Minimum pressure of LCL allowed : plclmin ',plclmin - write(iulog,*) ' Maximum entrainment rate in convective ensemble: entrmn ',entrmn - write(iulog,*) ' Detrainment/entrainment ratio in convect. ens. : alfadet ',alfadet - write(iulog,*) ' (tht) Tiedke parameter over land : tiedke_lnd ',tiedke_lnd - ! if (use_cin) & - !write(iulog,*) ' (tht) Maximum allowed CIN as a fraction of CAPE : cin_threshd',cin_threshd - write(iulog,*)'**** ZM: DILUTE Buoyancy Calculation ****' - endif - -end subroutine zm_convr_init - - -!=============================================================================== -!> \section arg_table_zm_convr_run Argument Table -!! \htmlinclude zm_convr_run.html -!! -subroutine zm_convr_run( ncol ,pver , & - pverp, gravit ,latice ,cpwv ,cpliq , rh2o, & - lat, long, & - t ,qh ,prec , & - pblh ,zm ,geos ,zi ,qtnd , & - heat ,pap ,paph ,dpp , & - delt ,mcon ,cme ,cape ,eurt , & - tpert ,dlf ,dif ,zdu ,rprd , & - mu ,md ,du ,eu ,ed , & - dp ,dsubcld ,jt ,maxg ,ideep , & - ql ,rliq ,landfrac, & - rice ,lengath ,scheme_name, errmsg ,errflg) -!----------------------------------------------------------------------- -! -! Purpose: -! Main driver for zhang-mcfarlane convection scheme -! -! Method: -! performs deep convective adjustment based on mass-flux closure -! algorithm. -! -! Author:guang jun zhang, m.lazare, n.mcfarlane. CAM Contact: P. Rasch -! -! This is contributed code not fully standardized by the CAM core group. -! All variables have been typed, where most are identified in comments -! The current procedure will be reimplemented in a subsequent version -! of the CAM where it will include a more straightforward formulation -! and will make use of the standard CAM nomenclature -! -!----------------------------------------------------------------------- -! -! ************************ index of variables ********************** -! -! wg * alpha array of vertical differencing used (=1. for upstream). -! w * cape convective available potential energy. -! wg * capeg gathered convective available potential energy. -! c * capelmt threshold value for cape for deep convection. -! ic * cpres specific heat at constant pressure in j/kg-degk. -! i * dpp -! ic * delt length of model time-step in seconds. -! wg * dp layer thickness in mbs (between upper/lower interface). -! wg * dqdt mixing ratio tendency at gathered points. -! wg * dsdt dry static energy ("temp") tendency at gathered points. -! wg * dudt u-wind tendency at gathered points. -! wg * dvdt v-wind tendency at gathered points. -! wg * dsubcld layer thickness in mbs between lcl and maxi. -! ic * grav acceleration due to gravity in m/sec2. -! wg * du detrainment in updraft. specified in mid-layer -! wg * ed entrainment in downdraft. -! wg * eu entrainment in updraft. -! wg * hmn moist static energy. -! wg * hsat saturated moist static energy. -! w * ideep holds position of gathered points vs longitude index. -! ic * pver number of model levels. -! wg * j0 detrainment initiation level index. -! wg * jd downdraft initiation level index. -! ic * jlatpr gaussian latitude index for printing grids (if needed). -! wg * jt top level index of deep cumulus convection. -! w * lcl base level index of deep cumulus convection. -! wg * lclg gathered values of lcl. -! w * lel index of highest theoretical convective plume. -! wg * lelg gathered values of lel. -! w * lon index of onset level for deep convection. -! w * maxi index of level with largest moist static energy. -! wg * maxg gathered values of maxi. -! wg * mb cloud base mass flux. -! wg * mc net upward (scaled by mb) cloud mass flux. -! wg * md downward cloud mass flux (positive up). -! wg * mu upward cloud mass flux (positive up). specified -! at interface -! ic * msg number of missing moisture levels at the top of model. -! w * p grid slice of ambient mid-layer pressure in mbs. -! i * pblt row of pbl top indices. -! w * pcpdh scaled surface pressure. -! w * pf grid slice of ambient interface pressure in mbs. -! wg * pg grid slice of gathered values of p. -! w * q grid slice of mixing ratio. -! wg * qd grid slice of mixing ratio in downdraft. -! wg * qg grid slice of gathered values of q. -! i/o * qh grid slice of specific humidity. -! w * qh0 grid slice of initial specific humidity. -! wg * qhat grid slice of upper interface mixing ratio. -! wg * ql grid slice of cloud liquid water. -! wg * qs grid slice of saturation mixing ratio. -! w * qstp grid slice of parcel temp. saturation mixing ratio. -! wg * qstpg grid slice of gathered values of qstp. -! wg * qu grid slice of mixing ratio in updraft. -! ic * rgas dry air gas constant. -! wg * rl latent heat of vaporization. -! w * s grid slice of scaled dry static energy (t+gz/cp). -! wg * sd grid slice of dry static energy in downdraft. -! wg * sg grid slice of gathered values of s. -! wg * shat grid slice of upper interface dry static energy. -! wg * su grid slice of dry static energy in updraft. -! i/o * t -! wg * tg grid slice of gathered values of t. -! w * tl row of parcel temperature at lcl. -! wg * tlg grid slice of gathered values of tl. -! w * tp grid slice of parcel temperatures. -! wg * tpg grid slice of gathered values of tp. -! i/o * u grid slice of u-wind (real). -! wg * ug grid slice of gathered values of u. -! i/o * utg grid slice of u-wind tendency (real). -! i/o * v grid slice of v-wind (real). -! w * va work array re-used by called subroutines. -! wg * vg grid slice of gathered values of v. -! i/o * vtg grid slice of v-wind tendency (real). -! i * w grid slice of diagnosed large-scale vertical velocity. -! w * z grid slice of ambient mid-layer height in metres. -! w * zf grid slice of ambient interface height in metres. -! wg * zfg grid slice of gathered values of zf. -! wg * zg grid slice of gathered values of z. -! -!----------------------------------------------------------------------- -! -! multi-level i/o fields: -! i => input arrays. -! i/o => input/output arrays. -! w => work arrays. -! wg => work arrays operating only on gathered points. -! ic => input data constants. -! c => data constants pertaining to subroutine itself. -! -! input arguments -! - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: pver, pverp - - real(kind_phys), intent(in) :: gravit ! gravitational acceleration (m s-2) - real(kind_phys), intent(in) :: latice ! Latent heat of fusion (J kg-1) - real(kind_phys), intent(in) :: cpwv ! specific heat of water vapor (J K-1 kg-1) - real(kind_phys), intent(in) :: cpliq ! specific heat of fresh h2o (J K-1 kg-1) - real(kind_phys), intent(in) :: rh2o ! Water vapor gas constant (J K-1 kg-1) - - real(kind_phys), intent(in) :: lat(:) - real(kind_phys), intent(in) :: long(:) - - real(kind_phys), intent(in) :: t(:,:) ! grid slice of temperature at mid-layer. (ncol,pver) - real(kind_phys), intent(in) :: qh(:,:) ! grid slice of specific humidity. (ncol,pver) - real(kind_phys), intent(in) :: pap(:,:) ! (ncol,pver) - real(kind_phys), intent(in) :: paph(:,:) ! (ncol,pver+1) - real(kind_phys), intent(in) :: dpp(:,:) ! local sigma half-level thickness (i.e. dshj). (ncol,pver) - real(kind_phys), intent(in) :: zm(:,:) ! (ncol,pver) - real(kind_phys), intent(in) :: geos(:) ! (ncol) - real(kind_phys), intent(in) :: zi(:,:) ! (ncol,pver+1) - real(kind_phys), intent(in) :: pblh(:) ! (ncol) - real(kind_phys), intent(in) :: tpert(:) ! (ncol) - real(kind_phys), intent(in) :: landfrac(:) ! RBN Landfrac (ncol) - -! output arguments -! - real(kind_phys), intent(out) :: qtnd(:,:) ! specific humidity tendency (kg/kg/s) (ncol,pver) - real(kind_phys), intent(out) :: heat(:,:) ! heating rate (dry static energy tendency, W/kg) (ncol,pver) - real(kind_phys), intent(out) :: mcon(:,:) ! (ncol,pverp) - real(kind_phys), intent(out) :: dif(:,:) - real(kind_phys), intent(out) :: dlf(:,:) ! scattrd version of the detraining cld h2o tend (ncol,pver) - real(kind_phys), intent(out) :: cme(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: cape(:) ! w convective available potential energy. (ncol) - real(kind_phys), intent(out) :: zdu(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: rprd(:,:) ! rain production rate (ncol,pver) - -! move these vars from local storage to output so that convective -! transports can be done in outside of conv_cam. - real(kind_phys), intent(out) :: mu(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: eu(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: eurt(:,:)! (ncol,pver) - real(kind_phys), intent(out) :: du(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: md(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: ed(:,:) ! (ncol,pver) - real(kind_phys), intent(out) :: dp(:,:) ! wg layer thickness in mbs (between upper/lower interface). (ncol,pver) - real(kind_phys), intent(out) :: dsubcld(:) ! wg layer thickness in mbs between lcl and maxi. (ncol) - real(kind_phys), intent(out) :: prec(:) ! (ncol) - real(kind_phys), intent(out) :: rliq(:) ! reserved liquid (not yet in cldliq) for energy integrals (ncol) - real(kind_phys), intent(out) :: rice(:) ! reserved ice (not yet in cldce) for energy integrals (ncol) - - integer, intent(out) :: ideep(:) ! column indices of gathered points (ncol) - - integer, intent(out) :: jt(:) ! wg top level index of deep cumulus convection. - integer, intent(out) :: maxg(:)! wg gathered values of maxi. - - integer, intent(out) :: lengath - - real(kind_phys),intent(out):: ql(:,:) ! wg grid slice of cloud liquid water. - - character(len=40), intent(out) :: scheme_name - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - - ! Local variables - - - real(kind_phys) zs(ncol) - real(kind_phys) dlg(ncol,pver) ! gathrd version of the detraining cld h2o tend - real(kind_phys) cug(ncol,pver) ! gathered condensation rate - - real(kind_phys) evpg(ncol,pver) ! gathered evap rate of rain in downdraft - real(kind_phys) dptot(ncol) - - real(kind_phys) mumax(ncol) - real(kind_phys) pblt(ncol) ! i row of pbl top indices. - -!----------------------------------------------------------------------- -! -! general work fields (local variables): -! - real(kind_phys) q(ncol,pver) ! w grid slice of mixing ratio. - real(kind_phys) p(ncol,pver) ! w grid slice of ambient mid-layer pressure in mbs. - real(kind_phys) z(ncol,pver) ! w grid slice of ambient mid-layer height in metres. - real(kind_phys) s(ncol,pver) ! w grid slice of scaled dry static energy (t+gz/cp). - real(kind_phys) tp(ncol,pver) ! w grid slice of parcel temperatures. - real(kind_phys) zf(ncol,pver+1) ! w grid slice of ambient interface height in metres. - real(kind_phys) pf(ncol,pver+1) ! w grid slice of ambient interface pressure in mbs. - real(kind_phys) qstp(ncol,pver) ! w grid slice of parcel temp. saturation mixing ratio. - - real(kind_phys) tl(ncol) ! w row of parcel temperature at lcl. - - integer lcl(ncol) ! w base level index of deep cumulus convection. - integer lel(ncol) ! w index of highest theoretical convective plume. - integer lon(ncol) ! w index of onset level for deep convection. - integer maxi(ncol) ! w index of level with largest moist static energy. - - real(kind_phys) precip -! -! gathered work fields: -! - real(kind_phys) qg(ncol,pver) ! wg grid slice of gathered values of q. - real(kind_phys) tg(ncol,pver) ! w grid slice of temperature at interface. - real(kind_phys) pg(ncol,pver) ! wg grid slice of gathered values of p. - real(kind_phys) zg(ncol,pver) ! wg grid slice of gathered values of z. - real(kind_phys) sg(ncol,pver) ! wg grid slice of gathered values of s. - real(kind_phys) tpg(ncol,pver) ! wg grid slice of gathered values of tp. - real(kind_phys) zfg(ncol,pver+1) ! wg grid slice of gathered values of zf. - real(kind_phys) qstpg(ncol,pver) ! wg grid slice of gathered values of qstp. - real(kind_phys) ug(ncol,pver) ! wg grid slice of gathered values of u. - real(kind_phys) vg(ncol,pver) ! wg grid slice of gathered values of v. - real(kind_phys) cmeg(ncol,pver) - - real(kind_phys) rprdg(ncol,pver) ! wg gathered rain production rate - real(kind_phys) capeg(ncol) ! wg gathered convective available potential energy. - real(kind_phys) tlg(ncol) ! wg grid slice of gathered values of tl. - real(kind_phys) landfracg(ncol) ! wg grid slice of landfrac - - integer lclg(ncol) ! wg gathered values of lcl. - integer lelg(ncol) - - integer indxd(ncol) !+tht work array - -! -! work fields arising from gathered calculations. -! - real(kind_phys) dqdt(ncol,pver) ! wg mixing ratio tendency at gathered points. - real(kind_phys) dsdt(ncol,pver) ! wg dry static energy ("temp") tendency at gathered points. - real(kind_phys) sd(ncol,pver) ! wg grid slice of dry static energy in downdraft. - real(kind_phys) qd(ncol,pver) ! wg grid slice of mixing ratio in downdraft. - real(kind_phys) mc(ncol,pver) ! wg net upward (scaled by mb) cloud mass flux. - real(kind_phys) qhat(ncol,pver) ! wg grid slice of upper interface mixing ratio. - real(kind_phys) qu(ncol,pver) ! wg grid slice of mixing ratio in updraft. - real(kind_phys) su(ncol,pver) ! wg grid slice of dry static energy in updraft. - real(kind_phys) qs(ncol,pver) ! wg grid slice of saturation mixing ratio. - real(kind_phys) shat(ncol,pver) ! wg grid slice of upper interface dry static energy. - real(kind_phys) hmn(ncol,pver) ! wg moist static energy. - real(kind_phys) hsat(ncol,pver) ! wg saturated moist static energy. - real(kind_phys) qlg(ncol,pver) - real(kind_phys) dudt(ncol,pver) ! wg u-wind tendency at gathered points. - real(kind_phys) dvdt(ncol,pver) ! wg v-wind tendency at gathered points. - - real(kind_phys) dmpdz(ncol,pver) !+tht Parcel fractional mass entrainment rate (/m) - - real(kind_phys) qldeg(ncol,pver) ! cloud liquid water mixing ratio for detrainment (kg/kg) - real(kind_phys) mb(ncol) ! wg cloud base mass flux. - - integer jlcl(ncol) - integer j0(ncol) ! wg detrainment initiation level index. - integer jd(ncol) ! wg downdraft initiation level index. - - real(kind_phys),intent(in):: delt ! length of model time-step in seconds. - - integer i - integer ii - integer k, kk, l, m - - integer msg ! ic number of missing moisture levels at the top of model. - real(kind_phys) qdifr - real(kind_phys) sdifr - - real(kind_phys) hk, dmsm(ncol) !+tht for diagnostic entrainment - - real(kind_phys), parameter :: dcon = 25.e-6_kind_phys - real(kind_phys), parameter :: mucon = 5.3_kind_phys - real(kind_phys) negadq - logical doliq - - -! -!--------------------------Data statements------------------------------ - - scheme_name = "zm_convr_run" - errmsg = '' - errflg = 0 -! -! Set internal variable "msg" (convection limit) to "limcnv-1" -! - msg = limcnv - 1 -! -! initialize necessary arrays. -! zero out variables not used in cam - - dmpdz(:,:)=dmpdz_param !+tht initialise value for entrainment rate - - qtnd(:,:) = 0._kind_phys - heat(:,:) = 0._kind_phys - mcon(:,:) = 0._kind_phys - rliq(:ncol) = 0._kind_phys - rice(:ncol) = 0._kind_phys - -! -! initialize convective tendencies -! - prec(:ncol) = 0._kind_phys - do k = 1,pver - do i = 1,ncol - dqdt(i,k) = 0._kind_phys - dsdt(i,k) = 0._kind_phys - dudt(i,k) = 0._kind_phys - dvdt(i,k) = 0._kind_phys - cme(i,k) = 0._kind_phys - rprd(i,k) = 0._kind_phys - zdu(i,k) = 0._kind_phys - ql(i,k) = 0._kind_phys - qlg(i,k) = 0._kind_phys - dlf(i,k) = 0._kind_phys - dlg(i,k) = 0._kind_phys - qldeg(i,k) = 0._kind_phys - eurt(i,k) = 0._kind_phys !+tht entr.rate (full) - dif(i,k) = 0._kind_phys - end do - end do - - do i = 1,ncol - pblt(i) = pver - dsubcld(i) = 0._kind_phys - end do - -! -! calculate local pressure (mbs) and height (m) for both interface -! and mid-layer locations. -! - do i = 1,ncol - zs(i) = geos(i)*rgrav - pf(i,pver+1) = paph(i,pver+1)*0.01_kind_phys - zf(i,pver+1) = zi(i,pver+1) + zs(i) - end do - do k = 1,pver - do i = 1,ncol - p(i,k) = pap(i,k)*0.01_kind_phys - pf(i,k) = paph(i,k)*0.01_kind_phys - z(i,k) = zm(i,k) + zs(i) - zf(i,k) = zi(i,k) + zs(i) - end do - end do - - do k = pver - 1,msg + 1,-1 - do i = 1,ncol - if (abs(z(i,k)-zs(i)-pblh(i)) < (zf(i,k)-zf(i,k+1))*0.5_kind_phys) pblt(i) = k - end do - end do -! -! store incoming specific humidity field for subsequent calculation -! of precipitation (through change in storage). -! define dry static energy (normalized by cp). -! - do k = 1,pver - do i = 1,ncol - q(i,k) = qh(i,k) -!+tht moist thermo - s(i,k) = t(i,k) + (grav/((1._kind_phys+zv*q(i,k))*cpres))*z(i,k) -!-tht - tp(i,k)=0.0_kind_phys - shat(i,k) = s(i,k) - qhat(i,k) = q(i,k) - end do - end do - - do i = 1,ncol - capeg(i) = 0._kind_phys - lclg(i) = 1 - lelg(i) = pver - maxg(i) = 1 - tlg(i) = 400._kind_phys - dsubcld(i) = 0._kind_phys - end do - - - ! Evaluate Tparcel, qs(Tparcel), buoyancy and CAPE, - ! lcl, lel, parcel launch level at index maxi()=hmax - - call buoyan_dilute(ncol ,pver , & - cpliq ,latice ,cpwv ,rh2o ,& - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & !tht - pblt ,lcl ,lel ,lon ,maxi , & - rgas ,grav ,cpres ,msg , & - zi ,zs ,tpert ,landfrac,dmpdz, & !tht - lat ,long ,errmsg ,errflg) - -! -! determine whether grid points will undergo some deep convection -! (ideep=1) or not (ideep=0), based on values of cape,lcl,lel -! (require cape.gt. 0 and lel capelmt) then - !if (.not.use_cin .or. cin(i).lt.cape(i)*cin_threshd) then !+tht: disabled - lengath = lengath + 1 - ideep(lengath) = i - indxd(lengath) = i !+tht sub-index - !endif - end if - end do - -! do ii=1,lengath -! i=indxd(ii) -! ideep(ii)=i !+tht keeping ideep and indxd distinguished for possible different use of CIN -! end do - - if (lengath.eq.0) return -! -! obtain gathered arrays necessary for ensuing calculations. -! - do k = 1,pver - do i = 1,lengath - dp(i,k) = 0.01_kind_phys*dpp(ideep(i),k) - qg(i,k) = q(ideep(i),k) - tg(i,k) = t(ideep(i),k) - pg(i,k) = p(ideep(i),k) - zg(i,k) = z(ideep(i),k) - sg(i,k) = s(ideep(i),k) - tpg(i,k) = tp(ideep(i),k) - zfg(i,k) = zf(ideep(i),k) - qstpg(i,k) = qstp(ideep(i),k) - ug(i,k) = 0._kind_phys - vg(i,k) = 0._kind_phys - end do - end do - -! - do i = 1,lengath - zfg(i,pver+1) = zf(ideep(i),pver+1) - end do - do i = 1,lengath - capeg(i) = cape(ideep(i)) - lclg(i) = lcl(ideep(i)) - lelg(i) = lel(ideep(i)) - maxg(i) = maxi(ideep(i)) - tlg(i) = tl(ideep(i)) - landfracg(i) = landfrac(ideep(i)) - end do -! -! calculate sub-cloud layer pressure "thickness" for use in -! closure and tendency routines. -! - do k = msg + 1,pver - do i = 1,lengath - if (k >= maxg(i)) then - dsubcld(i) = dsubcld(i) + dp(i,k) - end if - end do - end do -! -! define array of factors (alpha) which defines interfacial -! values, as well as interfacial values for (q,s) used in -! subsequent routines. -! - do k = msg + 2,pver - do i = 1,lengath - sdifr = 0._kind_phys - qdifr = 0._kind_phys - if (sg(i,k) > 0._kind_phys .or. sg(i,k-1) > 0._kind_phys) & - sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) - if (qg(i,k) > 0._kind_phys .or. qg(i,k-1) > 0._kind_phys) & - qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) - if (sdifr > 1.E-6_kind_phys) then - shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) - else - shat(i,k) = 0.5_kind_phys* (sg(i,k)+sg(i,k-1)) - end if - if (qdifr > 1.E-6_kind_phys) then - qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) - else - qhat(i,k) = 0.5_kind_phys* (qg(i,k)+qg(i,k-1)) - end if - end do - end do -! -! obtain cloud properties. -! - - call cldprp(ncol ,pver ,pverp ,cpliq , & - latice ,cpwv ,rh2o ,& - qg ,tg ,ug ,vg ,pg , & - zg ,sg ,mu ,eu ,du , & - md ,ed ,sd ,qd ,mc , & - qu ,su ,zfg ,qs ,hmn , & - hsat ,shat ,qlg , & - cmeg ,maxg ,lelg ,jt ,jlcl , & - maxg ,j0 ,jd ,rl ,lengath , & - rgas ,grav ,cpres ,msg , & - evpg ,cug ,rprdg ,limcnv ,landfracg , & - qldeg ,qhat ) - -!=================================================================================== -!!++tht second call to buoyan_dilute for new CAPE using entrainment rate from CLDPRP - if (second_call) then - - do i = 1,lengath - hk=0._kind_phys - dmpdz(ideep(i),:) = 1._kind_phys ! large value 3D - dmsm(i)=0._kind_phys - do k = pver,msg+1,-1 - if (eu(i,k).gt.0_kind_phys) then - dmsm(i) = dmsm(i)-eu(i,k) - hk=hk+1._kind_phys - endif - enddo - if (hk.gt.0) then - dmsm(i) = dmsm(i)/hk - dmpdz(ideep(i),:) = dmsm(i) - endif - enddo - - call buoyan_dilute(ncol ,pver , & - cpliq ,latice ,cpwv ,rh2o ,& - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & - pblt ,lcl ,lel ,lon ,maxi , & - rgas ,grav ,cpres ,msg , & - zi ,zs ,tpert ,landfrac,dmpdz, & !tht - lat ,long ,errmsg ,errflg) - - !------------------------------------------------------------------------------- - !+tht: retrigger? - if (retrigger) then - lengath = 0 - ideep(:)= 0 - indxd(:)= 0 - do i=1,ncol - if (cape(i) > capelmt) then - !if (.not.use_cin .or. cin(i).lt.cape(i)*cin_threshd) then !+tht: disabled - lengath = lengath + 1 - indxd(lengath) = i !+tht sub-index - !endif - end if - end do - if (lengath.eq.0) return - do ii=1,lengath - i=indxd(ii) - ideep(ii)=i !+tht keeping ideep and indxd distinguished for possible different use of CIN - end do - !---- - ! shorten all gathered arrays to new triggered subset - do k = 1,pver - do i = 1,lengath - dp(i,k) = 0.01_kind_phys*dpp(ideep(i),k) - qg(i,k) = q(ideep(i),k) - tg(i,k) = t(ideep(i),k) - pg(i,k) = p(ideep(i),k) - zg(i,k) = z(ideep(i),k) - sg(i,k) = s(ideep(i),k) - tpg(i,k) = tp(ideep(i),k) - zfg(i,k) = zf(ideep(i),k) - qstpg(i,k) = qstp(ideep(i),k) - ug(i,k) = 0._kind_phys - vg(i,k) = 0._kind_phys - end do - end do - do i = 1,lengath - zfg(i,pver+1) = zf(ideep(i),pver+1) - end do - do i = 1,lengath - capeg(i) = cape(ideep(i)) - lclg(i) = lcl(ideep(i)) - lelg(i) = lel(ideep(i)) - maxg(i) = maxi(ideep(i)) - tlg(i) = tl(ideep(i)) - landfracg(i) = landfrac(ideep(i)) - dsubcld(i) = 0._kind_phys - end do - do k = msg + 1,pver - do i = 1,lengath - if (k >= maxg(i)) then - dsubcld(i) = dsubcld(i) + dp(i,k) - end if - end do - end do - do k = msg + 2,pver - do i = 1,lengath - sdifr = 0._kind_phys - qdifr = 0._kind_phys - if (sg(i,k) > 0._kind_phys .or. sg(i,k-1) > 0._kind_phys) & - sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) - if (qg(i,k) > 0._kind_phys .or. qg(i,k-1) > 0._kind_phys) & - qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) - if (sdifr > 1.E-6_kind_phys) then - shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) - else - shat(i,k) = 0.5_kind_phys* (sg(i,k)+sg(i,k-1)) - end if - if (qdifr > 1.E-6_kind_phys) then - qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) - else - qhat(i,k) = 0.5_kind_phys* (qg(i,k)+qg(i,k-1)) - end if - end do - end do - ! tesbus dereggirt wen ot syarra derethag lla netrosh - !---- - else ! end retrigger=T - do k = 1,pver - do i = 1,lengath - tpg(i,k) = tp(ideep(i),k) - zfg(i,k) = zf(ideep(i),k) - qstpg(i,k) = qstp(ideep(i),k) - end do - end do - do i = 1,lengath - capeg(i) = cape(ideep(i)) - lclg(i) = lcl(ideep(i)) - lelg(i) = lel(ideep(i)) - maxg(i) = maxi(ideep(i)) - tlg(i) = tl(ideep(i)) - end do - endif ! end retrigger=F - !------------------------------------------------------------------------------- - - call cldprp(ncol ,pver ,pverp ,cpliq , & - latice ,cpwv ,rh2o ,& - qg ,tg ,ug ,vg ,pg , & - zg ,sg ,mu ,eu ,du , & - md ,ed ,sd ,qd ,mc , & - qu ,su ,zfg ,qs ,hmn , & - hsat ,shat ,qlg , & - cmeg ,maxg ,lelg ,jt ,jlcl , & - maxg ,j0 ,jd ,rl ,lengath , & - rgas ,grav ,cpres ,msg , & - evpg ,cug ,rprdg ,limcnv ,landfracg , & - qldeg ,qhat ) - - endif ! end second_call=F -!!--tht -!=================================================================================== - -!+tht - do k = msg + 1,pver - do i = 1,lengath - eurt (ideep(i),k)=-dmpdz(ideep(i),k) !+tht entr.rate 3D - enddo - enddo -!-tht - -! -! convert detrainment from units of "1/m" to "1/mb". -! - - do k = msg + 1,pver - do i = 1,lengath - du (i,k) = du (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - eu (i,k) = eu (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - ed (i,k) = ed (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - cug (i,k) = cug (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - cmeg (i,k) = cmeg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - rprdg(i,k) = rprdg(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - evpg (i,k) = evpg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - end do - end do - - call closure(ncol ,pver , & - qg ,tg ,pg ,zg ,sg , & - tpg ,qs ,qu ,su ,mc , & - du ,mu ,md ,qd ,sd , & - qhat ,shat ,dp ,qstpg ,zfg , & - qlg ,dsubcld ,mb ,capeg ,tlg , & - lclg ,lelg ,jt ,maxg ,1 , & - lengath ,rgas ,grav ,cpres ,rl , & - msg ,capelmt ) -! -! limit cloud base mass flux to theoretical upper bound. -! - do i=1,lengath - mumax(i) = 0 - end do - do k=msg + 2,pver - do i=1,lengath - mumax(i) = max(mumax(i), mu(i,k)/dp(i,k)) - end do - end do - - do i=1,lengath - if (mumax(i) > 0._kind_phys) then - mb(i) = min(mb(i),1._kind_phys/(delt*mumax(i))) - else - mb(i) = 0._kind_phys - endif - end do - ! If no_deep_pbl = .true., don't allow convection entirely - ! within PBL (suggestion of Bjorn Stevens, 8-2000) - - if (no_deep_pbl) then - do i=1,lengath - if (zm(ideep(i),jt(i)) < pblh(ideep(i))) mb(i) = 0 - end do - end if - - do k=msg+1,pver - do i=1,lengath - mu (i,k) = mu (i,k)*mb(i) - md (i,k) = md (i,k)*mb(i) - mc (i,k) = mc (i,k)*mb(i) - du (i,k) = du (i,k)*mb(i) - eu (i,k) = eu (i,k)*mb(i) - ed (i,k) = ed (i,k)*mb(i) - cmeg (i,k) = cmeg (i,k)*mb(i) - rprdg(i,k) = rprdg(i,k)*mb(i) - cug (i,k) = cug (i,k)*mb(i) - evpg (i,k) = evpg (i,k)*mb(i) - - end do - end do -! -! compute temperature and moisture changes due to convection. -! - call q1q2_pjr(ncol ,pver ,latice , & - dqdt ,dsdt ,qg ,qs ,qu , & - su ,du ,qhat ,shat ,dp , & - mu ,md ,sd ,qd ,qldeg , & - dsubcld ,jt ,maxg ,1 ,lengath , & - cpres ,rl ,msg , & - dlg ,evpg ,cug) - -! -! gather back temperature and mixing ratio. -! - - do k = msg + 1,pver - do i = 1,lengath -! -! q is updated to compute net precip. -! - q(ideep(i),k) = qh(ideep(i),k) + delt*dqdt(i,k) - qtnd(ideep(i),k) = dqdt (i,k) - cme (ideep(i),k) = cmeg (i,k) - rprd(ideep(i),k) = rprdg(i,k) - zdu (ideep(i),k) = du (i,k) - mcon(ideep(i),k) = mc (i,k) - heat(ideep(i),k) = dsdt (i,k)*cpres - dlf (ideep(i),k) = dlg (i,k) - ql (ideep(i),k) = qlg (i,k) - end do - end do - -! Compute precip by integrating change in water vapor minus detrained cloud water - do k = pver,msg + 1,-1 - do i = 1,ncol - prec(i) = prec(i) - dpp(i,k)* (q(i,k)-qh(i,k)) - dpp(i,k)*(dlf(i,k)+dif(i,k))*delt - end do - end do - -! obtain final precipitation rate in m/s. - do i = 1,ncol - prec(i) = rgrav*max(prec(i),0._kind_phys)/ delt/1000._kind_phys - end do - -! Compute reserved liquid (not yet in cldliq) for energy integrals. -! Treat rliq as flux out bottom, to be added back later. - do k = 1, pver - do i = 1, ncol - rliq(i) = rliq(i) + (dlf(i,k)+dif(i,k))*dpp(i,k)/gravit - rice(i) = rice(i) + dif(i,k)*dpp(i,k)/gravit - end do - end do - rliq(:ncol) = rliq(:ncol) /1000._kind_phys - rice(:ncol) = rice(:ncol) /1000._kind_phys - -! Convert mass flux from reported mb s-1 to kg m-2 s-1 - mcon(:ncol,:pverp) = mcon(:ncol,:pverp) * 100._kind_phys / gravit - - return -end subroutine zm_convr_run - -!========================================================================================= - -subroutine buoyan_dilute( ncol ,pver , & - cpliq ,latice ,cpwv ,rh2o ,& - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & - pblt ,lcl ,lel ,lon ,mx , & - rd ,grav ,cp ,msg , & - zi ,zs ,tpert ,landfrac,dmpdz , & !tht - lat ,long ,errmsg ,errflg) -!----------------------------------------------------------------------- -! -! Purpose: -! Calculates CAPE the lifting condensation level and the convective top -! where buoyancy is first -ve. -! -! Method: Calculates the parcel temperature based on a simple constant -! entraining plume model. CAPE is integrated from buoyancy. -! 09/09/04 - Simplest approach using an assumed entrainment rate for -! testing (dmpdp). -! 08/04/05 - Swap to convert dmpdz to dmpdp -! -! SCAM Logical Switches - DILUTE:RBN - Now Disabled -! --------------------- -! switch(1) = .T. - Uses the dilute parcel calculation to obtain tendencies. -! switch(2) = .T. - Includes entropy/q changes due to condensate loss and freezing. -! switch(3) = .T. - Adds the PBL Tpert for the parcel temperature at all levels. -! -! References: -! Raymond and Blythe (1992) JAS -! -! Author: -! Richard Neale - September 2004 -! -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- -! -! input arguments -! - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: pver - real(kind_phys), intent(in) :: cpliq - real(kind_phys), intent(in) :: latice - real(kind_phys), intent(in) :: cpwv - real(kind_phys), intent(in) :: rh2o - - real(kind_phys), intent(in) :: q(ncol,pver) ! spec. humidity - real(kind_phys), intent(in) :: t(ncol,pver) ! temperature - real(kind_phys), intent(in) :: p(ncol,pver) ! pressure - real(kind_phys), intent(in) :: z(ncol,pver) ! height - real(kind_phys), intent(in) :: pf(ncol,pver+1) ! pressure at interfaces - real(kind_phys), intent(in) :: pblt(ncol) ! index of pbl depth - real(kind_phys), intent(in) :: tpert(ncol) ! perturbation temperature by pbl processes - real(kind_phys), intent(inout) :: dmpdz(ncol,pver) !tht: fractional mass entrainment rate (/m) - -! Use z interface/surface relative values for PBL parcel calculations. - real(kind_phys), intent(in) :: zi(ncol,pver+1) - real(kind_phys), intent(in) :: zs(ncol) - - real(kind_phys), intent(in) :: lat(:) - real(kind_phys), intent(in) :: long(:) - -! -! output arguments -! - - real(kind_phys), intent(out) :: tp(ncol,pver) ! parcel temperature - real(kind_phys), intent(out) :: qstp(ncol,pver) ! saturation mixing ratio of parcel (only above lcl, just q below). - real(kind_phys), intent(out) :: tl(ncol) ! parcel temperature at lcl - real(kind_phys), intent(out) :: cape(ncol) ! convective aval. pot. energy. - integer lcl(ncol) ! - integer lel(ncol) ! - integer lon(ncol) ! level of onset of deep convection - integer mx(ncol) ! level of max moist static energy - - real(kind_phys), intent(in) :: landfrac(ncol) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - -! -!--------------------------Local Variables------------------------------ -! - real(kind_phys) capeten(ncol,5) ! provisional value of cape - real(kind_phys) tv(ncol,pver) ! - real(kind_phys) tpv(ncol,pver) ! - real(kind_phys) buoy(ncol,pver) - - real(kind_phys) a1(ncol) - real(kind_phys) a2(ncol) - real(kind_phys) estp(ncol) - real(kind_phys) pl(ncol) - real(kind_phys) plexp(ncol) - real(kind_phys) hmax(ncol) - real(kind_phys) hmn(ncol) - real(kind_phys) y(ncol) - - logical plge600(ncol) - integer knt(ncol) - integer lelten(ncol,5) - -! Parcel property variables - - real(kind_phys) :: hmn_lev(ncol,pver) ! Vertical profile of moist static energy for each column - real(kind_phys) :: dp_lev(ncol,pver) ! Level dpressure between interfaces - real(kind_phys) :: hmn_zdp(ncol,pver) ! Integrals of hmn_lev*dp_lev at each level - real(kind_phys) :: q_zdp(ncol,pver) ! Integrals of q*dp_lev at each level - real(kind_phys) :: dp_zfrac ! Fraction of vertical grid box below mixing top (usually pblt) - real(kind_phys) :: parcel_dz(ncol) ! Depth of parcel mixing (usually parcel_hscale*parcel_dz) - real(kind_phys) :: parcel_ztop(ncol) ! Height of parcel mixing (usually parcel_ztop+zm(nlev)) - real(kind_phys) :: parcel_dp(ncol) ! Pressure integral over parcel mixing depth (usually pblt) - real(kind_phys) :: parcel_hdp(ncol) ! Pressure*MSE integral over parcel mixing depth (usually pblt) - real(kind_phys) :: parcel_qdp(ncol) ! Pressure*q integral over parcel mixing depth (usually pblt) - real(kind_phys) :: pbl_dz(ncol) ! Previously diagnosed PBL height - real(kind_phys) :: hpar(ncol) ! Initial MSE of the parcel - real(kind_phys) :: qpar(ncol) ! Initial humidity of the parcel - real(kind_phys) :: ql(ncol) ! Initial parcel humidity (for ientropy routine) - real(kind_phys) :: zl(ncol) !tht Initial parcel GPH (for ienthalpy routine) - integer :: ipar ! Index for top of parcel mixing/launch level. - - real(kind_phys) cp - real(kind_phys) e - real(kind_phys) grav - - integer i - integer k - integer msg - integer n - - real(kind_phys) rd - real(kind_phys) rl - -!----------------------------------------------------------------------- -! - do n = 1,5 - do i = 1,ncol - lelten(i,n) = pver - capeten(i,n) = 0._kind_phys - end do - end do - - do i = 1,ncol -!tht: n.b.: with new test parcel calculation that includes parcel kinetic energy, -! the use of PBLT-dependent launch level and of CIN may be re-assessed - if(tht_tweaks) then - if (lparcel_pbl) then - lon(i) = pver ! re-assess - else - lon(i) = min(pver,nint(pblt(i))+2) - endif - else - lon(i) = pver - endif - knt(i) = 0 - lel(i) = pver - mx(i) = lon(i) - cape(i) = 0._kind_phys - hmax(i) = 0._kind_phys - pbl_dz(i) = z(i,nint(pblt(i)))-zs(i) ! mid-point z (zm) reference to PBL depth - parcel_dz(i) = max(zi(i,pver),parcel_hscale*pbl_dz(i)) ! PBL mixing depth [parcel_hscale*Boundary, but no thinner than zi(i,pver)] - parcel_ztop(i) = parcel_dz(i)+zs(i) ! PBL mixing height ztop this is wrt zs=0 - parcel_hdp(i) = 0._kind_phys - parcel_dp(i) = 0._kind_phys - parcel_qdp(i) = 0._kind_phys - hpar(i) = 0._kind_phys - qpar(i) = 0._kind_phys - end do - - tp(:ncol,:) = t(:ncol,:) - qstp(:ncol,:) = q(:ncol,:) - hmn_lev(:ncol,:) = 0._kind_phys - -!!! Initialize tv and buoy for output. -!!! tv=tv : tpv=tpv : qstp=q : buoy=0. - if (tht_tweaks) then ! use system constants - tv(:ncol,:) = t(:ncol,:) *(1._kind_phys+q(:ncol,:)/eps1) / (1._kind_phys+q(:ncol,:)) - else - tv(:ncol,:) = t(:ncol,:) *(1._kind_phys+1.608_kind_phys*q(:ncol,:))/ (1._kind_phys+q(:ncol,:)) - endif - tpv(:ncol,:) = tv(:ncol,:) - buoy(:ncol,:) = 0._kind_phys - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Mix the parcel over a certain dp or dz and take the launch level as the top level -! of this mixing region and the parcel properties as this mixed value -! Should be well mixed by other processes in the very near PBL. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - -if (lparcel_pbl) then - -! Vertical profile of MSE and pressure weighted of the same. - if(tht_thermo) then - hmn_lev(:ncol,1:pver) =(cp+q(:ncol,1:pver)*cpliq)*t(:ncol,1:pver)/(1._kind_phys+q(:ncol,1:pver)) & - +(1._kind_phys+q(:ncol,1:pver)/eps1)/(1._kind_phys+q(:ncol,1:pver))*grav*z(:ncol,1:pver) & - +(rl-(cpliq-cpwv)*(t(:ncol,1:pver)-tfreez))*q(:ncol,1:pver) - else - hmn_lev(:ncol,1:pver) = cp*t(:ncol,1:pver) + grav*z(:ncol,1:pver) + rl*q(:ncol,1:pver) - endif - dp_lev(:ncol,1:pver) = pf(:ncol,2:pver+1)-pf(:ncol,1:pver) - hmn_zdp(:ncol,1:pver) = hmn_lev(:ncol,1:pver)*dp_lev(:ncol,1:pver) - q_zdp(:ncol,1:pver) = q(:ncol,1:pver)*dp_lev(:ncol,1:pver) - -! Mix profile over vertical length scale of 0.5*PBLH. - do i = 1,ncol ! Loop columns - do k = pver,msg + 1,-1 - - if (zi(i,k+1)<= parcel_dz(i)) then ! Has to be relative to near-surface layer center elevation - ipar = k - - if (k == pver) then ! Always at least the full depth of lowest model layer. - dp_zfrac = 1._kind_phys - else - ! Fraction of grid cell depth (mostly 1, except when parcel_ztop is in between levels. - dp_zfrac = min(1._kind_phys,(parcel_dz(i)-zi(i,k+1))/(zi(i,k)-zi(i,k+1))) - end if - - parcel_hdp(i) = parcel_hdp(i)+hmn_zdp(i,k)*dp_zfrac ! Sum parcel profile up to a certain level. - parcel_qdp(i) = parcel_qdp(i)+q_zdp(i,k)*dp_zfrac ! Sum parcel profile up to a certain level. - parcel_dp(i) = parcel_dp(i)+dp_lev(i,k)*dp_zfrac ! SUM dp's for weighting of parcel_hdp - - end if - end do - hpar(i) = parcel_hdp(i)/parcel_dp(i) - qpar(i) = parcel_qdp(i)/parcel_dp(i) - mx(i) = ipar - end do - -else ! Default method finding level of MSE maximum (nlev sensitive though) - ! - ! set "launching" level(mx) to be at maximum moist static energy. - ! search for this level stops at planetary boundary layer top. - ! - do k = pver,msg + 1,-1 - do i = 1,ncol - if(tht_thermo) then - hmn(i) =(cp+q(i,k)*cpliq)*t(i,k)/(1._kind_phys+q(i,k)) & - +(1._kind_phys+q(i,k)/eps1)/(1._kind_phys+q(i,k))*grav*z(i,k) & - +(rl-(cpliq-cpwv)*(t(i,k)-tfreez))*q(i,k) - else - hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) - endif - if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then - hmax(i) = hmn(i) - mx(i) = k - end if - end do - end do - -end if ! Default method of determining parcel launch properties. - -! LCL dilute calculation - initialize to mx(i) -! Determine lcl in parcel_dilute and get pl,tl after parcel_dilute -! Original code actually sets LCL as level above wher condensate forms. -! Therefore in parcel_dilute lcl(i) will be at first level where qsmix < qtmix. - -if (lparcel_pbl) then - -! For parcel dilute need to invert hpar and qpar. -! Now need to supply ql(i) as it is mixed parcel version, just q(i,max(i)) in default - - do i = 1,ncol ! Initialise LCL variables. - lcl(i) = mx(i) - tl(i) = (hpar(i)-rl*qpar(i)-grav*parcel_ztop(i))/cp - ql(i) = qpar(i) - if(tht_thermo) & !tht: not exact but should be good enough - tl(i) = (hpar(i)-(rl-(cpliq-cpwv)*(tl(i)-tfreez))*ql(i) & - -(1._kind_phys+ql(i)/eps1)/(1._kind_phys+ql(i))*grav*parcel_ztop(i)) & - /((cp+qpar(i)*cpliq)/(1._kind_phys+ql(i))) - pl(i) = p(i,mx(i)) - zl(i) = parcel_ztop(i) - end do - -else - do i = 1,ncol - lcl(i) = mx(i) - tl(i) = t(i,mx(i)) - zl(i) = z(i,mx(i)) - ql(i) = q(i,mx(i)) - pl(i) = p(i,mx(i)) - end do - -end if ! Mixed parcel properties - -! -! dilute plume buoyancy calculation without exclamation marks. -! - call parcel_dilute(ncol, pver, cpliq, cpwv, rh2o, latice, msg, mx, p, z, t, q, & !tht - tpert, tp, tpv, qstp, pl, tl, zl, ql, lcl, & !tht - landfrac, dmpdz, lat, long, errmsg, errflg) !tht - -! If lcl is above the nominal level of non-divergence (600 mbs), -! no deep convection is permitted (ensuing calculations -! skipped and cape retains initialized value of zero). -! - do i = 1,ncol - plge600(i) = pl(i).ge.plclmin ! Just change to always allow buoy calculation. - end do - -! -! Main buoyancy calculation. -! - do k = pver,msg + 1,-1 - do i=1,ncol - if (k <= mx(i) .and. plge600(i)) then ! Define buoy from launch level to cloud top. - if (tht_tweaks) then - tv(i,k) = t(i,k)* (1._kind_phys+q(i,k)/eps1)/ (1._kind_phys+q(i,k)) - buoy(i,k) = tpv(i,k) - tv(i,k) +(tiedke_add*(1._kind_phys-landfrac(i))+tiedke_lnd*landfrac(i)) - else - tv(i,k) = t(i,k)* (1._kind_phys+1.608_kind_phys*q(i,k))/ (1._kind_phys+q(i,k)) - buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add - endif - else - qstp(i,k) = q(i,k) - tp(i,k) = t(i,k) - tpv(i,k) = tv(i,k) - endif - end do - end do - - - -!------------------------------------------------------------------------------- -! beginning from one below top (first level p>40hPa, msg) check for at most -! num_cin levels of neutral buoyancy (LELten) and compute CAPEten between LCL -! and each of them (tht) - - do k = msg + 2,pver - do i = 1,ncol - if (k < lcl(i) .and. plge600(i)) then - if (buoy(i,k+1) > 0._kind_phys .and. buoy(i,k) <= 0._kind_phys) then - knt(i) = min(num_cin,knt(i) + 1) - lelten(i,knt(i)) = k - end if - end if - end do - end do -! -! calculate convective available potential energy (cape). -! - do n = 1,num_cin - do k = msg + 1,pver - do i = 1,ncol - if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then - capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k)) - end if - end do - end do - end do -! -! find maximum cape from all possible tentative capes from -! one sounding, -! and use it as the final cape, april 26, 1995 -! - do n = 1,num_cin - do i = 1,ncol - if (capeten(i,n) > cape(i)) then - cape(i) = capeten(i,n) - lel(i) = lelten(i,n) - end if - end do - end do -! -! put lower bound on cape for diagnostic purposes. -! - do i = 1,ncol - cape(i) = max(cape(i), 0._kind_phys) - end do -! - return -end subroutine buoyan_dilute - -subroutine parcel_dilute (ncol, pver, cpliq, cpwv, rh2o, latice, msg, klaunch, p, z, t, q, & !tht - tpert, tp, tpv, qstp, pl, tl, zl, ql, lcl, & !tht - landfrac,dmpdz,lat,long,errmsg,errflg) !tht - -! Routine to determine -! 1. Tp - Parcel temperature -! 2. qstp - Saturated mixing ratio at the parcel temperature. - -!-------------------- -implicit none -!-------------------- - -integer, intent(in) :: ncol -integer, intent(in) :: pver -real(kind_phys), intent(in) :: cpliq -real(kind_phys), intent(in) :: cpwv -real(kind_phys), intent(in) :: rh2o -real(kind_phys), intent(in) :: latice -integer, intent(in) :: msg - -integer, intent(in), dimension(ncol) :: klaunch(ncol) - -real(kind_phys), intent(in), dimension(ncol,pver) :: p -real(kind_phys), intent(in), dimension(ncol,pver) :: t -real(kind_phys), intent(in), dimension(ncol,pver) :: z !tht -real(kind_phys), intent(in), dimension(ncol,pver) :: q -real(kind_phys), intent(in), dimension(ncol) :: tpert ! PBL temperature perturbation. - -real(kind_phys), intent(in) :: lat(:) -real(kind_phys), intent(in) :: long(:) - -real(kind_phys), intent(inout), dimension(ncol,pver) :: tp ! Parcel temp. -real(kind_phys), intent(inout), dimension(ncol,pver) :: qstp ! Parcel water vapour (sat value above lcl). -real(kind_phys), intent(inout), dimension(ncol) :: tl ! Actual temp of LCL. -real(kind_phys), intent(inout), dimension(ncol) :: ql ! Actual humidity of LCL -real(kind_phys), intent(inout), dimension(ncol) :: pl ! Actual pressure of LCL. -real(kind_phys), intent(inout), dimension(ncol) :: zl !tht GPH of LCL. - -integer, intent(inout), dimension(ncol) :: lcl ! Lifting condesation level (first model level with saturation). - -real(kind_phys), intent(out), dimension(ncol,pver) :: tpv ! Define tpv within this routine. - -character(len=512), intent(out) :: errmsg -integer, intent(out) :: errflg - - - -real(kind_phys), intent(in), dimension(ncol) :: landfrac -real(kind_phys), intent(inout), dimension(ncol,pver) :: dmpdz !tht -!-------------------- - -! Have to be careful as s is also dry static energy. -!+tht -! in the mods below, s is used both as enthalpy (moist s.e.) and entropy -!-tht - -! If we are to retain the fact that CAM loops over grid-points in the internal -! loop then we need to dimension sp,atp,mp,xsh2o with ncol. - - -real(kind_phys) tmix(ncol,pver) ! Tempertaure of the entraining parcel. -real(kind_phys) qtmix(ncol,pver) ! Total water of the entraining parcel. -real(kind_phys) qsmix(ncol,pver) ! Saturated mixing ratio at the tmix. -real(kind_phys) smix(ncol,pver) ! Entropy of the entraining parcel. -real(kind_phys) xsh2o(ncol,pver) ! Precipitate lost from parcel. -real(kind_phys) ds_xsh2o(ncol,pver) ! Entropy change due to loss of condensate. -real(kind_phys) ds_freeze(ncol,pver) ! Entropy change sue to freezing of precip. - -real(kind_phys) mp(ncol) ! Parcel mass flux. -real(kind_phys) qtp(ncol) ! Parcel total water. -real(kind_phys) sp(ncol) ! Parcel entropy. - -real(kind_phys) sp0(ncol) ! Parcel launch entropy. -real(kind_phys) qtp0(ncol) ! Parcel launch total water. -real(kind_phys) mp0(ncol) ! Parcel launch relative mass flux. - -real(kind_phys) lwmax ! Maximum condesate that can be held in cloud before rainout. -real(kind_phys) dmpdp ! Parcel fractional mass entrainment rate (/mb). -!real(kind_phys) dmpdz ! Parcel fractional mass entrainment rate (/m) -real(kind_phys) dpdz,dzdp ! Hydrstatic relation and inverse of. -real(kind_phys) senv ! Environmental entropy at each grid point. -real(kind_phys) qtenv ! Environmental total water " " ". -real(kind_phys) penv ! Environmental total pressure " " ". -real(kind_phys) tenv ! Environmental total temperature " " ". -real(kind_phys) zenv !tht Environmental GPH -real(kind_phys) new_s ! Hold value for entropy after condensation/freezing adjustments. -real(kind_phys) new_q ! Hold value for total water after condensation/freezing adjustments. -real(kind_phys) dp ! Layer thickness (center to center) -real(kind_phys) tfguess ! First guess for entropy inversion - crucial for efficiency! -real(kind_phys) tscool ! Super cooled temperature offset (in degC) (eg -35). - -real(kind_phys) qxsk, qxskp1 ! LCL excess water (k, k+1) -real(kind_phys) dsdp, dqtdp, dqxsdp ! LCL s, qt, p gradients (k, k+1) -real(kind_phys) slcl,qtlcl,qslcl ! LCL s, qt, qs values. - -integer rcall ! Number of ientropy call for errors recording -integer nit_lheat ! Number of iterations for condensation/freezing loop. -integer i,k,ii ! Loop counters. - -real(kind_phys) est !tht - -!====================================================================== -! SUMMARY -! -! 9/9/04 - Assumes parcel is initiated from level of maxh (klaunch) -! and entrains at each level with a specified entrainment rate. -! -! 15/9/04 - Calculates lcl(i) based on k where qsmix is first < qtmix. -! -!====================================================================== -! -! Set some values that may be changed frequently. -! - -nit_lheat = 2 ! iterations for ds,dq changes from condensation freezing. -if (.not.tht_tweaks) dmpdz(:,:)=dmpdz_param ! Entrainment rate. (-ve for /m) - -lwmax = 1.e-3_kind_phys ! Need to put formula in for this. -tscool = 0.0_kind_phys ! Temp at which water loading freezes in the cloud. -!lwmax = 1.e10_kind_phys ! tht: don't precipitate -!tscool =-10._kind_phys ! tht: allow even just mild supercooling?! - -qtmix=0._kind_phys -smix=0._kind_phys - -qtenv = 0._kind_phys -senv = 0._kind_phys -tenv = 0._kind_phys -zenv = 0._kind_phys !tht -penv = 0._kind_phys - -qtp0 = 0._kind_phys -sp0 = 0._kind_phys -mp0 = 0._kind_phys - -qtp = 0._kind_phys -sp = 0._kind_phys -mp = 0._kind_phys - -new_q = 0._kind_phys -new_s = 0._kind_phys - -! **** Begin loops **** - -do k = pver, msg+1, -1 - do i=1,ncol - -! Initialize parcel values at launch level. - if (k == klaunch(i)) then - if (lparcel_pbl) then ! Modifcations to parcel properties if lparcel_pbl set. - qtp0(i) = ql(i) ! Parcel launch q (PBL mixed value). - if(tht_tweaks) then - sp0(i) = enthalpy(tl(i),pl(i),qtp0(i),zl(i),cpliq,cpwv,rh2o) - else - sp0(i) = entropy(tl(i),pl(i),qtp0(i),cpliq,cpwv,rh2o) ! Parcel launch entropy could be a mixed parcel. - endif - else - qtp0(i) = q(i,k) ! Parcel launch total water (assuming subsaturated) - if(tht_tweaks) then - sp0(i) = enthalpy(t(i,k),p(i,k),qtp0(i),z(i,k),cpliq,cpwv,rh2o) - else - sp0(i) = entropy(t(i,k),p(i,k),qtp0(i),cpliq,cpwv,rh2o) ! Parcel launch entropy. - endif - end if - mp0(i) = 1._kind_phys ! Parcel launch relative mass (i.e. 1 parcel stays 1 parcel for dmpdp=0, undilute). - smix(i,k) = sp0(i) - qtmix(i,k) = qtp0(i) - if(tht_tweaks) then - if (lparcel_pbl) then !+tht - tfguess = t(i,k) - rcall = 1 - call ienthalpy(rcall,i,smix(i,k),p(i,k),z(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,& - lat(i), long(i), errmsg,errflg) - else -!+tht: if .not.lparcel_pbl: since the function to invert for T is identical with -! sp0(i)=entropy(t), the result is t(i,k) (verified 21/2/2014) - tmix(i,k) = t(i,k) - call qsat_hPa(tmix(i,k),p(i,k), est, qsmix(i,k)) - endif - else - tfguess = t(i,k) - rcall = 1 - call ientropy (rcall,i,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,& - lat(i), long(i), errmsg,errflg) - endif - end if - -! Entraining levels - - if (k < klaunch(i)) then -! Set environmental values for this level. - dp = (p(i,k)-p(i,k+1)) ! In -ve mb as p decreasing with height - difference between center of layers. - qtenv = 0.5_kind_phys*(q(i,k)+q(i,k+1)) ! Total water of environment. - tenv = 0.5_kind_phys*(t(i,k)+t(i,k+1)) - penv = 0.5_kind_phys*(p(i,k)+p(i,k+1)) - zenv = 0.5_kind_phys*(z(i,k)+z(i,k+1)) !tht - - if (tht_tweaks) then - senv = enthalpy(tenv,penv,qtenv,zenv,cpliq,cpwv,rh2o) ! Enthalpy of environment. - else - senv = entropy(tenv,penv,qtenv,cpliq,cpwv,rh2o) ! Entropy of environment. - endif - -! Determine fractional entrainment rate /pa given value /m. - dpdz = -(penv*grav)/(rgas*tenv) ! in mb/m since p in mb. - dzdp = 1._kind_phys/dpdz ! in m/mb - dmpdp = dmpdz(i,k)*dzdp !tht - -! Sum entrainment to current level -! entrains q,s out of intervening dp layers, in which linear variation is assumed -! so really it entrains the mean of the 2 stored values. - sp(i) = sp(i) - dmpdp*dp*senv - qtp(i) = qtp(i) - dmpdp*dp*qtenv - mp(i) = mp(i) - dmpdp*dp - -! Entrain s and qt to next level. - smix(i,k) = (sp0(i) + sp(i)) / (mp0(i) + mp(i)) - qtmix(i,k) = (qtp0(i) + qtp(i)) / (mp0(i) + mp(i)) - -! Invert entropy from s and q to determine T and saturation-capped q of mixture. -! t(i,k) used as a first guess so that it converges faster. - tfguess = tmix(i,k+1) - rcall = 2 - if (tht_tweaks) then - call ienthalpy(rcall,i,smix(i,k),p(i,k),z(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,lat(i),& - long(i),errmsg,errflg) - else - call ientropy(rcall,i,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess,cpliq,cpwv,rh2o,lat(i),& - long(i),errmsg,errflg) - endif - -! Determine if this is lcl of this column if qsmix <= qtmix. -! FIRST LEVEL where this happens on ascending. - if (qsmix(i,k) <= qtmix(i,k) .and. qsmix(i,k+1) > qtmix(i,k+1)) then - lcl(i) = k - qxsk = qtmix(i,k) - qsmix(i,k) - qxskp1 = qtmix(i,k+1) - qsmix(i,k+1) - dqxsdp = (qxsk - qxskp1)/dp - pl(i) = p(i,k+1) - qxskp1/dqxsdp ! pressure level of actual lcl. - zl(i) = z(i,k+1) - qxskp1/dqxsdp *dzdp !tht - dsdp = (smix(i,k) - smix(i,k+1))/dp - dqtdp = (qtmix(i,k) - qtmix(i,k+1))/dp - slcl = smix(i,k+1) + dsdp* (pl(i)-p(i,k+1)) - qtlcl = qtmix(i,k+1) + dqtdp*(pl(i)-p(i,k+1)) - - tfguess = tmix(i,k) - rcall = 3 - if (tht_tweaks) then - call ienthalpy(rcall,i,slcl,pl(i),zl(i),qtlcl,tl(i),qslcl,tfguess,cpliq,cpwv,rh2o,lat(i), long(i), errmsg,errflg) - else - call ientropy (rcall,i,slcl,pl(i),qtlcl,tl(i),qslcl,tfguess,cpliq,cpwv,rh2o,lat(i), long(i), errmsg,errflg) - endif - - endif -! - end if ! k < klaunch - - - end do ! Levels loop -end do ! Columns loop - -! many lines of meaningless comment with bad orthography and lost of exclamation marks - -xsh2o = 0._kind_phys -ds_xsh2o = 0._kind_phys -ds_freeze = 0._kind_phys - -do k = pver, msg+1, -1 - do i=1,ncol - -! Initialize variables at k=klaunch - - if (k == klaunch(i)) then - -! Set parcel values at launch level assume no liquid water. - - tp(i,k) = tmix(i,k) - qstp(i,k) = q(i,k) - if (tht_tweaks) then - tpv(i,k) = (tp(i,k) + tpert(i)) * (1._kind_phys+qstp(i,k)/eps1) / (1._kind_phys+qstp(i,k)) - else - tpv(i,k) = (tp(i,k) + tpert(i)) * (1._kind_phys+1.608_kind_phys*qstp(i,k)) / (1._kind_phys+qstp(i,k)) - endif - - end if - - if (k < klaunch(i)) then - - if (tht_tweaks) then - smix(i,k)=entropy(tmix(i,k),p(i,k),qtmix(i,k),cpliq,cpwv,rh2o) !+tht make sure to use entropy here - endif - -! Iterate nit_lheat times for s,qt changes. - do ii=0,nit_lheat-1 - -! Rain (xsh2o) is excess condensate, bar LWMAX (Accumulated loss from qtmix). - xsh2o(i,k) = max (0._kind_phys, qtmix(i,k) - qsmix(i,k) - lwmax) - -! Contribution to ds from precip loss of condensate (Accumulated change from smix).(-ve) - ds_xsh2o(i,k) = ds_xsh2o(i,k+1) - cpliq * log (tmix(i,k)/tfreez) * max(0._kind_phys,(xsh2o(i,k)-xsh2o(i,k+1))) -! -! Entropy of freezing: latice times amount of water involved divided by T. - if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) == 0._kind_phys) then ! One off freezing of condensate. - ds_freeze(i,k) = (latice/tmix(i,k)) * max(0._kind_phys,qtmix(i,k)-qsmix(i,k)-xsh2o(i,k)) ! Gain of LH - end if - - if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) /= 0._kind_phys) then ! Continual freezing of additional condensate. - ds_freeze(i,k) = ds_freeze(i,k+1)+(latice/tmix(i,k)) * max(0._kind_phys,(qsmix(i,k+1)-qsmix(i,k))) - end if - -! Adjust entropy and accordingly to sum of ds (be careful of signs). - new_s = smix(i,k) + ds_xsh2o(i,k) + ds_freeze(i,k) - -! Adjust liquid water and accordingly to xsh2o. - new_q = qtmix(i,k) - xsh2o(i,k) - -! Invert entropy to get updated Tmix and qsmix of parcel. - tfguess = tmix(i,k) - rcall =4 - call ientropy (rcall,i,new_s, p(i,k), new_q, tmix(i,k), qsmix(i,k), tfguess,cpliq,cpwv,rh2o,& - lat(i), long(i), errmsg,errflg) - - end do ! Iteration loop for freezing processes. - -! tp - Parcel temp is temp of mixture. -! tpv - Parcel v. temp should be density temp with new_q total water. - tp(i,k) = tmix(i,k) - -! tpv = tprho in the presence of condensate (i.e. when new_q > qsmix) - if (new_q > qsmix(i,k)) then ! Super-saturated so condensate present - reduces buoyancy. - qstp(i,k) = qsmix(i,k) - else ! Just saturated/sub-saturated - no condensate virtual effects. - qstp(i,k) = new_q - end if - if (tht_tweaks) then - tpv(i,k) = (tp(i,k)+tpert(i))* (1._kind_phys+qstp(i,k)/eps1) / (1._kind_phys+ new_q) !+tht - else - tpv(i,k) = (tp(i,k)+tpert(i))* (1._kind_phys+1.608_kind_phys*qstp(i,k)) / (1._kind_phys+ new_q) - endif - - end if ! k < klaunch - - end do ! Loop for columns - -end do ! Loop for vertical levels. - - -return -end subroutine parcel_dilute - -!----------------------------------------------------------------------------------------- -real(kind_phys) function entropy(TK,p,qtot,cpliq,cpwv,rh2o) -!----------------------------------------------------------------------------------------- -! -! TK(K),p(mb),qtot(kg/kg) -! from Raymond and Blyth 1992 -! - real(kind_phys), intent(in) :: p,qtot,TK - real(kind_phys), intent(in) :: cpliq - real(kind_phys), intent(in) :: cpwv - real(kind_phys), intent(in) :: rh2o - - real(kind_phys) :: qv,qst,e,est,L - real(kind_phys), parameter :: pref = 1000._kind_phys - -L = rl - (cpliq - cpwv)*(TK-tfreez) ! T IN CENTIGRADE - -call qsat_hPa(TK, p, est, qst) - -qv = min(qtot,qst) ! Partition qtot into vapor part only. -e = qv*p / (eps1 +qv) - -entropy = (cpres + qtot*cpliq)*log( TK/tfreez) - rgas*log( (p-e)/pref ) + & - L*qv/TK - qv*rh2o*log(qv/qst) - -end FUNCTION entropy - -! -!----------------------------------------------------------------------------------------- -SUBROUTINE ientropy (rcall,icol,s,p,qt,T,qst,Tfg,cpliq,cpwv,rh2o,this_lat,this_lon,errmsg,errflg) -!----------------------------------------------------------------------------------------- -! -! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). -! Inverts entropy, pressure and total water qt -! for T and saturated vapor mixing ratio -! - - integer, intent(in) :: icol, rcall - real(kind_phys), intent(in) :: s, p, Tfg, qt - real(kind_phys), intent(in) :: cpliq - real(kind_phys), intent(in) :: cpwv - real(kind_phys), intent(in) :: rh2o - - real(kind_phys), intent(in) :: this_lat - real(kind_phys), intent(in) :: this_lon - - real(kind_phys), intent(out) :: qst, T - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind_phys) :: est - real(kind_phys) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol - integer :: i - - logical :: converged - - ! Max number of iteration loops. - integer, parameter :: LOOPMAX = 100 - real(kind_phys), parameter :: EPS = 3.e-8_kind_phys - - converged = .false. - - ! Invert the entropy equation -- use Brent's method - ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. - - T = Tfg ! Better first guess based on Tprofile from conv. - - a = Tfg-10 !low bracket - b = Tfg+10 !high bracket - - fa = entropy(a, p, qt,cpliq,cpwv,rh2o) - s - fb = entropy(b, p, qt,cpliq,cpwv,rh2o) - s - - c=b - fc=fb - tol=0.001_kind_phys - - converge: do i=0, LOOPMAX - if ((fb > 0.0_kind_phys .and. fc > 0.0_kind_phys) .or. & - (fb < 0.0_kind_phys .and. fc < 0.0_kind_phys)) then - c=a - fc=fa - d=b-a - ebr=d - end if - if (abs(fc) < abs(fb)) then - a=b - b=c - c=a - fa=fb - fb=fc - fc=fa - end if - - tol1=2.0_kind_phys*EPS*abs(b)+0.5_kind_phys*tol - xm=0.5_kind_phys*(c-b) - converged = (abs(xm) <= tol1 .or. fb == 0.0_kind_phys) - if (converged) exit converge - - if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then - sbr=fb/fa - if (a == c) then - pbr=2.0_kind_phys*xm*sbr - qbr=1.0_kind_phys-sbr - else - qbr=fa/fc - rbr=fb/fc - pbr=sbr*(2.0_kind_phys*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_kind_phys)) - qbr=(qbr-1.0_kind_phys)*(rbr-1.0_kind_phys)*(sbr-1.0_kind_phys) - end if - if (pbr > 0.0_kind_phys) qbr=-qbr - pbr=abs(pbr) - if (2.0_kind_phys*pbr < min(3.0_kind_phys*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then - ebr=d - d=pbr/qbr - else - d=xm - ebr=d - end if - else - d=xm - ebr=d - end if - a=b - fa=fb - b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) - - fb = entropy(b, p, qt,cpliq,cpwv,rh2o) - s - - end do converge - - T = b - call qsat_hPa(T, p, est, qst) - - if (.not. converged) then - write(errmsg,100) ' ZM_CONV: IENTROPY. Details: call#,icol= ',rcall,icol, & - ' lat: ',this_lat,' lon: ',this_lon, & - ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._kind_phys*qt, & - ' qst(g/kg) = ', 1000._kind_phys*qst,', s(J/kg) = ',s - errflg=1 - end if - -100 format (A,I4,I4,7(A,F6.2)) - -end SUBROUTINE ientropy - -!----------------------------------------------------------------------------------------- -real(kind_phys) function enthalpy(TK,p,qtot,z,cpliq,cpwv,rh2o) -!----------------------------------------------------------------------------------------- -! -! TK(K),p(mb),qtot(kg/kg) -! - real(kind_phys), intent(in) :: p,qtot,TK,z - real(kind_phys), intent(in) :: cpliq - real(kind_phys), intent(in) :: cpwv - real(kind_phys), intent(in) :: rh2o - real(kind_phys) :: qv,qst,e,est,L - -L = rl - (cpliq - cpwv)*(TK-tfreez) - -call qsat_hPa(TK, p, est, qst) -qv = min(qtot,qst) ! Partition qtot into vapor part only. - - enthalpy = (cpres + qtot*cpliq)* TK + L*qv + (1._kind_phys+qtot)*grav*z - -return -end FUNCTION enthalpy - -!----------------------------------------------------------------------------------------- -SUBROUTINE ienthalpy (rcall,icol,s,p,z,qt,T,qst,Tfg,cpliq,cpwv,rh2o,this_lat,this_lon,errmsg,errflg) -!----------------------------------------------------------------------------------------- -! -! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). -! Inverts enthalpy, pressure and total water qt -! for T and saturated vapor mixing ratio -! - - integer, intent(in) :: icol, rcall - real(kind_phys), intent(in) :: s, p, z, Tfg, qt - real(kind_phys), intent(in) :: cpliq - real(kind_phys), intent(in) :: cpwv - real(kind_phys), intent(in) :: rh2o - - real(kind_phys), intent(in) :: this_lat - real(kind_phys), intent(in) :: this_lon - - real(kind_phys), intent(out) :: qst, T - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind_phys) :: est - real(kind_phys) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol - integer :: i - - logical :: converged - - ! Max number of iteration loops. - integer, parameter :: LOOPMAX = 100 - real(kind_phys), parameter :: EPS = 3.e-8_kind_phys - - converged = .false. - - ! Invert the enthalpy equation -- use Brent's method - ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. - - T = Tfg ! Better first guess based on Tprofile from conv. - - a = Tfg-10 !low bracket - b = Tfg+10 !high bracket - - fa = enthalpy(a, p, qt, z, cpliq,cpwv,rh2o) - s - fb = enthalpy(b, p, qt, z, cpliq,cpwv,rh2o) - s - - c=b - fc=fb - tol=0.001_kind_phys - - converge: do i=0, LOOPMAX - if ((fb > 0.0_kind_phys .and. fc > 0.0_kind_phys) .or. & - (fb < 0.0_kind_phys .and. fc < 0.0_kind_phys)) then - c=a - fc=fa - d=b-a - ebr=d - end if - if (abs(fc) < abs(fb)) then - a=b - b=c - c=a - fa=fb - fb=fc - fc=fa - end if - - tol1=2.0_kind_phys*EPS*abs(b)+0.5_kind_phys*tol - xm=0.5_kind_phys*(c-b) - converged = (abs(xm) <= tol1 .or. fb == 0.0_kind_phys) - if (converged) exit converge - - if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then - sbr=fb/fa - if (a == c) then - pbr=2.0_kind_phys*xm*sbr - qbr=1.0_kind_phys-sbr - else - qbr=fa/fc - rbr=fb/fc - pbr=sbr*(2.0_kind_phys*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_kind_phys)) - qbr=(qbr-1.0_kind_phys)*(rbr-1.0_kind_phys)*(sbr-1.0_kind_phys) - end if - if (pbr > 0.0_kind_phys) qbr=-qbr - pbr=abs(pbr) - if (2.0_kind_phys*pbr < min(3.0_kind_phys*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then - ebr=d - d=pbr/qbr - else - d=xm - ebr=d - end if - else - d=xm - ebr=d - end if - a=b - fa=fb - b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) - - fb = enthalpy(b, p, qt, z, cpliq,cpwv,rh2o) - s - - end do converge - - T = b - call qsat_hPa(T, p, est, qst) - - if (.not. converged) then - write(errmsg,101) ' ZM_CONV: IENTHALPY. Details: call#,icol= ',rcall,icol, & - ' lat: ',this_lat,' lon: ',this_lon, & - ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._kind_phys*qt, & - ' qst(g/kg) = ', 1000._kind_phys*qst,', s(J/kg) = ',s - errflg=1 - end if - -101 format (A,I4,I4,7(A,F6.2)) - -end SUBROUTINE ienthalpy - -subroutine cldprp(ncol ,pver ,pverp ,cpliq , & - latice ,cpwv ,rh2o ,& - q ,t ,u ,v ,p , & - z ,s ,mu ,eu ,du , & - md ,ed ,sd ,qd ,mc , & - qu ,su ,zf ,qst ,hmn , & - hsat ,shat ,ql , & - cmeg ,jb ,lel ,jt ,jlcl , & - mx ,j0 ,jd ,rl ,il2g , & - rd ,grav ,cp ,msg , & - evp ,cu ,rprd ,limcnv ,landfrac, & - qcde ,qhat ) - -!----------------------------------------------------------------------- -! (meaningless comment here) -!----------------------------------------------------------------------- - - implicit none - -!------------------------------------------------------------------------------ -! -! Input arguments -! - integer, intent(in) :: ncol - integer, intent(in) :: pver - integer, intent(in) :: pverp - - real(kind_phys), intent(in) :: cpliq - real(kind_phys), intent(in) :: latice - real(kind_phys), intent(in) :: cpwv - real(kind_phys), intent(in) :: rh2o - - real(kind_phys), intent(in) :: q(ncol,pver) ! spec. humidity of env - real(kind_phys), intent(in) :: t(ncol,pver) ! temp of env - real(kind_phys), intent(in) :: p(ncol,pver) ! pressure of env - real(kind_phys), intent(in) :: z(ncol,pver) ! height of env - real(kind_phys), intent(in) :: s(ncol,pver) ! normalized dry static energy of env - real(kind_phys), intent(in) :: zf(ncol,pverp) ! height of interfaces - real(kind_phys), intent(in) :: u(ncol,pver) ! zonal velocity of env - real(kind_phys), intent(in) :: v(ncol,pver) ! merid. velocity of env - - real(kind_phys), intent(in) :: landfrac(ncol) ! RBN Landfrac - - integer, intent(in) :: jb(ncol) ! updraft base level - integer, intent(in) :: lel(ncol) ! updraft launch level - integer, intent(in) :: mx(ncol) ! updraft base level (same is jb) - integer, intent(out) :: jt(ncol) ! updraft plume top - integer, intent(out) :: jlcl(ncol) ! updraft lifting cond level - integer, intent(out) :: j0(ncol) ! level where updraft begins detraining - integer, intent(out) :: jd(ncol) ! level of downdraft - integer, intent(in) :: limcnv ! convection limiting level - integer, intent(in) :: il2g !CORE GROUP REMOVE - integer, intent(in) :: msg ! missing moisture vals (always 0) - real(kind_phys), intent(in) :: rl ! latent heat of vap - real(kind_phys), intent(in) :: shat(ncol,pver) ! interface values of dry stat energy - real(kind_phys), intent(in) :: qhat(ncol,pver) ! wg grid slice of upper interface mixing ratio. - -! -! output -! - real(kind_phys), intent(out) :: rprd(ncol,pver) ! rate of production of precip at that layer - real(kind_phys), intent(out) :: du(ncol,pver) ! detrainement rate of updraft - real(kind_phys), intent(out) :: ed(ncol,pver) ! entrainment rate of downdraft - real(kind_phys), intent(out) :: eu(ncol,pver) ! entrainment rate of updraft - real(kind_phys), intent(out) :: hmn(ncol,pver) ! moist stat energy of env - real(kind_phys), intent(out) :: hsat(ncol,pver) ! sat moist stat energy of env - real(kind_phys), intent(out) :: mc(ncol,pver) ! net mass flux - real(kind_phys), intent(out) :: md(ncol,pver) ! downdraft mass flux - real(kind_phys), intent(out) :: mu(ncol,pver) ! updraft mass flux - real(kind_phys), intent(out) :: qd(ncol,pver) ! spec humidity of downdraft - real(kind_phys), intent(out) :: ql(ncol,pver) ! liq water of updraft - real(kind_phys), intent(out) :: qst(ncol,pver) ! saturation mixing ratio of env. - real(kind_phys), intent(out) :: qu(ncol,pver) ! spec hum of updraft - real(kind_phys), intent(out) :: sd(ncol,pver) ! normalized dry stat energy of downdraft - real(kind_phys), intent(out) :: su(ncol,pver) ! normalized dry stat energy of updraft - real(kind_phys), intent(out) :: qcde(ncol,pver) ! cloud water mixing ratio for detrainment (kg/kg) - - real(kind_phys) rd ! gas constant for dry air - real(kind_phys) grav ! gravity - real(kind_phys) cp ! heat capacity of dry air - -! -! Local workspace -! - real(kind_phys) gamma(ncol,pver) - real(kind_phys) dz(ncol,pver) - real(kind_phys) iprm(ncol,pver) - real(kind_phys) hu(ncol,pver) - real(kind_phys) hd(ncol,pver) - real(kind_phys) eps(ncol,pver) - real(kind_phys) f(ncol,pver) - real(kind_phys) k1(ncol,pver) - real(kind_phys) i2(ncol,pver) - real(kind_phys) ihat(ncol,pver) - real(kind_phys) i3(ncol,pver) - real(kind_phys) idag(ncol,pver) - real(kind_phys) i4(ncol,pver) - real(kind_phys) qsthat(ncol,pver) - real(kind_phys) hsthat(ncol,pver) - real(kind_phys) gamhat(ncol,pver) - real(kind_phys) cu(ncol,pver) - real(kind_phys) evp(ncol,pver) - real(kind_phys) cmeg(ncol,pver) - real(kind_phys) qds(ncol,pver) - real(kind_phys) c0mask(ncol) - -!tht For tiedke_lnd - real(kind_phys) tiedke_msk(ncol) - !vars for tht_thermo - real(kind_phys), dimension(ncol,pver) :: mcp,mrd,mrl,tu,td -!-tht - - real(kind_phys) hmin(ncol) - real(kind_phys) expdif(ncol) - real(kind_phys) expnum(ncol) - real(kind_phys) ftemp(ncol) - real(kind_phys) eps0(ncol) - real(kind_phys) rmue(ncol) - real(kind_phys) zuef(ncol) - real(kind_phys) zdef(ncol) - real(kind_phys) epsm(ncol) - real(kind_phys) ratmjb(ncol) - real(kind_phys) est(ncol) - real(kind_phys) totpcp(ncol) - real(kind_phys) totevp(ncol) - real(kind_phys) alfa(ncol) - real(kind_phys) ql1 - real(kind_phys) estu - real(kind_phys) qstu - - real(kind_phys) small - real(kind_phys) mdt - - !real(kind_phys) fice(ncol,pver) ! ice fraction in precip production - real(kind_phys) tug(ncol,pver) - - real(kind_phys) tvuo(ncol,pver) ! updraft virtual T w/o freezing heating - real(kind_phys) tvu(ncol,pver) ! updraft virtual T with freezing heating - real(kind_phys) totfrz(ncol) - real(kind_phys) frz (ncol,pver) ! rate of freezing - integer jto(ncol) ! updraft plume old top - integer tmplel(ncol) - - integer iter, itnum - integer m - - integer khighest - integer klowest - integer kount - integer i,k - - logical doit(ncol) - logical done(ncol) -! -!------------------------------------------------------------------------------ -! - do i = 1,il2g - ftemp(i) = 0._kind_phys - expnum(i) = 0._kind_phys - expdif(i) = 0._kind_phys - c0mask(i) = c0_ocn * (1._kind_phys-landfrac(i)) + c0_lnd * landfrac(i) - if(tht_tweaks) then - tiedke_msk(i)=tiedke_add* (1._kind_phys-landfrac(i)) + tiedke_lnd* landfrac(i) - else - tiedke_msk(i)=tiedke_add - endif - end do -! -!jr Change from msg+1 to 1 to prevent blowup -! - do k = 1,pver - do i = 1,il2g - dz(i,k) = zf(i,k) - zf(i,k+1) - end do - end do - -! -! initialize many output and work variables to zero -! - !pflx(:il2g,1) = 0 - - do k = 1,pver - do i = 1,il2g - k1(i,k) = 0._kind_phys - i2(i,k) = 0._kind_phys - i3(i,k) = 0._kind_phys - i4(i,k) = 0._kind_phys - mu(i,k) = 0._kind_phys - f(i,k) = 0._kind_phys - eps(i,k) = 0._kind_phys - eu(i,k) = 0._kind_phys - du(i,k) = 0._kind_phys - ql(i,k) = 0._kind_phys - cu(i,k) = 0._kind_phys - evp(i,k) = 0._kind_phys - cmeg(i,k) = 0._kind_phys - qds(i,k) = q(i,k) - md(i,k) = 0._kind_phys - ed(i,k) = 0._kind_phys - sd(i,k) = s(i,k) - qd(i,k) = q(i,k) - mc(i,k) = 0._kind_phys - qu(i,k) = q(i,k) - su(i,k) = s(i,k) - call qsat_hPa(t(i,k), p(i,k), est(i), qst(i,k)) - - if ( p(i,k)-est(i) <= 0._kind_phys ) then - qst(i,k) = 1.0_kind_phys - end if -!tht moist thermo - mrd(i,k) = (1._kind_phys+zv*q(i,k))*rd - mcp(i,k) = (1._kind_phys+cpv*q(i,k))*cp - mrl(i,k) = (1._kind_phys-dcol*(t(i,k)-tfreez))*rl - gamma(i,k) = qst(i,k)*(1._kind_phys + qst(i,k)/eps1)*eps1*mrl(i,k)/(mrd(i,k)*t(i,k)**2)*mrl(i,k)/mcp(i,k) - hmn (i,k) = mcp(i,k)*t(i,k) + grav*z(i,k) + mrl(i,k)*q(i,k) - hsat (i,k) = mcp(i,k)*t(i,k) + grav*z(i,k) + mrl(i,k)*qst(i,k) -!-tht - hu(i,k) = hmn(i,k) - hd(i,k) = hmn(i,k) - rprd(i,k) = 0._kind_phys - - !fice(i,k) = 0._kind_phys - tug(i,k) = 0._kind_phys - qcde(i,k) = 0._kind_phys -!+tht moist thermo - if(tht_tweaks) then - tvuo(i,k) = (shat(i,k) - grav/mcp(i,k)*zf(i,k))*(1._kind_phys+(1._kind_phys/eps1-1._kind_phys)*qhat(i,k)) - else - tvuo(i,k) = (shat(i,k) - grav/cp*zf(i,k))*(1._kind_phys + 0.608_kind_phys*qhat(i,k)) - endif -!-tht - tvu(i,k) = tvuo(i,k) - frz(i,k) = 0._kind_phys -!+tht moist thermo - td(i,k) = (hd(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qds(i,k)) & - /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qds(i,k) )) -!-tht - end do - end do -! -!jr Set to zero things which make this routine blow up -! - do k=1,msg - do i=1,il2g - rprd(i,k) = 0._kind_phys - end do - end do -! -! interpolate the layer values of qst, hsat and gamma to -! layer interfaces -! - do k = 1, msg+1 - do i = 1,il2g - hsthat(i,k) = hsat(i,k) - qsthat(i,k) = qst(i,k) - gamhat(i,k) = gamma(i,k) - end do - end do - do i = 1,il2g - totpcp(i) = 0._kind_phys - totevp(i) = 0._kind_phys - end do - do k = msg + 2,pver - do i = 1,il2g - if (abs(qst(i,k-1)-qst(i,k)) > 1.E-6_kind_phys) then - qsthat(i,k) = log(qst(i,k-1)/qst(i,k))*qst(i,k-1)*qst(i,k)/ (qst(i,k-1)-qst(i,k)) - else - qsthat(i,k) = qst(i,k) - end if -!+tht moist thermo - hsthat(i,k) = mcp(i,k)*shat(i,k) +mrl(i,k)*qsthat(i,k) -!-tht - if (abs(gamma(i,k-1)-gamma(i,k)) > 1.E-6_kind_phys) then - gamhat(i,k) = log(gamma(i,k-1)/gamma(i,k))*gamma(i,k-1)*gamma(i,k)/ & - (gamma(i,k-1)-gamma(i,k)) - else - gamhat(i,k) = gamma(i,k) - end if - end do - end do -! -! initialize cloud top to highest plume top. -!jr changed hard-wired 4 to limcnv+1 (not to exceed pver) -! - jt(:) = pver - do i = 1,il2g - jt(i) = max(lel(i),limcnv+1) - jt(i) = min(jt(i),pver) - jd(i) = pver - jlcl(i) = lel(i) - hmin(i) = 1.E6_kind_phys - end do -! -! find the level of minimum hsat, where detrainment starts -! - - do k = msg + 1,pver - do i = 1,il2g - if (hsat(i,k) <= hmin(i) .and. k >= jt(i) .and. k <= jb(i)) then - hmin(i) = hsat(i,k) - j0(i) = k - end if - end do - end do - do i = 1,il2g - j0(i) = min(j0(i),jb(i)-2) - j0(i) = max(j0(i),jt(i)+2) -! -! Fix from Guang Zhang to address out of bounds array reference -! - j0(i) = min(j0(i),pver) - end do -! -! Initialize certain arrays inside cloud -! - do k = msg + 1,pver - do i = 1,il2g - if (k >= jt(i) .and. k <= jb(i)) then -!+tht moist thermo - uniform perturbation either in h or in s - hu(i,k) = hmn(i,mx(i)) + mcp(i,k)*tiedke_msk(i) - su(i,k) = s(i,mx(i)) + tiedke_msk(i)/(1._kind_phys+cpv*qu(i,k)) -!-tht - end if - end do - end do -! -! ********************************************************* -! compute taylor series for approximate eps(z) below -! ********************************************************* -! - do k = pver - 1,msg + 1,-1 - do i = 1,il2g - if (k < jb(i) .and. k >= jt(i)) then - k1(i,k) = k1(i,k+1) + (hmn(i,mx(i))-hmn(i,k))*dz(i,k) - ihat(i,k) = 0.5_kind_phys* (k1(i,k+1)+k1(i,k)) - i2(i,k) = i2(i,k+1) + ihat(i,k)*dz(i,k) - idag(i,k) = 0.5_kind_phys* (i2(i,k+1)+i2(i,k)) - i3(i,k) = i3(i,k+1) + idag(i,k)*dz(i,k) - iprm(i,k) = 0.5_kind_phys* (i3(i,k+1)+i3(i,k)) - i4(i,k) = i4(i,k+1) + iprm(i,k)*dz(i,k) - end if - end do - end do -! -! re-initialize hmin array for ensuing calculation. -! - do i = 1,il2g - hmin(i) = 1.E6_kind_phys - end do - do k = msg + 1,pver - do i = 1,il2g - if (k >= j0(i) .and. k <= jb(i) .and. hmn(i,k) <= hmin(i)) then - hmin(i) = hmn(i,k) - expdif(i) = hmn(i,mx(i)) - hmin(i) - end if - end do - end do -! -! ********************************************************* -! compute approximate eps(z) using above taylor series -! ********************************************************* -! - do k = msg + 2,pver - do i = 1,il2g - expnum(i) = 0._kind_phys - ftemp(i) = 0._kind_phys - if (k < jt(i) .or. k >= jb(i)) then - k1(i,k) = 0._kind_phys - expnum(i) = 0._kind_phys - else - expnum(i) = hmn(i,mx(i)) - (hsat(i,k-1)*(zf(i,k)-z(i,k)) + & - hsat(i,k)* (z(i,k-1)-zf(i,k)))/(z(i,k-1)-z(i,k)) - end if - if ((expdif(i) > 100._kind_phys .and. expnum(i) > 0._kind_phys) .and. & - k1(i,k) > expnum(i)*dz(i,k)) then - ftemp(i) = expnum(i)/k1(i,k) - f(i,k) = ftemp(i) + i2(i,k)/k1(i,k)*ftemp(i)**2 + & - (2._kind_phys*i2(i,k)**2-k1(i,k)*i3(i,k))/k1(i,k)**2* & - ftemp(i)**3 + (-5._kind_phys*k1(i,k)*i2(i,k)*i3(i,k)+ & - 5._kind_phys*i2(i,k)**3+k1(i,k)**2*i4(i,k))/ & - k1(i,k)**3*ftemp(i)**4 - f(i,k) = max(f(i,k),0._kind_phys) - f(i,k) = min(f(i,k),entrmn) !tht: maximum entr. rate (lambda_0 in paper) - end if - end do - end do - do i = 1,il2g - if (j0(i) < jb(i)) then - if (f(i,j0(i)) < 1.E-6_kind_phys .and. f(i,j0(i)+1) > f(i,j0(i))) j0(i) = j0(i) + 1 - end if - end do - do k = msg + 2,pver - do i = 1,il2g - if (k >= jt(i) .and. k <= j0(i)) then - f(i,k) = max(f(i,k),f(i,k-1)) - end if - end do - end do - do i = 1,il2g - eps0(i) = f(i,j0(i)) - eps(i,jb(i)) = eps0(i) - end do -! -! This is set to match the Rasch and Kristjansson paper -! - do k = pver,msg + 1,-1 - do i = 1,il2g - if (k >= j0(i) .and. k <= jb(i)) then - eps(i,k) = f(i,j0(i)) - end if - end do - end do - do k = pver,msg + 1,-1 - do i = 1,il2g - if (k < j0(i) .and. k >= jt(i)) eps(i,k) = f(i,k) - end do - end do - - itnum = 1 - do iter=1, itnum - -! -! specify the updraft mass flux mu, entrainment eu, detrainment du -! and moist static energy hu. -! here and below mu, eu,du, md and ed are all normalized by mb -! - do i = 1,il2g - if (eps0(i) > 0._kind_phys) then - mu(i,jb(i)) = 1._kind_phys - eu(i,jb(i)) = mu(i,jb(i))/dz(i,jb(i)) - end if - tmplel(i) = jt(i) - end do - do k = pver,msg + 1,-1 - do i = 1,il2g - if (eps0(i) > 0._kind_phys .and. (k >= tmplel(i) .and. k < jb(i))) then - zuef(i) = zf(i,k) - zf(i,jb(i)) - rmue(i) = (1._kind_phys/eps0(i))* (exp(eps(i,k+1)*zuef(i))-1._kind_phys)/zuef(i) - mu(i,k) = (1._kind_phys/eps0(i))* (exp(eps(i,k )*zuef(i))-1._kind_phys)/zuef(i) - eu(i,k) = (rmue(i)-mu(i,k+1))/dz(i,k) - du(i,k) = (rmue(i)-mu(i,k))/dz(i,k) - end if - end do - end do - - khighest = pverp - klowest = 1 - do i=1,il2g - khighest = min(khighest,lel(i)) - klowest = max(klowest,jb(i)) - end do - do k = klowest-1,khighest,-1 - do i = 1,il2g - if (k <= jb(i)-1 .and. k >= lel(i) .and. eps0(i) > 0._kind_phys) then - if (mu(i,k) < 0.02_kind_phys) then - hu(i,k) = hmn(i,k) - mu(i,k) = 0._kind_phys - eu(i,k) = 0._kind_phys - du(i,k) = mu(i,k+1)/dz(i,k) - else - hu(i,k) = mu(i,k+1)/mu(i,k)*hu(i,k+1) + & - dz(i,k)/mu(i,k)* (eu(i,k)*hmn(i,k)- du(i,k)*hsat(i,k)) - end if - end if - end do - end do -! -! reset cloud top index beginning from two layers above the -! cloud base (i.e. if cloud is only one layer thick, top is not reset -! - do i=1,il2g - doit(i) = .true. - totfrz(i)= 0._kind_phys - do k = pver,msg + 1,-1 - totfrz(i)= totfrz(i)+ frz(i,k)*dz(i,k) - end do - end do - do k=klowest-2,khighest-1,-1 - do i=1,il2g - if (doit(i) .and. k <= jb(i)-2 .and. k >= lel(i)-1) then - if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & - .and. mu(i,k) >= 0.02_kind_phys) then - if (hu(i,k)-hsthat(i,k) < -2000._kind_phys) then - jt(i) = k + 1 - doit(i) = .false. - else - jt(i) = k - doit(i) = .false. - end if - else if ( (hu(i,k) > hu(i,jb(i)) .and. totfrz(i)<=0._kind_phys) .or. mu(i,k) < 0.02_kind_phys) then - jt(i) = k + 1 - doit(i) = .false. - end if - end if - end do - end do - - if (iter == 1) jto(:) = jt(:) - - do k = pver,msg + 1,-1 - do i = 1,il2g - if (k >= lel(i) .and. k <= jt(i) .and. eps0(i) > 0._kind_phys) then - mu(i,k) = 0._kind_phys - eu(i,k) = 0._kind_phys - du(i,k) = 0._kind_phys - hu(i,k) = hmn(i,k) - end if - if (k == jt(i) .and. eps0(i) > 0._kind_phys) then - du(i,k) = mu(i,k+1)/dz(i,k) - eu(i,k) = 0._kind_phys - mu(i,k) = 0._kind_phys - end if - end do - end do - -!+tht initialise tu (moist thermo) - do k = pver,msg + 2,-1 - do i = 1,il2g - tu(i,k) = (hu(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qu(i,k)) & - /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qu(i,k) )) - end do - end do -!-tht - do i = 1,il2g - done(i) = .false. - end do - kount = 0 - do k = pver,msg + 2,-1 - do i = 1,il2g - if (k == jb(i) .and. eps0(i) > 0._kind_phys) then - qu(i,k) = q(i,mx(i)) -!+tht moist thermo - tu(i,k) = (hu(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qu(i,k)) & - /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qu(i,k) )) - su(i,k) = (hu(i,k)-(1._kind_phys-dcol*(tu(i,k)-tfreez))*rl*qu(i,k)) & - /((1._kind_phys+cpv*qu(i,k))*cp) -!-tht - end if - if (( .not. done(i) .and. k > jt(i) .and. k < jb(i)) .and. eps0(i) > 0._kind_phys) then - su(i,k) = mu(i,k+1)/mu(i,k)*su(i,k+1) + & - dz(i,k)/mu(i,k)* (eu(i,k)-du(i,k))*s(i,k) - qu(i,k) = mu(i,k+1)/mu(i,k)*qu(i,k+1) + dz(i,k)/mu(i,k)* (eu(i,k)*q(i,k)- & - du(i,k)*qst(i,k)) -!+tht moist thermo - tu(i,k) = su(i,k) - grav/((1._kind_phys+cpv*qu(i,k))*cp)*zf(i,k) - call qsat_hPa(tu(i,k), (p(i,k)+p(i,k-1))/2._kind_phys, estu, qstu) -!-tht - if (qu(i,k) >= qstu) then - jlcl(i) = k - kount = kount + 1 - done(i) = .true. - end if - end if - end do - if (kount >= il2g) goto 690 - end do -690 continue - do k = msg + 2,pver - do i = 1,il2g - if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._kind_phys) then -!+tht moist thermo - qu(i,k) = qsthat(i,k) + gamhat(i,k)*(hu(i,k)-hsthat(i,k))/ & - ((1._kind_phys-dcol*(tu(i,k)-tfreez))*rl* (1._kind_phys+gamhat(i,k))) - su(i,k) = shat(i,k) + (hu(i,k)-hsthat(i,k))/((1._kind_phys+cpv*qu(i,k))*cp* (1._kind_phys+gamhat(i,k))) - tu(i,k) = su(i,k) - grav/((1._kind_phys+cpv*qu(i,k))*cp)*zf(i,k) -!-tht - end if - end do - end do - -! compute condensation in updraft - tmplel(:il2g) = jb(:il2g) - - do k = pver,msg + 2,-1 - do i = 1,il2g - if (k >= jt(i) .and. k < tmplel(i) .and. eps0(i) > 0._kind_phys) then -!+tht moist thermo - cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ & - dz(i,k)- (eu(i,k)-du(i,k))*s(i,k))/(rl/cp) & - *((1._kind_phys+cpv*qu(i,k))/(1._kind_phys-dcol*(tu(i,k)-tfreez))) -!-tht - if (k == jt(i)) cu(i,k) = 0._kind_phys - cu(i,k) = max(0._kind_phys,cu(i,k)) - end if - end do - end do - - -! compute condensed liquid, rain production rate -! accumulate total precipitation (condensation - detrainment of liquid) -! Note ql1 = ql(k) + rprd(k)*dz(k)/mu(k) -! The differencing is somewhat strange (e.g. du(i,k)*ql(i,k+1)) but is -! consistently applied. -! mu, ql are interface quantities -! cu, du, eu, rprd are midpoint quantites - - do k = pver,msg + 2,-1 - do i = 1,il2g - rprd(i,k) = 0._kind_phys - if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._kind_phys .and. mu(i,k) >= 0.0_kind_phys) then - if (mu(i,k) > 0._kind_phys) then - ql1 = 1._kind_phys/mu(i,k)* (mu(i,k+1)*ql(i,k+1)- & - dz(i,k)*du(i,k)*ql(i,k+1)+dz(i,k)*cu(i,k)) - ql(i,k) = ql1/ (1._kind_phys+dz(i,k)*c0mask(i)) - else - ql(i,k) = 0._kind_phys - end if - totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*ql(i,k+1)) - rprd(i,k) = c0mask(i)*mu(i,k)*ql(i,k) - qcde(i,k) = ql(i,k) - end if - end do - end do -! - end do !iter -! -! specify downdraft properties (no downdrafts if jd.ge.jb). -! scale down downward mass flux profile so that net flux -! (up-down) at cloud base in not negative. -! - do i = 1,il2g -! -! in normal downdraft strength run alfa=0.2. In test4 alfa=0.1 -! - alfa(i) = alfadet !tht: detrainment proportionality factor (alpha in paper) - jt(i) = min(jt(i),jb(i)-1) - jd(i) = max(j0(i),jt(i)+1) - jd(i) = min(jd(i),jb(i)) - hd(i,jd(i)) = hmn(i,jd(i)-1) - if (jd(i) < jb(i) .and. eps0(i) > 0._kind_phys) then - epsm(i) = eps0(i) - md(i,jd(i)) = -alfa(i)*epsm(i)/eps0(i) - end if - end do - do k = msg + 1,pver - do i = 1,il2g - if ((k > jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._kind_phys) then - zdef(i) = zf(i,jd(i)) - zf(i,k) -!tht: why the factor 2 here? - md(i,k) = -alfa(i)/ (2._kind_phys*eps0(i))*(exp(2._kind_phys*epsm(i)*zdef(i))-1._kind_phys)/zdef(i) - end if - end do - end do - - do k = msg + 1,pver - do i = 1,il2g - if ((k >= jt(i) .and. k <= jb(i)) .and. eps0(i) > 0._kind_phys .and. jd(i) < jb(i)) then - ratmjb(i) = min(abs(mu(i,jb(i))/md(i,jb(i))),1._kind_phys) - md(i,k) = md(i,k)*ratmjb(i) - end if - end do - end do - - small = 1.e-20_kind_phys - do k = msg + 1,pver - do i = 1,il2g - if ((k >= jt(i) .and. k <= pver) .and. eps0(i) > 0._kind_phys) then - ed(i,k-1) = (md(i,k-1)-md(i,k))/dz(i,k-1) - mdt = min(md(i,k),-small) - hd(i,k) = (md(i,k-1)*hd(i,k-1) - dz(i,k-1)*ed(i,k-1)*hmn(i,k-1))/mdt - end if - end do - end do -! -! calculate updraft and downdraft properties. -! - do k = msg + 2,pver - do i = 1,il2g - if ((k >= jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._kind_phys .and. jd(i) < jb(i)) then - qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & - (rl*(1._kind_phys + gamhat(i,k))) -!+tht moist thermo - td(i,k) = (hd(i,k)-grav*zf(i,k)-(1._kind_phys+dcol*tfreez)*rl*qds(i,k)) & - /(cp*( 1._kind_phys + (cpv-dcol*(rl/cp))*qds(i,k) )) - qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & - ((1._kind_phys-dcol*(td(i,k)-tfreez))*rl*(1._kind_phys + gamhat(i,k))) -!-tht - end if - end do - end do - - do i = 1,il2g - qd(i,jd(i)) = qds(i,jd(i)) -!+tht moist thermo - k=jd(i) - sd(i,k) = (hd(i,k) - (1._kind_phys-dcol*(td(i,k)-tfreez))*rl*qd(i,k))/((1._kind_phys+cpv*qd(i,k))*cp) - td(i,k) = sd(i,k) - grav/((1._kind_phys+cpv*qd(i,k))*cp)*zf(i,k) -!-tht - end do -! - do k = msg + 2,pver - do i = 1,il2g - if (k >= jd(i) .and. k < jb(i) .and. eps0(i) > 0._kind_phys) then - qd(i,k+1) = qds(i,k+1) - evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k)-md(i,k+1)*qd(i,k+1))/dz(i,k) - evp(i,k) = max(evp(i,k),0._kind_phys) - mdt = min(md(i,k+1),-small) -!+tht moist thermo - sd(i,k+1) = (((1._kind_phys-dcol*(td(i,k)-tfreez))*rl/((1._kind_phys+cpv*qd(i,k))*cp)*evp(i,k) & - -ed(i,k)*s(i,k))*dz(i,k) + md(i,k)*sd(i,k))/mdt -!-tht - totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) - end if - end do - end do - do i = 1,il2g - totevp(i) = totevp(i) + md(i,jd(i))*qd(i,jd(i)) - md(i,jb(i))*qd(i,jb(i)) - end do -!!$ if (.true.) then - if (.false.) then - do i = 1,il2g - k = jb(i) - if (eps0(i) > 0._kind_phys) then - evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k))/dz(i,k) - evp(i,k) = max(evp(i,k),0._kind_phys) - totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) - end if - end do - endif - - do i = 1,il2g - totpcp(i) = max(totpcp(i),0._kind_phys) - totevp(i) = max(totevp(i),0._kind_phys) - end do -! - do k = msg + 2,pver - do i = 1,il2g - if (totevp(i) > 0._kind_phys .and. totpcp(i) > 0._kind_phys) then - md(i,k) = md (i,k)*min(1._kind_phys, totpcp(i)/(totevp(i)+totpcp(i))) - ed(i,k) = ed (i,k)*min(1._kind_phys, totpcp(i)/(totevp(i)+totpcp(i))) - evp(i,k) = evp(i,k)*min(1._kind_phys, totpcp(i)/(totevp(i)+totpcp(i))) - else - md(i,k) = 0._kind_phys - ed(i,k) = 0._kind_phys - evp(i,k) = 0._kind_phys - end if -! cmeg is the cloud water condensed - rain water evaporated -! rprd is the cloud water converted to rain - (rain evaporated) - cmeg(i,k) = cu(i,k) - evp(i,k) - rprd(i,k) = rprd(i,k)-evp(i,k) - end do - end do - -! - do k = msg + 1,pver - do i = 1,il2g - mc(i,k) = mu(i,k) + md(i,k) - end do - end do -! - return -end subroutine cldprp - -subroutine closure(ncol ,pver, & - q ,t ,p ,z ,s , & - tp ,qs ,qu ,su ,mc , & - du ,mu ,md ,qd ,sd , & - qhat ,shat ,dp ,qstp ,zf , & - ql ,dsubcld ,mb ,cape ,tl , & - lcl ,lel ,jt ,mx ,il1g , & - il2g ,rd ,grav ,cp ,rl , & - msg ,capelmt ) -! -!-----------------------------Arguments--------------------------------- -! - integer, intent(in) :: ncol - integer, intent(in) :: pver - - real(kind_phys), intent(inout) :: q(ncol,pver) ! spec humidity - real(kind_phys), intent(inout) :: t(ncol,pver) ! temperature - real(kind_phys), intent(inout) :: p(ncol,pver) ! pressure (mb) - real(kind_phys), intent(inout) :: mb(ncol) ! cloud base mass flux - real(kind_phys), intent(in) :: z(ncol,pver) ! height (m) - real(kind_phys), intent(in) :: s(ncol,pver) ! normalized dry static energy - real(kind_phys), intent(in) :: tp(ncol,pver) ! parcel temp - real(kind_phys), intent(in) :: qs(ncol,pver) ! sat spec humidity - real(kind_phys), intent(in) :: qu(ncol,pver) ! updraft spec. humidity - real(kind_phys), intent(in) :: su(ncol,pver) ! normalized dry stat energy of updraft - real(kind_phys), intent(in) :: mc(ncol,pver) ! net convective mass flux - real(kind_phys), intent(in) :: du(ncol,pver) ! detrainment from updraft - real(kind_phys), intent(in) :: mu(ncol,pver) ! mass flux of updraft - real(kind_phys), intent(in) :: md(ncol,pver) ! mass flux of downdraft - real(kind_phys), intent(in) :: qd(ncol,pver) ! spec. humidity of downdraft - real(kind_phys), intent(in) :: sd(ncol,pver) ! dry static energy of downdraft - real(kind_phys), intent(in) :: qhat(ncol,pver) ! environment spec humidity at interfaces - real(kind_phys), intent(in) :: shat(ncol,pver) ! env. normalized dry static energy at intrfcs - real(kind_phys), intent(in) :: dp(ncol,pver) ! pressure thickness of layers - real(kind_phys), intent(in) :: qstp(ncol,pver) ! spec humidity of parcel - real(kind_phys), intent(in) :: zf(ncol,pver+1) ! height of interface levels - real(kind_phys), intent(in) :: ql(ncol,pver) ! liquid water mixing ratio - - real(kind_phys), intent(in) :: cape(ncol) ! available pot. energy of column - real(kind_phys), intent(in) :: tl(ncol) - real(kind_phys), intent(in) :: dsubcld(ncol) ! thickness of subcloud layer - - integer, intent(in) :: lcl(ncol) ! index of lcl - integer, intent(in) :: lel(ncol) ! index of launch leve - integer, intent(in) :: jt(ncol) ! top of updraft - integer, intent(in) :: mx(ncol) ! base of updraft -! -!--------------------------Local variables------------------------------ -! - real(kind_phys) dtpdt(ncol,pver) - real(kind_phys) dqsdtp(ncol,pver) - real(kind_phys) dtmdt(ncol,pver) - real(kind_phys) dqmdt(ncol,pver) - real(kind_phys) dboydt(ncol,pver) - real(kind_phys) thetavp(ncol,pver) - real(kind_phys) thetavm(ncol,pver) - - real(kind_phys) dtbdt(ncol),dqbdt(ncol),dtldt(ncol) - real(kind_phys) beta - real(kind_phys) capelmt - real(kind_phys) cp - real(kind_phys) dadt(ncol) - real(kind_phys) debdt - real(kind_phys) dltaa - real(kind_phys) eb - real(kind_phys) grav - - integer i - integer il1g - integer il2g - integer k, kmin, kmax - integer msg - - real(kind_phys) rd - real(kind_phys) rl - !real(kind_phys) rltp !tht - -! change of subcloud layer properties due to convection is -! related to cumulus updrafts and downdrafts. -! mc(z)=f(z)*mb, mub=betau*mb, mdb=betad*mb are used -! to define betau, betad and f(z). -! note that this implies all time derivatives are in effect -! time derivatives per unit cloud-base mass flux, i.e. they -! have units of 1/mb instead of 1/sec. -! - do i = il1g,il2g - mb(i) = 0._kind_phys - eb = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i))) - dtbdt(i) = (1._kind_phys/dsubcld(i))* (mu(i,mx(i))*(shat(i,mx(i))-su(i,mx(i)))+ & - md(i,mx(i))* (shat(i,mx(i))-sd(i,mx(i)))) - dqbdt(i) = (1._kind_phys/dsubcld(i))* (mu(i,mx(i))*(qhat(i,mx(i))-qu(i,mx(i)))+ & - md(i,mx(i))* (qhat(i,mx(i))-qd(i,mx(i)))) - debdt = eps1*p(i,mx(i))/ (eps1+q(i,mx(i)))**2*dqbdt(i) - dtldt(i) = -2840._kind_phys* (3.5_kind_phys/t(i,mx(i))*dtbdt(i)-debdt/eb)/ & - (3.5_kind_phys*log(t(i,mx(i)))-log(eb)-4.805_kind_phys)**2 - end do -! -! dtmdt and dqmdt are cumulus heating and drying. -! - do k = msg + 1,pver - do i = il1g,il2g - dtmdt(i,k) = 0._kind_phys - dqmdt(i,k) = 0._kind_phys - end do - end do -! - do k = msg + 1,pver - 1 - do i = il1g,il2g - if (k == jt(i)) then - dtmdt(i,k) = (1._kind_phys/dp(i,k))*(mu(i,k+1)* (su(i,k+1)-shat(i,k+1)- & - rl/cp*ql(i,k+1))+md(i,k+1)* (sd(i,k+1)-shat(i,k+1))) - dqmdt(i,k) = (1._kind_phys/dp(i,k))*(mu(i,k+1)* (qu(i,k+1)- & - qhat(i,k+1)+ql(i,k+1))+md(i,k+1)*(qd(i,k+1)-qhat(i,k+1))) - end if - end do - end do -! - beta = 0._kind_phys - do k = msg + 1,pver - 1 - do i = il1g,il2g - if (k > jt(i) .and. k < mx(i)) then - dtmdt(i,k) = (mc(i,k)* (shat(i,k)-s(i,k))+mc(i,k+1)* (s(i,k)-shat(i,k+1)))/ & - dp(i,k) - rl/cp*du(i,k)*(beta*ql(i,k)+ (1-beta)*ql(i,k+1)) - - dqmdt(i,k) = (mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)+cp/rl* (su(i,k+1)-s(i,k)))- & - mu(i,k)* (qu(i,k)-qhat(i,k)+cp/rl*(su(i,k)-s(i,k)))+md(i,k+1)* & - (qd(i,k+1)-qhat(i,k+1)+cp/rl*(sd(i,k+1)-s(i,k)))-md(i,k)* & - (qd(i,k)-qhat(i,k)+cp/rl*(sd(i,k)-s(i,k))))/dp(i,k) + & - du(i,k)* (beta*ql(i,k)+(1-beta)*ql(i,k+1)) - end if - end do - end do -! - do k = msg + 1,pver - do i = il1g,il2g - if (k >= lel(i) .and. k <= lcl(i)) then - thetavp(i,k) = tp(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+1.608_kind_phys*qstp(i,k)-q(i,mx(i))) - thetavm(i,k) = t(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+0.608_kind_phys*q(i,k)) - dqsdtp(i,k) = qstp(i,k)* (1._kind_phys+qstp(i,k)/eps1)*eps1*rl/(rd*tp(i,k)**2) -! -! dtpdt is the parcel temperature change due to change of -! subcloud layer properties during convection. -! - dtpdt(i,k) = tp(i,k)/ (1._kind_phys+rl/cp* (dqsdtp(i,k)-qstp(i,k)/tp(i,k)))* & - (dtbdt(i)/t(i,mx(i))+rl/cp* (dqbdt(i)/tl(i)-q(i,mx(i))/ & - tl(i)**2*dtldt(i))) -! -! dboydt is the integrand of cape change. -! - dboydt(i,k) = ((dtpdt(i,k)/tp(i,k)+1._kind_phys/(1._kind_phys+1.608_kind_phys*qstp(i,k)-q(i,mx(i)))* & - (1.608_kind_phys * dqsdtp(i,k) * dtpdt(i,k) -dqbdt(i))) - (dtmdt(i,k)/t(i,k)+0.608_kind_phys/ & - (1._kind_phys+0.608_kind_phys*q(i,k))*dqmdt(i,k)))*grav*thetavp(i,k)/thetavm(i,k) - end if - end do - end do -! - do k = msg + 1,pver - do i = il1g,il2g - if (k > lcl(i) .and. k < mx(i)) then - thetavp(i,k) = tp(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+0.608_kind_phys*q(i,mx(i))) - thetavm(i,k) = t(i,k)* (1000._kind_phys/p(i,k))** (rd/cp)*(1._kind_phys+0.608_kind_phys*q(i,k)) -! -! dboydt is the integrand of cape change. -! - dboydt(i,k) = (dtbdt(i)/t(i,mx(i))+0.608_kind_phys/ (1._kind_phys+0.608_kind_phys*q(i,mx(i)))*dqbdt(i)- & - dtmdt(i,k)/t(i,k)-0.608_kind_phys/ (1._kind_phys+0.608_kind_phys*q(i,k))*dqmdt(i,k))* & - grav*thetavp(i,k)/thetavm(i,k) - end if - end do - end do - -! -! buoyant energy change is set to 2/3*excess cape per 3 hours -! - dadt(il1g:il2g) = 0._kind_phys - kmin = minval(lel(il1g:il2g)) - kmax = maxval(mx(il1g:il2g)) - 1 - do k = kmin, kmax - do i = il1g,il2g - if ( k >= lel(i) .and. k <= mx(i) - 1) then - dadt(i) = dadt(i) + dboydt(i,k)* (zf(i,k)-zf(i,k+1)) - endif - end do - end do - do i = il1g,il2g - dltaa = -1._kind_phys* (cape(i)-capelmt) - if (dadt(i) /= 0._kind_phys) mb(i) = max(dltaa/tau/dadt(i),0._kind_phys) - end do -! - return -end subroutine closure - -subroutine q1q2_pjr(ncol ,pver ,latice ,& - dqdt ,dsdt ,q ,qs ,qu , & - su ,du ,qhat ,shat ,dp , & - mu ,md ,sd ,qd ,ql , & - dsubcld ,jt ,mx ,il1g ,il2g , & - cp ,rl ,msg , & - dl ,evp ,cu) - - implicit none - -!----------------------------------------------------------------------- -! Purpose: -! compute temperature and moisture changes due to convection. -!----------------------------------------------------------------------- - - - real(kind_phys), intent(in) :: cp - - integer, intent(in) :: ncol - integer, intent(in) :: pver - real(kind_phys), intent(in) :: latice - integer, intent(in) :: il1g - integer, intent(in) :: il2g - integer, intent(in) :: msg - - real(kind_phys), intent(in) :: q(ncol,pver) - real(kind_phys), intent(in) :: qs(ncol,pver) - real(kind_phys), intent(in) :: qu(ncol,pver) - real(kind_phys), intent(in) :: su(ncol,pver) - real(kind_phys), intent(in) :: du(ncol,pver) - real(kind_phys), intent(in) :: qhat(ncol,pver) - real(kind_phys), intent(in) :: shat(ncol,pver) - real(kind_phys), intent(in) :: dp(ncol,pver) - real(kind_phys), intent(in) :: mu(ncol,pver) - real(kind_phys), intent(in) :: md(ncol,pver) - real(kind_phys), intent(in) :: sd(ncol,pver) - real(kind_phys), intent(in) :: qd(ncol,pver) - real(kind_phys), intent(in) :: ql(ncol,pver) - real(kind_phys), intent(in) :: evp(ncol,pver) - real(kind_phys), intent(in) :: cu(ncol,pver) - real(kind_phys), intent(in) :: dsubcld(ncol) - - real(kind_phys),intent(out) :: dqdt(ncol,pver),dsdt(ncol,pver) - real(kind_phys),intent(out) :: dl(ncol,pver) - - integer kbm - integer ktm - integer jt(ncol) - integer mx(ncol) -! -! work fields: -! - integer i - integer k - - real(kind_phys) emc - real(kind_phys) rl -!------------------------------------------------------------------- - do k = msg + 1,pver - do i = il1g,il2g - dsdt(i,k) = 0._kind_phys - dqdt(i,k) = 0._kind_phys - dl(i,k) = 0._kind_phys - end do - end do - -! -! find the highest level top and bottom levels of convection -! - ktm = pver - kbm = pver - do i = il1g, il2g - ktm = min(ktm,jt(i)) - kbm = min(kbm,mx(i)) - end do - - do k = ktm,pver-1 - do i = il1g,il2g - emc = -cu (i,k) & ! condensation in updraft - +evp(i,k) ! evaporating rain in downdraft - - dsdt(i,k) = -rl/cp*emc & - + (+mu(i,k+1)* (su(i,k+1)-shat(i,k+1)) & - -mu(i,k)* (su(i,k)-shat(i,k)) & - +md(i,k+1)* (sd(i,k+1)-shat(i,k+1)) & - -md(i,k)* (sd(i,k)-shat(i,k)) & - )/dp(i,k) - - dqdt(i,k) = emc + & - (+mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)) & - -mu(i,k)* (qu(i,k)-qhat(i,k)) & - +md(i,k+1)* (qd(i,k+1)-qhat(i,k+1)) & - -md(i,k)* (qd(i,k)-qhat(i,k)) & - )/dp(i,k) - - dl(i,k) = du(i,k)*ql(i,k+1) - - end do - end do - -! - do k = kbm,pver - do i = il1g,il2g - if (k == mx(i)) then - dsdt(i,k) = (1._kind_phys/dsubcld(i))* & - (-mu(i,k)* (su(i,k)-shat(i,k)) & - -md(i,k)* (sd(i,k)-shat(i,k)) & - ) - dqdt(i,k) = (1._kind_phys/dsubcld(i))* & - (-mu(i,k)*(qu(i,k)-qhat(i,k)) & - -md(i,k)*(qd(i,k)-qhat(i,k)) & - ) - else if (k > mx(i)) then - dsdt(i,k) = dsdt(i,k-1) - dqdt(i,k) = dqdt(i,k-1) - end if - end do - end do -! - return -end subroutine q1q2_pjr - - -! Wrapper for qsat_water that does translation between Pa and hPa -! qsat_water uses Pa internally, so get it right, need to pass in Pa. -! Afterward, set es back to hPa. -subroutine qsat_hPa(t, p, es, qm) - use wv_saturation, only: qsat_water - - ! Inputs - real(kind_phys), intent(in) :: t ! Temperature (K) - real(kind_phys), intent(in) :: p ! Pressure (hPa) - ! Outputs - real(kind_phys), intent(out) :: es ! Saturation vapor pressure (hPa) - real(kind_phys), intent(out) :: qm ! Saturation mass mixing ratio - ! (vapor mass over dry mass, kg/kg) - - call qsat_water(t, p*100._kind_phys, es, qm) - - es = es*0.01_kind_phys - -end subroutine qsat_hPa - -end module zm_convr From adb03c18d04be4416c078ff291f3ec98f1f4c567 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 17 Sep 2025 16:30:29 +0200 Subject: [PATCH 12/78] pointed to a hash of oslo_aero rather than a branch --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 84d8490460..239552841a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -77,7 +77,7 @@ [submodule "oslo_aero"] path = src/chemistry/oslo_aero url = https://github.com/mvertens/OSLO_AERO - fxtag = feature/cam_computes_enthalpy + fxtag = 2218bd9 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/OSLO_AERO.git From 9eacdc293fcd07f22b41c4dfe1e1b05e74dd1b99 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 27 Sep 2025 19:26:47 +0200 Subject: [PATCH 13/78] add dp_ntprp and dp_ntsnp back into pbuf - needed for enthalpy check_energy --- src/physics/cam/zm_conv_intr.F90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/physics/cam/zm_conv_intr.F90 b/src/physics/cam/zm_conv_intr.F90 index 5079daa7f8..65c2a3243f 100644 --- a/src/physics/cam/zm_conv_intr.F90 +++ b/src/physics/cam/zm_conv_intr.F90 @@ -60,7 +60,9 @@ module zm_conv_intr dlfzm_idx, & ! detrained convective cloud water mixing ratio. prec_dp_idx, & snow_dp_idx, & - mconzm_idx ! convective mass flux + mconzm_idx, & ! convective mass flux + dp_ntprp_idx, & ! needed in check_energy for new enthalpy + dp_ntsnp_idx ! needed in check_energy for new enthalpy real(r8), parameter :: unset_r8 = huge(1.0_r8) real(r8) :: zmconv_c0_lnd = unset_r8 @@ -134,10 +136,14 @@ subroutine zm_conv_register ! map gathered points to chunk index call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) -! Flux of precipitation from deep convection (kg/m2/s) + ! Flux of precipitation from deep convection (kg/m2/s) call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) -! Flux of snow from deep convection (kg/m2/s) + ! Needed for check_energy for new enthalpy computations + call pbuf_add_field('dp_ntprp','physpkg',dtype_r8,(/pcols,pver /),dp_ntprp_idx) + call pbuf_add_field('dp_ntsnp','physpkg',dtype_r8,(/pcols,pver /),dp_ntsnp_idx) + + ! Flux of snow from deep convection (kg/m2/s) call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) @@ -754,6 +760,9 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) + ! Needed in check_energy for new enthalpy computations + call pbuf_set_field(pbuf, dp_ntprp_idx, ntprprd) + call pbuf_set_field(pbuf, dp_ntsnp_idx, ntsnprd) ! ! Write out variables from zm_conv_evap_run ! From 1eeab2ca7ab4e6ffab582f2eaa9873a218e64c9a Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 27 Sep 2025 19:27:50 +0200 Subject: [PATCH 14/78] remove compute_enthalpy_flux as a cam namelist variable - get config variable from mediator now --- bld/build-namelist | 3 +-- bld/namelist_files/namelist_defaults_cam.xml | 3 --- bld/namelist_files/namelist_definition.xml | 16 ---------------- src/atmos_phys | 2 +- src/cpl/nuopc/atm_import_export.F90 | 7 ++++--- src/utils/air_composition.F90 | 10 ++-------- 6 files changed, 8 insertions(+), 33 deletions(-) diff --git a/bld/build-namelist b/bld/build-namelist index e128e5079c..e84445c335 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -455,8 +455,7 @@ if ($print>=2) { # Composition of air add_default($nl, 'dry_air_species'); add_default($nl, 'water_species_in_air'); -# Enthalpy flux -add_default($nl, 'compute_enthalpy_flux'); + # Spectral Element dycore my $dyn = $cfg->get('dyn'); diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 0f7da600ff..cf8f145b46 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -3020,9 +3020,6 @@ See https://github.com/NorESMhub/noresm3_dev_simulations/discussions/78 'Q','CLDLIQ','CLDICE','RAINQM','SNOWQM' 'Q','CLDLIQ','CLDICE','RAINQM','SNOWQM','GRAUQM' - - .false. - diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index f25b9e61b1..1def2ab394 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -8282,15 +8282,6 @@ Switch to apply lunar tidal tendencies to neutral winds. Default: FALSE - - - -Enthalpy flux terms explicitly computed and added in the atmosphere and -passed to an active ocean component. -Default: FALSE - - - -Enthalpy flux terms explicitly computed and added in atmosphere and -passed to MOM6 -Default: TRUE - - Date: Sat, 27 Sep 2025 19:32:47 +0200 Subject: [PATCH 15/78] cleaned comments --- src/physics/cam7/micro_pumas_cam.F90 | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/physics/cam7/micro_pumas_cam.F90 b/src/physics/cam7/micro_pumas_cam.F90 index c09c637ce3..b11ff71c8a 100644 --- a/src/physics/cam7/micro_pumas_cam.F90 +++ b/src/physics/cam7/micro_pumas_cam.F90 @@ -219,7 +219,7 @@ module micro_pumas_cam qrain_idx=-1, qsnow_idx=-1, & nrain_idx=-1, nsnow_idx=-1, & qcsedten_idx=-1, qrsedten_idx=-1, & - qisedten_idx=-1, qssedten_idx=-1, qgsedten_idx=-1, & !+tht + qisedten_idx=-1, qssedten_idx=-1, qgsedten_idx=-1, & vtrmc_idx=-1, umr_idx=-1, & vtrmi_idx=-1, ums_idx=-1, & qcsevap_idx=-1, qisevap_idx=-1 @@ -816,14 +816,12 @@ subroutine micro_pumas_cam_register call pbuf_add_field('UMS', 'physpkg', dtype_r8, (/pcols,pver/), ums_idx) call pbuf_add_field('QCSEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qcsevap_idx) call pbuf_add_field('QISEVAP', 'physpkg', dtype_r8, (/pcols,pver/), qisevap_idx) -!+tht else call pbuf_add_field('QCSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qcsedten_idx) call pbuf_add_field('QRSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qrsedten_idx) call pbuf_add_field('QISEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qisedten_idx) call pbuf_add_field('QSSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qssedten_idx) call pbuf_add_field('QGSEDTEN', 'physpkg', dtype_r8, (/pcols,pver/), qgsedten_idx) -!-tht end if end subroutine micro_pumas_cam_register @@ -1519,7 +1517,7 @@ subroutine micro_pumas_cam_init(pbuf2d) if (qrsedten_idx > 0) call pbuf_set_field(pbuf2d, qrsedten_idx, 0._r8) if (qisedten_idx > 0) call pbuf_set_field(pbuf2d, qisedten_idx, 0._r8) if (qssedten_idx > 0) call pbuf_set_field(pbuf2d, qssedten_idx, 0._r8) - if (qgsedten_idx > 0) call pbuf_set_field(pbuf2d, qgsedten_idx, 0._r8) !+tht + if (qgsedten_idx > 0) call pbuf_set_field(pbuf2d, qgsedten_idx, 0._r8) if (vtrmc_idx > 0) call pbuf_set_field(pbuf2d, vtrmc_idx, 0._r8) if (umr_idx > 0) call pbuf_set_field(pbuf2d, umr_idx, 0._r8) if (vtrmi_idx > 0) call pbuf_set_field(pbuf2d, vtrmi_idx, 0._r8) @@ -1928,7 +1926,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8) :: qrsedtenout_grid(pcols,pver) real(r8) :: qisedtenout_grid(pcols,pver) real(r8) :: qssedtenout_grid(pcols,pver) - real(r8) :: qgsedtenout_grid(pcols,pver)!+tht + real(r8) :: qgsedtenout_grid(pcols,pver) real(r8) :: vtrmcout_grid(pcols,pver) real(r8) :: umrout_grid(pcols,pver) real(r8) :: vtrmiout_grid(pcols,pver) @@ -2003,7 +2001,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8), pointer :: qrsedtenout_grid_ptr(:,:) real(r8), pointer :: qisedtenout_grid_ptr(:,:) real(r8), pointer :: qssedtenout_grid_ptr(:,:) - real(r8), pointer :: qgsedtenout_grid_ptr(:,:) !+tht + real(r8), pointer :: qgsedtenout_grid_ptr(:,:) real(r8), pointer :: vtrmcout_grid_ptr(:,:) real(r8), pointer :: umrout_grid_ptr(:,:) real(r8), pointer :: vtrmiout_grid_ptr(:,:) @@ -2269,7 +2267,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) if (qrsedten_idx > 0) call pbuf_get_field(pbuf, qrsedten_idx, qrsedtenout_grid_ptr) if (qisedten_idx > 0) call pbuf_get_field(pbuf, qisedten_idx, qisedtenout_grid_ptr) if (qssedten_idx > 0) call pbuf_get_field(pbuf, qssedten_idx, qssedtenout_grid_ptr) - if (qgsedten_idx > 0) call pbuf_get_field(pbuf, qgsedten_idx, qgsedtenout_grid_ptr) !+tht + if (qgsedten_idx > 0) call pbuf_get_field(pbuf, qgsedten_idx, qgsedtenout_grid_ptr) if (vtrmc_idx > 0) call pbuf_get_field(pbuf, vtrmc_idx, vtrmcout_grid_ptr) if (umr_idx > 0) call pbuf_get_field(pbuf, umr_idx, umrout_grid_ptr) if (vtrmi_idx > 0) call pbuf_get_field(pbuf, vtrmi_idx, vtrmiout_grid_ptr) @@ -2999,7 +2997,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) qisevapout_grid(:ncol,:top_lev-1) = 0._r8 qrsedtenout_grid(:ncol,:top_lev-1) = 0._r8 qssedtenout_grid(:ncol,:top_lev-1) = 0._r8 - qgsedtenout_grid(:ncol,:top_lev-1) = 0._r8 !+tht + qgsedtenout_grid(:ncol,:top_lev-1) = 0._r8 umrout_grid(:ncol,:top_lev-1) = 0._r8 umsout_grid(:ncol,:top_lev-1) = 0._r8 psacro_grid(:ncol,:top_lev-1) = 0._r8 @@ -3090,7 +3088,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) ns_grid = state_loc%q(:,:,ixnumsnow) qrsedtenout_grid(:ncol,top_lev:) = proc_rates%qrsedten qssedtenout_grid(:ncol,top_lev:) = proc_rates%qssedten - qgsedtenout_grid(:ncol,top_lev:) = proc_rates%qgsedten !+tht + qgsedtenout_grid(:ncol,top_lev:) = proc_rates%qgsedten umrout_grid(:ncol,top_lev:) = proc_rates%umr umsout_grid(:ncol,top_lev:) = proc_rates%ums @@ -3583,7 +3581,7 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) if (qrsedten_idx > 0) qrsedtenout_grid_ptr = qrsedtenout_grid if (qisedten_idx > 0) qisedtenout_grid_ptr = qisedtenout_grid if (qssedten_idx > 0) qssedtenout_grid_ptr = qssedtenout_grid - if (qgsedten_idx > 0) qgsedtenout_grid_ptr = qgsedtenout_grid !+tht + if (qgsedten_idx > 0) qgsedtenout_grid_ptr = qgsedtenout_grid if (vtrmc_idx > 0) vtrmcout_grid_ptr = vtrmcout_grid if (umr_idx > 0) umrout_grid_ptr = umrout_grid if (vtrmi_idx > 0) vtrmiout_grid_ptr = vtrmiout_grid From c43b3448f3f64bc1ddec85037a15db469d2af211 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 28 Sep 2025 16:05:51 +0200 Subject: [PATCH 16/78] handling compute_enthalpy_from_atm consistently now --- src/control/cam_comp.F90 | 7 +++++-- src/cpl/nuopc/atm_comp_nuopc.F90 | 4 +++- src/utils/air_composition.F90 | 17 +++++++++++++---- 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index c07d342923..c911d0addb 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -56,7 +56,8 @@ module cam_comp subroutine cam_init( & caseid, ctitle, model_doi_url, & initial_run_in, restart_run_in, branch_run_in, post_assim_in, & - calendar, brnch_retain_casename, aqua_planet, dms_from_ocn, & + calendar, brnch_retain_casename, aqua_planet, dms_from_ocn, & + compute_enthalpy_flux, & single_column, scmlat, scmlon, & eccen, obliqr, lambm0, mvelpp, & perpetual_run, perpetual_ymd, & @@ -103,6 +104,7 @@ subroutine cam_init( & logical, intent(in) :: single_column logical, intent(in) :: dms_from_ocn + logical, intent(in) :: compute_enthalpy_flux real(r8), intent(in) :: scmlat real(r8), intent(in) :: scmlon @@ -175,7 +177,8 @@ subroutine cam_init( & ! are set in dyn_init call chem_surfvals_init() - call air_composition_init() + call air_composition_init(compute_enthalpy_flux) + ! initialize ionosphere call ionosphere_init() diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 3acd97c311..a737ad1f68 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -69,7 +69,6 @@ module atm_comp_nuopc use pio , only : pio_noerr, pio_bcast_error, pio_internal_error, pio_seterrorhandling use pio , only : pio_def_var, pio_get_var, pio_put_var, PIO_INT use ioFileMod - use air_composition , only : compute_enthalpy_flux !$use omp_lib , only : omp_set_num_threads implicit none @@ -128,6 +127,8 @@ module atm_comp_nuopc character(len=*) , parameter :: orb_variable_year = 'variable_year' character(len=*) , parameter :: orb_fixed_parameters = 'fixed_parameters' + logical :: compute_enthalpy_flux ! If true, CAM computes enthalpy flux + real(R8) , parameter :: grid_tol = 1.e-2_r8 ! tolerance for calculated lat/lon vs read in type(ESMF_Mesh) :: model_mesh ! model_mesh @@ -660,6 +661,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) branch_run_in=branch_run, post_assim_in=dart_mode, & calendar=calendar, brnch_retain_casename=brnch_retain_casename, & aqua_planet=aqua_planet, dms_from_ocn=dms_from_ocn, & + compute_enthalpy_flux=compute_enthalpy_flux, & single_column=single_column, scmlat=scol_lat, scmlon=scol_lon, & eccen=eccen, obliqr=obliqr, lambm0=lambm0, mvelpp=mvelpp, & perpetual_run=perpetual_run, perpetual_ymd=perpetual_ymd, & diff --git a/src/utils/air_composition.F90 b/src/utils/air_composition.F90 index 659b7e758b..4826e844c6 100644 --- a/src/utils/air_composition.F90 +++ b/src/utils/air_composition.F90 @@ -39,7 +39,7 @@ module air_composition integer, parameter :: unseti = -HUGE(1) real(r8), parameter :: unsetr = HUGE(1.0_r8) - logical, public :: compute_enthalpy_flux ! set by CMEPS + logical, protected, public :: compute_enthalpy_flux ! composition of air ! @@ -259,23 +259,28 @@ end subroutine air_composition_readnl !=========================================================================== - subroutine air_composition_init() + subroutine air_composition_init(compute_enthalpy_flux_in) + use string_utils, only: int2str use spmd_utils, only: masterproc use cam_logfile, only: iulog use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry, cpwv, latice, latvap, tmelt use constituents, only: cnst_get_ind, cnst_mw use ppgrid, only: pcols, pver, begchunk, endchunk + + ! Arguments + logical, intent(in) :: compute_enthalpy_flux_in + + ! Local variables integer :: icnst, ix, isize, ierr, idx integer :: liq_num, ice_num integer :: liq_idx(water_species_in_air_num) integer :: ice_idx(water_species_in_air_num) logical :: has_liq, has_ice real(r8) :: mw - + ! character(len=*), parameter :: subname = 'composition_init' character(len=*), parameter :: errstr = subname//": failed to allocate " - ! ! define cp and R for species in species_name ! @@ -297,6 +302,10 @@ subroutine air_composition_init() real(r8), parameter :: dof3 = 6._r8 real(r8), parameter :: cv3 = 0.5_r8 * r_universal * dof3 real(r8), parameter :: cp3 = 0.5_r8 * r_universal * (2._r8 + dof3) + !----------------------------------------------------------------------- + + ! Set module variable compute_enthalpy_flux + compute_enthalpy_flux = compute_enthalpy_flux_in liq_num = 0 ice_num = 0 From a7614ceea0ddb540d05bd77ea75a2c732f6971b9 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 28 Sep 2025 16:53:48 +0200 Subject: [PATCH 17/78] moved physics/camnor/physics/cam_diagnostics.F90 to physics/cam/cam_diagnostics.F90 and added a new namelist variable history_enthalpy_flux --- bld/build-namelist | 1 + bld/namelist_files/namelist_defaults_cam.xml | 1 + bld/namelist_files/namelist_definition.xml | 6 + src/physics/cam/cam_diagnostics.F90 | 80 +- src/physics/cam/phys_control.F90 | 5 + .../camnor_phys/physics/cam_diagnostics.F90 | 2348 ----------------- 6 files changed, 82 insertions(+), 2359 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/cam_diagnostics.F90 diff --git a/bld/build-namelist b/bld/build-namelist index e84445c335..c9bad05851 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -4552,6 +4552,7 @@ add_default($nl, 'history_gas'); add_default($nl, 'history_aerosol_forcing'); add_default($nl, 'history_aerosol_radiation'); add_default($nl, 'history_aerosol_debug_output'); +add_default($nl, 'history_enthalpy_flux'); # The history output for the AMWG variability diagnostics assumes that auxilliary history # files h1, h2, and h3 contain daily, 6-hrly, and 3-hrly output respectively. If this output diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index cf8f145b46..39c189f11e 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -3001,6 +3001,7 @@ See https://github.com/NorESMhub/noresm3_dev_simulations/discussions/78 .false. .false. .false. + .false. -1 -1 diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 1def2ab394..63ad1021c1 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -5815,6 +5815,12 @@ summation fields. Default: .false. + +Output enthalpy flux diagnostics if CAM computes enthalpy fluxes +Default: .false. + + True when model is configured to use an offline driver. diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 5f7e7d9a60..e10d0b32ce 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -17,7 +17,7 @@ module cam_diagnostics use constituents, only: pcnst, cnst_name, cnst_longname, cnst_cam_outfld use constituents, only: ptendnam, apcnst, bpcnst, cnst_get_ind use dycore, only: dycore_is -use phys_control, only: phys_getopts +use phys_control, only: phys_getopts, history_enthalpy_flux use wv_saturation, only: qsat, qsat_water, svp_ice_vect use time_manager, only: is_first_step @@ -88,6 +88,7 @@ module cam_diagnostics ! liquid budgets. integer :: history_budget_histfile_num ! output history file number for budget fields logical :: history_waccm ! outputs typically used for WACCM +logical :: history_enthalpy_flux ! outputs enthalpy flux diagnostics ! Physics buffer indices @@ -191,10 +192,12 @@ subroutine diag_init_dry(pbuf2d) use cam_history, only: register_vector_field use tidal_diag, only: tidal_diag_init use cam_budget, only: cam_budget_em_snapshot, cam_budget_em_register, thermo_budget_history + use air_composition, only: compute_enthalpy_flux type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) integer :: istage + ! outfld calls in diag_phys_writeout call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) call addfld ('NSTEP', horiz_only, 'A', 'timestep', 'Model timestep') @@ -224,6 +227,19 @@ subroutine diag_init_dry(pbuf2d) call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') + call addfld('EBREAK' , horiz_only, 'A','W/m2', & + 'Global-mean energy-nonconservation (W/m2)' ) + if (compute_enthalpy_flux) then + call addfld('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & + 'T-tendency due to water fluxes (end of tphysac)' ) + call addfld('IETEND_DME', horiz_only, 'A','W/m2 ', & + 'Column enthalpy tendency due to water fluxes (end of tphysac)' ) + call addfld('EFLX ' , horiz_only, 'A','W/m2 ', & + 'Surface water material enthalpy flux (end of tphysac)' ) + call addfld('MFLX ' , horiz_only, 'A','W/m2 ', & + 'Mass flux due to dry mass adjustment / water changes (end of tphysac)') + end if + ! outfld calls in diag_phys_tend_writeout call addfld ('UTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total zonal wind tendency') call addfld ('VTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total meridional wind tendency') @@ -392,6 +408,44 @@ subroutine diag_init_dry(pbuf2d) call addfld( 'CPAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable specific heat cap air' ) call addfld( 'RAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable dry air gas constant' ) + if (compute_enthalpy_flux) then + if (history_enthalpy_flux) then + call addfld('enth_prec_ac_hice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_hliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_hice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_hliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_fice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_ac_fliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_fice',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_prec_bc_fliq',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fevap' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_frain_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_fwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hevap_atm' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hevap_ocn' ,horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hrain_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) + call addfld('enth_hwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) + endif + call addfld('te_tnd' , horiz_only, 'A', 'W/m2', 'Total column integrated energy tendency from CAM physics' ) + call addfld('dEdt_dme' , horiz_only, 'A', 'W/m2', 'Column integrated dEdt from water update') + call addfld('dEdt_physics' , horiz_only, 'A', 'W/m2', '' )!xxx diags will remove + call addfld('dEdt_efix_physics', horiz_only, 'A', 'W/m2', 'Column integrated physics energy fixer dEdt from enthalpy fixer' ) + endif + if (thermo_budget_history) then ! ! energy diagnostics addflds for vars_stage combinations plus e_m_snapshots @@ -1579,14 +1633,14 @@ subroutine diag_conv(state, ztodt, pbuf) type(physics_buffer_desc), pointer :: pbuf(:) ! convective precipitation variables - real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8), pointer :: snow_dp(:) ! snow from ZM convection - real(r8), pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8), pointer :: snow_sh(:) ! snow from Hack convection - real(r8), pointer :: prec_sed(:) ! total precipitation from ZM convection - real(r8), pointer :: snow_sed(:) ! snow from ZM convection - real(r8), pointer :: prec_pcw(:) ! total precipitation from Hack convection - real(r8), pointer :: snow_pcw(:) ! snow from Hack convection + real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8), pointer :: snow_dp(:) ! snow from ZM convection + real(r8), pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8), pointer :: snow_sh(:) ! snow from Hack convection + real(r8), pointer :: prec_sed(:) ! total precipitation from MG sedimentation + real(r8), pointer :: snow_sed(:) ! snow from MG sedimentation + real(r8), pointer :: prec_pcw(:) ! total precipitation from MG prog. cloud + real(r8), pointer :: snow_pcw(:) ! snow from MG prog. cloud ! Local variables: @@ -2044,6 +2098,7 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) real(r8) :: ftem2(pcols) ! Temporary workspace for outfld variables real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables real(r8) :: heat_glob ! global energy integral (FV only) + real(r8) :: tedif_glob ! energy flux from fixer ! CAM pointers to get variables from the physics buffer real(r8), pointer, dimension(:,:) :: t_ttend real(r8), pointer, dimension(:,:) :: t_utend @@ -2064,9 +2119,12 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) ! Total physics tendency for Temperature ! (remove global fixer tendency from total for FV and SE dycores) - call check_energy_get_integrals( heat_glob_out=heat_glob ) + call check_energy_get_integrals(heat_glob_out=heat_glob,tedif_glob_out=tedif_glob) !+tedif + ftem2(:ncol) = tedif_glob/ztodt + call outfld('EBREAK', ftem2, pcols, lchnk) ftem2(:ncol) = heat_glob/cpair - call outfld('TFIX', ftem2, pcols, lchnk ) + call outfld('TFIX', ftem2, pcols, lchnk) + ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair call outfld('PTTEND',ftem3, pcols, lchnk ) ftem3(:ncol,:pver) = tend%dudt(:ncol,:pver) diff --git a/src/physics/cam/phys_control.F90 b/src/physics/cam/phys_control.F90 index 210c2a1d66..7528bd11d4 100644 --- a/src/physics/cam/phys_control.F90 +++ b/src/physics/cam/phys_control.F90 @@ -71,12 +71,15 @@ module phys_control logical :: history_dust = .false. logical :: history_scwaccm_forcing = .false. logical :: history_chemspecies_srf = .false. + logical, public, protected :: history_aerosol_base = .true. logical, public, protected :: history_aerosol_decomposed = .false. logical, public, protected :: history_gas = .false. logical, public, protected :: history_aerosol_forcing = .false. logical, public, protected :: history_aerosol_radiation = .false. logical, public, protected :: history_aerosol_debug_output = .false. +logical, public, protected :: history_enthalpy_flux = .false. + logical :: do_clubb_sgs logical :: do_hb_above_clubb = .false. ! enable HB vertical mixing above clubb top @@ -143,6 +146,7 @@ subroutine phys_ctl_readnl(nlfile) history_clubb, history_dust, & history_cesm_forcing, history_scwaccm_forcing, history_chemspecies_srf, history_aerosol_base, history_aerosol_debug_output, & history_aerosol_decomposed, history_gas, history_aerosol_forcing, history_aerosol_radiation, & + history_enthalpy_flux, & do_clubb_sgs, state_debug_checks, use_hetfrz_classnuc, use_gw_oro, use_gw_front, & use_gw_front_igw, use_gw_convect_dp, use_gw_convect_sh, use_gw_movmtn_pbl, cld_macmic_num_steps, & offline_driver, convproc_do_aer, cam_snapshot_before_num, cam_snapshot_after_num, & @@ -200,6 +204,7 @@ subroutine phys_ctl_readnl(nlfile) call mpi_bcast(history_aerosol_debug_output,1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_dust, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_scwaccm_forcing, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_enthalpy_flux, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(do_clubb_sgs, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(state_debug_checks, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(use_hetfrz_classnuc, 1, mpi_logical, masterprocid, mpicom, ierr) diff --git a/src/physics/camnor_phys/physics/cam_diagnostics.F90 b/src/physics/camnor_phys/physics/cam_diagnostics.F90 deleted file mode 100644 index e2e537a106..0000000000 --- a/src/physics/camnor_phys/physics/cam_diagnostics.F90 +++ /dev/null @@ -1,2348 +0,0 @@ -module cam_diagnostics - -!--------------------------------------------------------------------------------- -! Module to compute a variety of diagnostics quantities for history files -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 -use camsrfexch, only: cam_in_t, cam_out_t -use cam_control_mod, only: moist_physics -use physics_types, only: physics_state, physics_tend, physics_ptend -use ppgrid, only: pcols, pver, begchunk, endchunk -use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dtype_r8 -use physics_buffer, only: dyn_time_lvls, pbuf_get_field, pbuf_get_index, pbuf_old_tim_idx - -use cam_history, only: outfld, write_inithist, hist_fld_active, inithist_all, write_camiop -use cam_history_support, only: max_fieldname_len -use constituents, only: pcnst, cnst_name, cnst_longname, cnst_cam_outfld -use constituents, only: ptendnam, apcnst, bpcnst, cnst_get_ind -use dycore, only: dycore_is -use phys_control, only: phys_getopts -use wv_saturation, only: qsat, qsat_water, svp_ice_vect -use time_manager, only: is_first_step - -use scamMod, only: single_column, wfld -use cam_abortutils, only: endrun - -implicit none -private -save - -! Public interfaces - -public :: & - diag_readnl, &! read namelist options - diag_register, &! register pbuf space - diag_init, &! initialization - diag_allocate, &! allocate memory for module variables - diag_deallocate, &! deallocate memory for module variables - diag_conv_tend_ini, &! initialize convective tendency calcs - diag_phys_writeout, &! output diagnostics of the dynamics - diag_clip_tend_writeout, &! output diagnostics for clipping - diag_phys_tend_writeout, &! output physics tendencies - diag_state_b4_phys_write, &! output state before physics execution - diag_conv, &! output diagnostics of convective processes - diag_surf, &! output diagnostics of the surface - diag_export, &! output export state - diag_physvar_ic, & - nsurf - -integer, public, parameter :: num_stages = 8 -character (len = max_fieldname_len), dimension(num_stages) :: stage = (/"phBF","phBP","phAP","phAM","dyBF","dyBP","dyAP","dyAM"/) -character (len = 45),dimension(num_stages) :: stage_txt = (/& - " before energy fixer ",& !phBF - physics energy - " before parameterizations ",& !phBF - physics energy - " after parameterizations ",& !phAP - physics energy - " after dry mass correction ",& !phAM - physics energy - " before energy fixer (dycore) ",& !dyBF - dynamics energy - " before parameterizations (dycore) ",& !dyBF - dynamics energy - " after parameterizations (dycore) ",& !dyAP - dynamics energy - " after dry mass correction (dycore) " & !dyAM - dynamics energy - /) - -! Private data - -integer :: dqcond_num ! number of constituents to compute convective -character(len=16) :: dcconnam(pcnst) ! names of convection tendencies - ! tendencies for -real(r8), allocatable :: dtcond(:,:,:) ! temperature tendency due to convection -type dqcond_t - real(r8), allocatable :: cnst(:,:,:) ! constituent tendency due to convection -end type dqcond_t -type(dqcond_t), allocatable :: dqcond(:) - -character(len=8) :: diag_cnst_conv_tend = 'q_only' ! output constituent tendencies due to convection - ! 'none', 'q_only' or 'all' - -integer, parameter :: surf_100000 = 1 -integer, parameter :: surf_092500 = 2 -integer, parameter :: surf_085000 = 3 -integer, parameter :: surf_070000 = 4 -integer, parameter :: nsurf = 4 - -logical :: history_amwg ! output the variables used by the AMWG diag package -logical :: history_vdiag ! output the variables used by the AMWG variability diag package -logical :: history_eddy ! output the eddy variables -logical :: history_budget ! output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. -integer :: history_budget_histfile_num ! output history file number for budget fields -logical :: history_waccm ! outputs typically used for WACCM - -! Physics buffer indices - -integer :: psl_idx = 0 -integer :: relhum_idx = 0 -integer :: qcwat_idx = 0 -integer :: tcwat_idx = 0 -integer :: lcwat_idx = 0 -integer :: cld_idx = 0 -integer :: concld_idx = 0 -integer :: tke_idx = 0 -integer :: kvm_idx = 0 -integer :: kvh_idx = 0 -integer :: cush_idx = 0 -integer :: t_ttend_idx = 0 -integer :: t_utend_idx = 0 -integer :: t_vtend_idx = 0 - -integer :: prec_dp_idx = 0 -integer :: snow_dp_idx = 0 -integer :: prec_sh_idx = 0 -integer :: snow_sh_idx = 0 -integer :: prec_sed_idx = 0 -integer :: snow_sed_idx = 0 -integer :: prec_pcw_idx = 0 -integer :: snow_pcw_idx = 0 - - -integer :: tpert_idx=-1, qpert_idx=-1, pblh_idx=-1 - -integer :: trefmxav_idx = -1, trefmnav_idx = -1 - -contains - -!============================================================================== - - subroutine diag_readnl(nlfile) - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: masterproc, masterprocid, mpi_character, mpicom - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'diag_readnl' - - namelist /cam_diag_opts/ diag_cnst_conv_tend - !-------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'cam_diag_opts', status=ierr) - if (ierr == 0) then - read(unitn, cam_diag_opts, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - ! Broadcast namelist variables - call mpi_bcast(diag_cnst_conv_tend, len(diag_cnst_conv_tend), mpi_character, masterprocid, mpicom, ierr) - - end subroutine diag_readnl - -!============================================================================== - - subroutine diag_register_dry() - - call pbuf_add_field('PSL', 'physpkg', dtype_r8, (/pcols/), psl_idx) - - ! Request physics buffer space for fields that persist across timesteps. - call pbuf_add_field('T_TTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_ttend_idx) - call pbuf_add_field('T_UTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_utend_idx) - call pbuf_add_field('T_VTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_vtend_idx) - end subroutine diag_register_dry - - subroutine diag_register_moist() - ! Request physics buffer space for fields that persist across timesteps. - call pbuf_add_field('TREFMXAV', 'global', dtype_r8, (/pcols/), trefmxav_idx) - call pbuf_add_field('TREFMNAV', 'global', dtype_r8, (/pcols/), trefmnav_idx) - end subroutine diag_register_moist - - subroutine diag_register() - call diag_register_dry() - if (moist_physics) then - call diag_register_moist() - end if - end subroutine diag_register - -!============================================================================== - - subroutine diag_init_dry(pbuf2d) - ! Declare the history fields for which this module contains outfld calls. - - use cam_history, only: addfld, add_default, horiz_only - use cam_history, only: register_vector_field - use tidal_diag, only: tidal_diag_init - use cam_budget, only: cam_budget_em_snapshot, cam_budget_em_register, thermo_budget_history - use air_composition, only: compute_enthalpy_flux - - type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) - - logical :: debug_enthalpy_flux=.false. - integer :: istage - - ! outfld calls in diag_phys_writeout - call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) - call addfld ('NSTEP', horiz_only, 'A', 'timestep', 'Model timestep') - call addfld ('PHIS', horiz_only, 'I', 'm2/s2', 'Surface geopotential') - - call addfld ('PS', horiz_only, 'A', 'Pa', 'Surface pressure') - call addfld ('T', (/ 'lev' /), 'A', 'K', 'Temperature') - call addfld ('U', (/ 'lev' /), 'A', 'm/s', 'Zonal wind') - call addfld ('V', (/ 'lev' /), 'A', 'm/s', 'Meridional wind') - - call register_vector_field('U','V') - - ! State before physics - call addfld ('TBP', (/ 'lev' /), 'A','K', 'Temperature (before physics)') - call addfld ('UBP', (/ 'lev' /), 'A','m/s', 'Zonal wind (before physics)') - call addfld ('VBP', (/ 'lev' /), 'A','m/s', 'Meridional Wind (before physics)') - call register_vector_field('UBP','VBP') - call addfld (bpcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (before physics)') - ! State after physics - call addfld ('TAP', (/ 'lev' /), 'A','K', 'Temperature (after physics)' ) - call addfld ('UAP', (/ 'lev' /), 'A','m/s', 'Zonal wind (after physics)' ) - call addfld ('VAP', (/ 'lev' /), 'A','m/s', 'Meridional wind (after physics)' ) - - call register_vector_field('UAP','VAP') - - call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') - call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') - call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') - - call addfld('EBREAK' , horiz_only, 'A','W/m2', & - 'Global-mean energy-nonconservation (W/m2)' ) - !if (compute_enthalpy_flux) then - call addfld('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & - 'T-tendency due to water fluxes (end of tphysac)' ) - call addfld('IETEND_DME', horiz_only, 'A','W/m2 ', & - 'Column enthalpy tendency due to water fluxes (end of tphysac)' ) - call addfld('EFLX ' , horiz_only, 'A','W/m2 ', & - 'Surface water material enthalpy flux (end of tphysac)' ) - call addfld('MFLX ' , horiz_only, 'A','W/m2 ', & - 'Mass flux due to dry mass adjustment / water changes (end of tphysac)') - !end if - - ! outfld calls in diag_phys_tend_writeout - call addfld ('UTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total zonal wind tendency') - call addfld ('VTEND_TOT', (/ 'lev' /), 'A', 'm/s2', 'Total meridional wind tendency') - call register_vector_field('UTEND_TOT','VTEND_TOT') - - ! Debugging negative water output fields - call addfld ('INEGCLPTEND ', (/ 'lev' /), 'A', 'kg/kg/s', 'Cloud ice tendency due to clipping neg values after microp', sampled_on_subcycle=.true.) - call addfld ('LNEGCLPTEND ', (/ 'lev' /), 'A', 'kg/kg/s', 'Cloud liq tendency due to clipping neg values after microp', sampled_on_subcycle=.true.) - call addfld ('VNEGCLPTEND ', (/ 'lev' /), 'A', 'kg/kg/s', 'Vapor tendency due to clipping neg values after microp', sampled_on_subcycle=.true.) - - call addfld ('Z3', (/ 'lev' /), 'A', 'm', 'Geopotential Height (above sea level)') - call addfld ('Z1000', horiz_only, 'A', 'm', 'Geopotential Z at 1000 mbar pressure surface') - call addfld ('Z700', horiz_only, 'A', 'm', 'Geopotential Z at 700 mbar pressure surface') - call addfld ('Z500', horiz_only, 'A', 'm', 'Geopotential Z at 500 mbar pressure surface') - call addfld ('Z300', horiz_only, 'A', 'm', 'Geopotential Z at 300 mbar pressure surface') - call addfld ('Z200', horiz_only, 'A', 'm', 'Geopotential Z at 200 mbar pressure surface') - call addfld ('Z100', horiz_only, 'A', 'm', 'Geopotential Z at 100 mbar pressure surface') - call addfld ('Z050', horiz_only, 'A', 'm', 'Geopotential Z at 50 mbar pressure surface') - - call addfld ('ZZ', (/ 'lev' /), 'A', 'm2', 'Eddy height variance' ) - call addfld ('VZ', (/ 'lev' /), 'A', 'm2/s', 'Meridional transport of geopotential height') - call addfld ('VT', (/ 'lev' /), 'A', 'K m/s ', 'Meridional heat transport') - call addfld ('VU', (/ 'lev' /), 'A', 'm2/s2', 'Meridional flux of zonal momentum' ) - call addfld ('VV', (/ 'lev' /), 'A', 'm2/s2', 'Meridional velocity squared' ) - call addfld ('OMEGAV', (/ 'lev' /), 'A', 'm Pa/s2 ', 'Vertical flux of meridional momentum' ) - call addfld ('OMGAOMGA', (/ 'lev' /), 'A', 'Pa2/s2', 'Vertical flux of vertical momentum' ) - - call addfld ('UT', (/ 'lev' /), 'A', 'K m/s ', 'Zonal heat transport') - call addfld ('UU', (/ 'lev' /), 'A', 'm2/s2', 'Zonal velocity squared' ) - call addfld ('WSPEED', (/ 'lev' /), 'X', 'm/s', 'Horizontal total wind speed maximum' ) - call addfld ('WSPDSRFMX', horiz_only, 'X', 'm/s', 'Horizontal total wind speed maximum at surface layer midpoint' ) - call addfld ('WSPDSRFAV', horiz_only, 'A', 'm/s', 'Horizontal total wind speed average at surface layer midpoint' ) - - call addfld ('OMEGA', (/ 'lev' /), 'A', 'Pa/s', 'Vertical velocity (pressure)') - call addfld ('OMEGAT', (/ 'lev' /), 'A', 'K Pa/s ', 'Vertical heat flux' ) - call addfld ('OMEGAU', (/ 'lev' /), 'A', 'm Pa/s2 ', 'Vertical flux of zonal momentum' ) - call addfld ('OMEGA850', horiz_only, 'A', 'Pa/s', 'Vertical velocity at 850 mbar pressure surface') - call addfld ('OMEGA500', horiz_only, 'A', 'Pa/s', 'Vertical velocity at 500 mbar pressure surface') - - call addfld ('PSL', horiz_only, 'A', 'Pa','Sea level pressure') - - call addfld ('T1000', horiz_only, 'A', 'K','Temperature at 1000 mbar pressure surface') - call addfld ('T925', horiz_only, 'A', 'K','Temperature at 925 mbar pressure surface') - call addfld ('T850', horiz_only, 'A', 'K','Temperature at 850 mbar pressure surface') - call addfld ('T700', horiz_only, 'A', 'K','Temperature at 700 mbar pressure surface') - call addfld ('T500', horiz_only, 'A', 'K','Temperature at 500 mbar pressure surface') - call addfld ('T400', horiz_only, 'A', 'K','Temperature at 400 mbar pressure surface') - call addfld ('T300', horiz_only, 'A', 'K','Temperature at 300 mbar pressure surface') - call addfld ('T200', horiz_only, 'A', 'K','Temperature at 200 mbar pressure surface') - call addfld ('T010', horiz_only, 'A', 'K','Temperature at 10 mbar pressure surface') - - call addfld ('T7001000', horiz_only, 'A', 'K','Temperature difference 700 mb - 1000 mb') - call addfld ('TH7001000', horiz_only, 'A', 'K','Theta difference 700 mb - 1000 mb') - call addfld ('THE7001000', horiz_only, 'A', 'K','ThetaE difference 700 mb - 1000 mb') - - call addfld ('T8501000', horiz_only, 'A', 'K','Temperature difference 850 mb - 1000 mb') - call addfld ('TH8501000', horiz_only, 'A', 'K','Theta difference 850 mb - 1000 mb') - call addfld ('T9251000', horiz_only, 'A', 'K','Temperature difference 925 mb - 1000 mb') - call addfld ('TH9251000', horiz_only, 'A', 'K','Theta difference 925 mb - 1000 mb') - - call addfld ('TT', (/ 'lev' /), 'A', 'K2','Eddy temperature variance' ) - - call addfld ('U850', horiz_only, 'A', 'm/s','Zonal wind at 850 mbar pressure surface') - call addfld ('U500', horiz_only, 'A', 'm/s','Zonal wind at 500 mbar pressure surface') - call addfld ('U250', horiz_only, 'A', 'm/s','Zonal wind at 250 mbar pressure surface') - call addfld ('U200', horiz_only, 'A', 'm/s','Zonal wind at 200 mbar pressure surface') - call addfld ('U010', horiz_only, 'A', 'm/s','Zonal wind at 10 mbar pressure surface') - call addfld ('V850', horiz_only, 'A', 'm/s','Meridional wind at 850 mbar pressure surface') - call addfld ('V500', horiz_only, 'A', 'm/s','Meridional wind at 500 mbar pressure surface') - call addfld ('V250', horiz_only, 'A', 'm/s','Meridional wind at 250 mbar pressure surface') - call addfld ('V200', horiz_only, 'A', 'm/s','Meridional wind at 200 mbar pressure surface') - - call register_vector_field('U850', 'V850') - call register_vector_field('U500', 'V500') - call register_vector_field('U250', 'V250') - call register_vector_field('U200', 'V200') - - call addfld ('UBOT', horiz_only, 'A', 'm/s','Lowest model level zonal wind') - call addfld ('VBOT', horiz_only, 'A', 'm/s','Lowest model level meridional wind') - call register_vector_field('UBOT', 'VBOT') - - call addfld ('ZBOT', horiz_only, 'A', 'm','Lowest model level height') - - call addfld ('ATMEINT', horiz_only, 'A', 'J/m2','Vertically integrated total atmospheric energy ') - - if (history_amwg) then - call add_default ('PHIS ' , 1, ' ') - call add_default ('PS ' , 1, ' ') - call add_default ('T ' , 1, ' ') - call add_default ('U ' , 1, ' ') - call add_default ('V ' , 1, ' ') - call add_default ('Z3 ' , 1, ' ') - call add_default ('OMEGA ' , 1, ' ') - call add_default ('VT ', 1, ' ') - call add_default ('VU ', 1, ' ') - call add_default ('VV ', 1, ' ') - call add_default ('UU ', 1, ' ') - call add_default ('OMEGAT ', 1, ' ') - call add_default ('PSL ', 1, ' ') - end if - - if (history_vdiag) then - call add_default ('U200', 2, ' ') - call add_default ('V200', 2, ' ') - call add_default ('U850', 2, ' ') - call add_default ('U200', 3, ' ') - call add_default ('U850', 3, ' ') - call add_default ('OMEGA500', 3, ' ') - end if - - if (history_eddy) then - call add_default ('VT ', 1, ' ') - call add_default ('VU ', 1, ' ') - call add_default ('VV ', 1, ' ') - call add_default ('UT ', 1, ' ') - call add_default ('UU ', 1, ' ') - call add_default ('OMEGAT ', 1, ' ') - call add_default ('OMEGAU ', 1, ' ') - call add_default ('OMEGAV ', 1, ' ') - endif - - if ( history_budget ) then - call add_default ('PHIS ' , history_budget_histfile_num, ' ') - call add_default ('PS ' , history_budget_histfile_num, ' ') - call add_default ('T ' , history_budget_histfile_num, ' ') - call add_default ('U ' , history_budget_histfile_num, ' ') - call add_default ('V ' , history_budget_histfile_num, ' ') - call add_default ('TTEND_TOT' , history_budget_histfile_num, ' ') - call add_default ('UTEND_TOT' , history_budget_histfile_num, ' ') - call add_default ('VTEND_TOT' , history_budget_histfile_num, ' ') - - ! State before physics (FV) - call add_default ('TBP ' , history_budget_histfile_num, ' ') - call add_default ('UBP ' , history_budget_histfile_num, ' ') - call add_default ('VBP ' , history_budget_histfile_num, ' ') - call add_default (bpcnst(1) , history_budget_histfile_num, ' ') - ! State after physics (FV) - call add_default ('TAP ' , history_budget_histfile_num, ' ') - call add_default ('UAP ' , history_budget_histfile_num, ' ') - call add_default ('VAP ' , history_budget_histfile_num, ' ') - call add_default (apcnst(1) , history_budget_histfile_num, ' ') - call add_default ('TFIX ' , history_budget_histfile_num, ' ') - end if - - if (history_waccm) then - call add_default ('PHIS', 7, ' ') - call add_default ('PS', 7, ' ') - call add_default ('PSL', 7, ' ') - end if - - ! outfld calls in diag_phys_tend_writeout - call addfld ('PTTEND', (/ 'lev' /), 'A', 'K/s','T total physics tendency') - call addfld ('UTEND_PHYSTOT', (/ 'lev' /), 'A', 'm/s2','U total physics tendency') - call addfld ('VTEND_PHYSTOT', (/ 'lev' /), 'A', 'm/s2','V total physics tendency') - call register_vector_field('UTEND_PHYSTOT','VTEND_PHYSTOT') - if ( history_budget ) then - call add_default ('PTTEND' , history_budget_histfile_num, ' ') - call add_default ('UTEND_PHYSTOT' , history_budget_histfile_num, ' ') - call add_default ('VTEND_PHYSTOT' , history_budget_histfile_num, ' ') - end if - - ! create history variables for fourier coefficients of the diurnal - ! and semidiurnal tide in T, U, V, and Z3 - call tidal_diag_init() - - call addfld( 'CPAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable specific heat cap air' ) - call addfld( 'RAIRV', (/ 'lev' /), 'I', 'J/K/kg', 'Variable dry air gas constant' ) - - if (compute_enthalpy_flux) then - if(debug_enthalpy_flux) then - call addfld('enth_prec_ac_hice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_ac_hliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_hice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_hliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_ac_fice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_ac_fliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_fice',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_prec_bc_fliq',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fevap' ,horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_frain_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_frain_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_frain_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_fwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hevap_atm' ,horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hevap_ocn' ,horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hrain_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hsnow_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hwatr_bc_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hrain_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hsnow_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hwatr_ac_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hrain_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hsnow_tt_err',horiz_only, 'A', 'W/m2', '' ) - call addfld('enth_hwatr_tt_err',horiz_only, 'A', 'W/m2', '' ) - endif - call addfld('te_tnd' , horiz_only, 'A', 'W/m2', 'Total column integrated energy tendency from CAM physics' ) - call addfld('dEdt_dme' , horiz_only, 'A', 'W/m2', 'Column integrated dEdt from water update') - call addfld('dEdt_physics' , horiz_only, 'A', 'W/m2', '' )!xxx diags will remove - call addfld('dEdt_efix_physics', horiz_only, 'A', 'W/m2', 'Column integrated physics energy fixer dEdt from enthalpy fixer' ) - endif - - if (thermo_budget_history) then - ! - ! energy diagnostics addflds for vars_stage combinations plus e_m_snapshots - ! - do istage = 1, num_stages - call cam_budget_em_snapshot(TRIM(ADJUSTL(stage(istage))),'phy',longname=TRIM(ADJUSTL(stage_txt(istage)))) - end do - - ! Create budgets that are a sum/dif of 2 stages - - call cam_budget_em_register('dEdt_param_efix_physE','phAP','phBF','phy','dif',longname='dE/dt CAM physics + energy fixer using physics E formula (phAP-phBF)') - call cam_budget_em_register('dEdt_param_efix_dynE' ,'dyAP','dyBF','phy','dif',longname='dE/dt CAM physics + energy fixer using dycore E formula (dyAP-dyBF)') - call cam_budget_em_register('dEdt_param_physE' ,'phAP','phBP','phy','dif',longname='dE/dt CAM physics using physics E formula (phAP-phBP)') - call cam_budget_em_register('dEdt_param_dynE' ,'dyAP','dyBP','phy','dif',longname='dE/dt CAM physics using dycore E (dyAP-dyBP)') - call cam_budget_em_register('dEdt_dme_adjust_physE','phAM','phAP','phy','dif',longname='dE/dt dry mass adjustment using physics E formula (phAM-phAP)') - call cam_budget_em_register('dEdt_dme_adjust_dynE' ,'dyAM','dyAP','phy','dif',longname='dE/dt dry mass adjustment using dycore E (dyAM-dyAP)') - call cam_budget_em_register('dEdt_efix_physE' ,'phBP','phBF','phy','dif',longname='dE/dt energy fixer using physics E formula (phBP-phBF)') - call cam_budget_em_register('dEdt_efix_dynE' ,'dyBP','dyBF','phy','dif',longname='dE/dt energy fixer using dycore E formula (dyBP-dyBF)') - call cam_budget_em_register('dEdt_phys_tot_physE' ,'phAM','phBF','phy','dif',longname='dE/dt physics total using physics E formula (phAM-phBF)') - call cam_budget_em_register('dEdt_phys_tot_dynE' ,'dyAM','dyBF','phy','dif',longname='dE/dt physics total using dycore E (dyAM-dyBF)') - endif - end subroutine diag_init_dry - - subroutine diag_init_moist(pbuf2d) - - ! Declare the history fields for which this module contains outfld calls. - - use cam_history, only: addfld, add_default, horiz_only - use constituent_burden, only: constituent_burden_init - use physics_buffer, only: pbuf_set_field - - type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) - - integer :: m - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - integer :: ierr - ! column burdens for all constituents except water vapor - call constituent_burden_init - - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - - ! outfld calls in diag_phys_writeout - call addfld ('OMEGAQ', (/ 'lev' /), 'A', 'kgPa/kgs', 'Vertical water transport' ) - call addfld ('UQ', (/ 'lev' /), 'A', 'm/skg/kg', 'Zonal water transport') - call addfld ('VQ', (/ 'lev' /), 'A', 'm/skg/kg', 'Meridional water transport') - call addfld ('QQ', (/ 'lev' /), 'A', 'kg2/kg2', 'Eddy moisture variance') - - call addfld ('MQ', (/ 'lev' /), 'A', 'kg/m2','Water vapor mass in layer') - call addfld ('TMQ', horiz_only, 'A', 'kg/m2','Total (vertically integrated) precipitable water') - call addfld ('RELHUM', (/ 'lev' /), 'A', 'percent','Relative humidity') - call addfld ('RHW', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to liquid') - call addfld ('RHI', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to ice') - call addfld ('RHCFMIP', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to water above 273 K, ice below 273 K') - - call addfld ('IVT', horiz_only, 'A', 'kg/m/s','Total (vertically integrated) vapor transport') - call addfld ('uIVT', horiz_only, 'A', 'kg/m/s','u-component (vertically integrated) vapor transport') - call addfld ('vIVT', horiz_only, 'A', 'kg/m/s','v-component (vertically integrated) vapor transport') - - call addfld ('THE8501000', horiz_only, 'A', 'K','ThetaE difference 850 mb - 1000 mb') - call addfld ('THE9251000', horiz_only, 'A', 'K','ThetaE difference 925 mb - 1000 mb') - - call addfld ('Q1000', horiz_only, 'A', 'kg/kg','Specific Humidity at 1000 mbar pressure surface') - call addfld ('Q925', horiz_only, 'A', 'kg/kg','Specific Humidity at 925 mbar pressure surface') - call addfld ('Q850', horiz_only, 'A', 'kg/kg','Specific Humidity at 850 mbar pressure surface') - call addfld ('Q200', horiz_only, 'A', 'kg/kg','Specific Humidity at 200 mbar pressure surface') - call addfld ('QBOT', horiz_only, 'A', 'kg/kg','Lowest model level water vapor mixing ratio') - - call addfld ('PSDRY', horiz_only, 'A', 'Pa', 'Dry surface pressure') - call addfld ('PMID', (/ 'lev' /), 'A', 'Pa', 'Pressure at layer midpoints') - call addfld ('PINT', (/ 'ilev' /), 'A', 'Pa', 'Pressure at layer interfaces') - call addfld ('PDELDRY', (/ 'lev' /), 'A', 'Pa', 'Dry pressure difference between levels') - call addfld ('PDEL', (/ 'lev' /), 'A', 'Pa', 'Pressure difference between levels') - - ! outfld calls in diag_conv - - call addfld ('DTCOND', (/ 'lev' /), 'A','K/s','T tendency - moist processes') - call addfld ('DTCOND_24_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 24hr. cos coeff.') - call addfld ('DTCOND_24_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 24hr. sin coeff.') - call addfld ('DTCOND_12_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. cos coeff.') - call addfld ('DTCOND_12_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. sin coeff.') - call addfld ('DTCOND_08_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. cos coeff.') - call addfld ('DTCOND_08_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. sin coeff.') - - call addfld ('PRECL', horiz_only, 'A', 'm/s','Large-scale (stable) precipitation rate (liq + ice)' ) - call addfld ('PRECC', horiz_only, 'A', 'm/s','Convective precipitation rate (liq + ice)' ) - call addfld ('PRECT', horiz_only, 'A', 'm/s','Total (convective and large-scale) precipitation rate (liq + ice)' ) - call addfld ('PREC_PCW', horiz_only, 'A', 'm/s','LS_pcw precipitation rate') - call addfld ('PREC_zmc', horiz_only, 'A', 'm/s','CV_zmc precipitation rate') - call addfld ('PRECTMX', horiz_only, 'X','m/s','Maximum (convective and large-scale) precipitation rate (liq+ice)' ) - call addfld ('PRECSL', horiz_only, 'A', 'm/s','Large-scale (stable) snow rate (water equivalent)' ) - call addfld ('PRECSC', horiz_only, 'A', 'm/s','Convective snow rate (water equivalent)' ) - call addfld ('PRECCav', horiz_only, 'A', 'm/s','Average large-scale precipitation (liq + ice)' ) - call addfld ('PRECLav', horiz_only, 'A', 'm/s','Average convective precipitation (liq + ice)' ) - - ! outfld calls in diag_surf - - call addfld ('SHFLX', horiz_only, 'A', 'W/m2','Surface sensible heat flux') - call addfld ('LHFLX', horiz_only, 'A', 'W/m2','Surface latent heat flux') - call addfld ('QFLX', horiz_only, 'A', 'kg/m2/s','Surface water flux') - - call addfld ('TAUX', horiz_only, 'A', 'N/m2','Zonal surface stress') - call addfld ('TAUY', horiz_only, 'A', 'N/m2','Meridional surface stress') - call addfld ('TREFHT', horiz_only, 'A', 'K','Reference height temperature') - call addfld ('TREFHTMN', horiz_only, 'M','K','Minimum reference height temperature over output period') - call addfld ('TREFHTMX', horiz_only, 'X','K','Maximum reference height temperature over output period') - call addfld ('QREFHT', horiz_only, 'A', 'kg/kg','Reference height humidity') - call addfld ('U10', horiz_only, 'A', 'm/s','10m wind speed') - call addfld ('UGUST', horiz_only, 'A', 'm/s','Gustiness term added to U10') - call addfld ('U10WITHGUSTS',horiz_only, 'A', 'm/s','10m wind speed with gustiness added') - call addfld ('RHREFHT', horiz_only, 'A', 'fraction','Reference height relative humidity') - - call addfld ('LANDFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by land') - call addfld ('ICEFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by sea-ice') - call addfld ('OCNFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by ocean') - - call addfld ('TREFMNAV', horiz_only, 'A', 'K','Average of TREFHT daily minimum') - call addfld ('TREFMXAV', horiz_only, 'A', 'K','Average of TREFHT daily maximum') - - call addfld ('TS', horiz_only, 'A', 'K','Surface temperature (radiative)') - call addfld ('TSMN', horiz_only, 'M','K','Minimum surface temperature over output period') - call addfld ('TSMX', horiz_only, 'X','K','Maximum surface temperature over output period') - call addfld ('SNOWHLND', horiz_only, 'A', 'm','Water equivalent snow depth') - call addfld ('SNOWHICE', horiz_only, 'A', 'm','Snow depth over ice', fill_value = 1.e30_r8) - call addfld ('TBOT', horiz_only, 'A', 'K','Lowest model level temperature') - - call addfld ('ASDIR', horiz_only, 'A', '1','albedo: shortwave, direct') - call addfld ('ASDIF', horiz_only, 'A', '1','albedo: shortwave, diffuse') - call addfld ('ALDIR', horiz_only, 'A', '1','albedo: longwave, direct') - call addfld ('ALDIF', horiz_only, 'A', '1','albedo: longwave, diffuse') - call addfld ('SST', horiz_only, 'A', 'K','sea surface temperature') - - - ! outfld calls in diag_phys_tend_writeout - - call addfld (ptendnam( 1),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name( 1))//' total physics tendency ' ) - - if (ixcldliq > 0) then - call addfld (ptendnam(ixcldliq),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldliq))//' total physics tendency ' ) - end if - if (ixcldice > 0) then - call addfld (ptendnam(ixcldice),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldice))//' total physics tendency ') - end if - - ! outfld calls in diag_physvar_ic - - call addfld ('QCWAT&IC', (/ 'lev' /), 'I','kg/kg','q associated with cloud water' ) - call addfld ('TCWAT&IC', (/ 'lev' /), 'I','kg/kg','T associated with cloud water' ) - call addfld ('LCWAT&IC', (/ 'lev' /), 'I','kg/kg','Cloud water (ice + liq' ) - call addfld ('CLOUD&IC', (/ 'lev' /), 'I','fraction','Cloud fraction' ) - call addfld ('CONCLD&IC', (/ 'lev' /), 'I','fraction','Convective cloud fraction' ) - call addfld ('TKE&IC', (/ 'ilev' /), 'I','m2/s2','Turbulent Kinetic Energy' ) - call addfld ('CUSH&IC', horiz_only, 'I','m','Convective Scale Height' ) - call addfld ('KVH&IC', (/ 'ilev' /), 'I','m2/s','Vertical diffusion diffusivities (heat/moisture)' ) - call addfld ('KVM&IC', (/ 'ilev' /), 'I','m2/s','Vertical diffusion diffusivities (momentum)' ) - call addfld ('PBLH&IC', horiz_only, 'I','m','PBL height' ) - call addfld ('TPERT&IC', horiz_only, 'I','K','Perturbation temperature (eddies in PBL)' ) - call addfld ('QPERT&IC', horiz_only, 'I','kg/kg','Perturbation specific humidity (eddies in PBL)' ) - - ! CAM export state - call addfld('a2x_BCPHIWET', horiz_only, 'A', 'kg/m2/s', 'wetdep of hydrophilic black carbon') - call addfld('a2x_BCPHIDRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophilic black carbon') - call addfld('a2x_BCPHODRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophobic black carbon') - call addfld('a2x_OCPHIWET', horiz_only, 'A', 'kg/m2/s', 'wetdep of hydrophilic organic carbon') - call addfld('a2x_OCPHIDRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophilic organic carbon') - call addfld('a2x_OCPHODRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophobic organic carbon') - call addfld('a2x_DSTWET1', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin1)') - call addfld('a2x_DSTDRY1', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin1)') - call addfld('a2x_DSTWET2', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin2)') - call addfld('a2x_DSTDRY2', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin2)') - call addfld('a2x_DSTWET3', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin3)') - call addfld('a2x_DSTDRY3', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin3)') - call addfld('a2x_DSTWET4', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin4)') - call addfld('a2x_DSTDRY4', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin4)') - - call addfld('a2x_NOYDEP', horiz_only, 'A', 'kgN/m2/s', 'NOy Deposition Flux') - call addfld('a2x_NHXDEP', horiz_only, 'A', 'kgN/m2/s', 'NHx Deposition Flux') - - ! defaults - if (history_amwg) then - call add_default (cnst_name(1), 1, ' ') - call add_default ('VQ ', 1, ' ') - call add_default ('TMQ ', 1, ' ') - call add_default ('PSL ', 1, ' ') - call add_default ('RELHUM ', 1, ' ') - - call add_default ('DTCOND ', 1, ' ') - call add_default ('PRECL ', 1, ' ') - call add_default ('PRECC ', 1, ' ') - call add_default ('PRECSL ', 1, ' ') - call add_default ('PRECSC ', 1, ' ') - call add_default ('SHFLX ', 1, ' ') - call add_default ('LHFLX ', 1, ' ') - call add_default ('QFLX ', 1, ' ') - call add_default ('TAUX ', 1, ' ') - call add_default ('TAUY ', 1, ' ') - call add_default ('TREFHT ', 1, ' ') - call add_default ('LANDFRAC', 1, ' ') - call add_default ('OCNFRAC ', 1, ' ') - call add_default ('QREFHT ', 1, ' ') - call add_default ('U10 ', 1, ' ') - call add_default ('ICEFRAC ', 1, ' ') - call add_default ('TS ', 1, ' ') - call add_default ('TSMN ', 1, ' ') - call add_default ('TSMX ', 1, ' ') - call add_default ('SNOWHLND', 1, ' ') - call add_default ('SNOWHICE', 1, ' ') - end if - - if (dycore_is('SE')) then - call add_default ('PSDRY', 1, ' ') - call add_default ('PMID', 1, ' ') - end if - - if (dycore_is('MPAS')) then - call add_default ('PINT', 1, ' ') - call add_default ('PMID', 1, ' ') - call add_default ('PDEL', 1, ' ') - end if - - if (history_eddy) then - call add_default ('UQ ', 1, ' ') - call add_default ('VQ ', 1, ' ') - endif - - if ( history_budget ) then - call add_default (cnst_name(1), history_budget_histfile_num, ' ') - call add_default ('PTTEND' , history_budget_histfile_num, ' ') - call add_default ('UTEND_PHYSTOT' , history_budget_histfile_num, ' ') - call add_default ('VTEND_PHYSTOT' , history_budget_histfile_num, ' ') - call add_default (ptendnam( 1), history_budget_histfile_num, ' ') - if (ixcldliq > 0) then - call add_default (ptendnam(ixcldliq), history_budget_histfile_num, ' ') - end if - if (ixcldice > 0) then - call add_default (ptendnam(ixcldice), history_budget_histfile_num, ' ') - end if - if( history_budget_histfile_num > 1 ) then - call add_default ('DTCOND ' , history_budget_histfile_num, ' ') - end if - end if - - if (history_vdiag) then - call add_default ('PRECT ', 2, ' ') - call add_default ('PRECT ', 3, ' ') - call add_default ('PRECT ', 4, ' ') - end if - - ! Initial file - Optional fields - if (inithist_all.or.single_column) then - call add_default ('CONCLD&IC ',0, 'I') - call add_default ('QCWAT&IC ',0, 'I') - call add_default ('TCWAT&IC ',0, 'I') - call add_default ('LCWAT&IC ',0, 'I') - call add_default ('PBLH&IC ',0, 'I') - call add_default ('TPERT&IC ',0, 'I') - call add_default ('QPERT&IC ',0, 'I') - call add_default ('CLOUD&IC ',0, 'I') - call add_default ('TKE&IC ',0, 'I') - call add_default ('CUSH&IC ',0, 'I') - call add_default ('KVH&IC ',0, 'I') - call add_default ('KVM&IC ',0, 'I') - end if - - ! determine number of constituents for which convective tendencies must be computed - if (history_budget) then - dqcond_num = pcnst - else - if (diag_cnst_conv_tend == 'none') dqcond_num = 0 - if (diag_cnst_conv_tend == 'q_only') dqcond_num = 1 - if (diag_cnst_conv_tend == 'all') dqcond_num = pcnst - end if - - do m = 1, dqcond_num - dcconnam(m) = 'DC'//cnst_name(m) - end do - - if ((diag_cnst_conv_tend == 'q_only') .or. (diag_cnst_conv_tend == 'all') .or. history_budget) then - call addfld (dcconnam(1),(/ 'lev' /),'A', 'kg/kg/s',trim(cnst_name(1))//' tendency due to moist processes') - if ( diag_cnst_conv_tend == 'q_only' .or. diag_cnst_conv_tend == 'all' ) then - call add_default (dcconnam(1), 1, ' ') - end if - if( history_budget ) then - call add_default (dcconnam(1), history_budget_histfile_num, ' ') - end if - if (diag_cnst_conv_tend == 'all' .or. history_budget) then - do m = 2, pcnst - call addfld (dcconnam(m),(/ 'lev' /),'A', 'kg/kg/s',trim(cnst_name(m))//' tendency due to moist processes') - if( diag_cnst_conv_tend == 'all' ) then - call add_default (dcconnam(m), 1, ' ') - end if - if( history_budget .and. (m == ixcldliq .or. m == ixcldice) ) then - call add_default (dcconnam(m), history_budget_histfile_num, ' ') - end if - end do - end if - end if - - ! Pbuf field indices for collecting output data - relhum_idx = pbuf_get_index('RELHUM', errcode=ierr) - qcwat_idx = pbuf_get_index('QCWAT', errcode=ierr) - tcwat_idx = pbuf_get_index('TCWAT', errcode=ierr) - lcwat_idx = pbuf_get_index('LCWAT', errcode=ierr) - cld_idx = pbuf_get_index('CLD', errcode=ierr) - concld_idx = pbuf_get_index('CONCLD', errcode=ierr) - - tke_idx = pbuf_get_index('tke', errcode=ierr) - kvm_idx = pbuf_get_index('kvm', errcode=ierr) - kvh_idx = pbuf_get_index('kvh', errcode=ierr) - cush_idx = pbuf_get_index('cush', errcode=ierr) - - pblh_idx = pbuf_get_index('pblh', errcode=ierr) - tpert_idx = pbuf_get_index('tpert', errcode=ierr) - qpert_idx = pbuf_get_index('qpert', errcode=ierr) - - prec_dp_idx = pbuf_get_index('PREC_DP', errcode=ierr) - snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=ierr) - prec_sh_idx = pbuf_get_index('PREC_SH', errcode=ierr) - snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=ierr) - prec_sed_idx = pbuf_get_index('PREC_SED', errcode=ierr) - snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=ierr) - prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=ierr) - snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=ierr) - - if (is_first_step()) then - call pbuf_set_field(pbuf2d, trefmxav_idx, -1.0e36_r8) - call pbuf_set_field(pbuf2d, trefmnav_idx, 1.0e36_r8) - end if - - end subroutine diag_init_moist - - subroutine diag_init(pbuf2d) - - ! Declare the history fields for which this module contains outfld calls. - - type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) - - ! ---------------------------- - ! determine default variables - ! ---------------------------- - call phys_getopts(history_amwg_out = history_amwg , & - history_vdiag_out = history_vdiag , & - history_eddy_out = history_eddy , & - history_budget_out = history_budget , & - history_budget_histfile_num_out = history_budget_histfile_num, & - history_waccm_out = history_waccm) - - call diag_init_dry(pbuf2d) - if (moist_physics) then - call diag_init_moist(pbuf2d) - end if - - end subroutine diag_init - -!=============================================================================== - - subroutine diag_allocate_dry() - use infnan, only: nan, assignment(=) - - ! Allocate memory for module variables. - ! Done at the begining of a physics step at same point as the pbuf allocate - ! for variables with "physpkg" scope. - - ! Local variables - character(len=*), parameter :: sub = 'diag_allocate_dry' - character(len=128) :: errmsg - integer :: istat - - allocate(dtcond(pcols,pver,begchunk:endchunk), stat=istat) - if ( istat /= 0 ) then - write(errmsg, '(2a,i0)') sub, ': allocate failed, stat = ',istat - call endrun (errmsg) - end if - dtcond = nan - end subroutine diag_allocate_dry - - subroutine diag_allocate_moist() - use infnan, only: nan, assignment(=) - - ! Allocate memory for module variables. - ! Done at the begining of a physics step at same point as the pbuf allocate - ! for variables with "physpkg" scope. - - ! Local variables - character(len=*), parameter :: sub = 'diag_allocate_moist' - character(len=128) :: errmsg - integer :: i, istat - - if (dqcond_num > 0) then - allocate(dqcond(dqcond_num)) - do i = 1, dqcond_num - allocate(dqcond(i)%cnst(pcols,pver,begchunk:endchunk), stat=istat) - if ( istat /= 0 ) then - write(errmsg, '(2a,i0)') sub, ': allocate failed, stat = ',istat - call endrun (errmsg) - end if - dqcond(i)%cnst = nan - end do - end if - - end subroutine diag_allocate_moist - - subroutine diag_allocate() - - call diag_allocate_dry() - if (moist_physics) then - call diag_allocate_moist() - end if - - end subroutine diag_allocate - -!=============================================================================== - - subroutine diag_deallocate_dry() - ! Deallocate memory for module variables. - ! Done at the end of a physics step at same point as the pbuf deallocate for - ! variables with "physpkg" scope. - - ! Local variables - character(len=*), parameter :: sub = 'diag_deallocate_dry' - integer :: istat - - deallocate(dtcond, stat=istat) - if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') - end subroutine diag_deallocate_dry - - subroutine diag_deallocate_moist() - - ! Deallocate memory for module variables. - ! Done at the end of a physics step at same point as the pbuf deallocate for - ! variables with "physpkg" scope. - - ! Local variables - character(len=*), parameter :: sub = 'diag_deallocate_moist' - integer :: i, istat - - if (dqcond_num > 0) then - do i = 1, dqcond_num - deallocate(dqcond(i)%cnst, stat=istat) - if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') - end do - deallocate(dqcond, stat=istat) - if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') - end if - end subroutine diag_deallocate_moist - - subroutine diag_deallocate() - - call diag_deallocate_dry() - if (moist_physics) then - call diag_deallocate_moist() - end if - - end subroutine diag_deallocate - -!=============================================================================== - - subroutine diag_conv_tend_ini(state,pbuf) - - ! Initialize convective tendency calcs. - - ! Arguments: - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - ! Local variables: - - integer :: i, k, m, lchnk, ncol - real(r8), pointer, dimension(:,:) :: t_ttend - real(r8), pointer, dimension(:,:) :: t_utend - real(r8), pointer, dimension(:,:) :: t_vtend - - lchnk = state%lchnk - ncol = state%ncol - - do k = 1, pver - do i = 1, ncol - dtcond(i,k,lchnk) = state%t(i,k) - end do - end do - - do m = 1, dqcond_num - do k = 1, pver - do i = 1, ncol - dqcond(m)%cnst(i,k,lchnk) = state%q(i,k,m) - end do - end do - end do - - !! initialize to pbuf T_TTEND to temperature at first timestep - if (is_first_step()) then - do m = 1, dyn_time_lvls - call pbuf_get_field(pbuf, t_ttend_idx, t_ttend, start=(/1,1,m/), kount=(/pcols,pver,1/)) - t_ttend(:ncol,:) = state%t(:ncol,:) - call pbuf_get_field(pbuf, t_utend_idx, t_utend, start=(/1,1,m/), kount=(/pcols,pver,1/)) - t_utend(:ncol,:) = state%u(:ncol,:) - call pbuf_get_field(pbuf, t_vtend_idx, t_vtend, start=(/1,1,m/), kount=(/pcols,pver,1/)) - t_vtend(:ncol,:) = state%v(:ncol,:) - end do - end if - - end subroutine diag_conv_tend_ini - -!=============================================================================== - - subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) - - !----------------------------------------------------------------------- - ! - ! Purpose: output dry physics diagnostics - ! - !----------------------------------------------------------------------- - use physconst, only: gravit, rga, rair, cappa - use time_manager, only: get_nstep - use interpolate_data, only: vertinterp - use tidal_diag, only: tidal_diag_write - use air_composition, only: cpairv, rairv - use cam_diagnostic_utils, only: cpslec - !----------------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface - ! - !---------------------------Local workspace----------------------------- - ! - real(r8) :: ftem(pcols,pver) ! temporary workspace - real(r8) :: z3(pcols,pver) ! geo-potential height - real(r8) :: p_surf(pcols) ! data interpolated to a pressure surface - real(r8) :: timestep(pcols) ! used for outfld call - - real(r8), pointer :: psl(:) ! Sea Level Pressure - - integer :: i, k, m, lchnk, ncol, nstep - ! - !----------------------------------------------------------------------- - ! - lchnk = state%lchnk - ncol = state%ncol - - ! Output NSTEP for debugging - nstep = get_nstep() - timestep(:ncol) = nstep - call outfld ('NSTEP ',timestep, pcols, lchnk) - - call outfld('T ',state%t , pcols ,lchnk ) - call outfld('PS ',state%ps, pcols ,lchnk ) - call outfld('U ',state%u , pcols ,lchnk ) - call outfld('V ',state%v , pcols ,lchnk ) - - call outfld('PHIS ',state%phis, pcols, lchnk ) - - if (write_camiop) call outfld('phis ',state%phis, pcols, lchnk ) - - call outfld( 'CPAIRV', cpairv(:ncol,:,lchnk), ncol, lchnk ) - call outfld( 'RAIRV', rairv(:ncol,:,lchnk), ncol, lchnk ) - - do m = 1, pcnst - if (cnst_cam_outfld(m)) then - call outfld(cnst_name(m), state%q(1,1,m), pcols, lchnk) - end if - end do - - ! - ! Add height of surface to midpoint height above surface - ! - do k = 1, pver - z3(:ncol,k) = state%zm(:ncol,k) + state%phis(:ncol)*rga - end do - call outfld('Z3 ',z3,pcols,lchnk) - ! - ! Output Z3 on pressure surfaces - ! - if (hist_fld_active('Z1000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, z3, p_surf, & - extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) - call outfld('Z1000 ', p_surf, pcols, lchnk) - end if - if (hist_fld_active('Z700')) then - call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, z3, p_surf, & - extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) - call outfld('Z700 ', p_surf, pcols, lchnk) - end if - if (hist_fld_active('Z500')) then - call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, z3, p_surf, & - extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) - call outfld('Z500 ', p_surf, pcols, lchnk) - end if - if (hist_fld_active('Z300')) then - call vertinterp(ncol, pcols, pver, state%pmid, 30000._r8, z3, p_surf, ln_interp=.true.) - call outfld('Z300 ', p_surf, pcols, lchnk) - end if - if (hist_fld_active('Z200')) then - call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, z3, p_surf, ln_interp=.true.) - call outfld('Z200 ', p_surf, pcols, lchnk) - end if - if (hist_fld_active('Z100')) then - call vertinterp(ncol, pcols, pver, state%pmid, 10000._r8, z3, p_surf, ln_interp=.true.) - call outfld('Z100 ', p_surf, pcols, lchnk) - end if - if (hist_fld_active('Z050')) then - call vertinterp(ncol, pcols, pver, state%pmid, 5000._r8, z3, p_surf, ln_interp=.true.) - call outfld('Z050 ', p_surf, pcols, lchnk) - end if - ! - ! Quadratic height fiels Z3*Z3 - ! - ftem(:ncol,:) = z3(:ncol,:)*z3(:ncol,:) - call outfld('ZZ ',ftem,pcols,lchnk) - - ftem(:ncol,:) = z3(:ncol,:)*state%v(:ncol,:) - call outfld('VZ ',ftem, pcols,lchnk) - ! - ! Meridional advection fields - ! - ftem(:ncol,:) = state%v(:ncol,:)*state%t(:ncol,:) - call outfld ('VT ',ftem ,pcols ,lchnk ) - - ftem(:ncol,:) = state%v(:ncol,:)**2 - call outfld ('VV ',ftem ,pcols ,lchnk ) - - ftem(:ncol,:) = state%v(:ncol,:) * state%u(:ncol,:) - call outfld ('VU ',ftem ,pcols ,lchnk ) - ! - ! zonal advection - ! - ftem(:ncol,:) = state%u(:ncol,:)*state%t(:ncol,:) - call outfld ('UT ',ftem ,pcols ,lchnk ) - - ftem(:ncol,:) = state%u(:ncol,:)**2 - call outfld ('UU ',ftem ,pcols ,lchnk ) - - ! Wind speed - ftem(:ncol,:) = sqrt( state%u(:ncol,:)**2 + state%v(:ncol,:)**2) - call outfld ('WSPEED ',ftem ,pcols ,lchnk ) - call outfld ('WSPDSRFMX',ftem(:,pver) ,pcols ,lchnk ) - call outfld ('WSPDSRFAV',ftem(:,pver) ,pcols ,lchnk ) - - ! Vertical velocity and advection - - if (single_column) then - call outfld('OMEGA ',wfld, pcols, lchnk ) - else - call outfld('OMEGA ',state%omega, pcols, lchnk ) - endif - - if (write_camiop) call outfld('omega ',state%omega, pcols, lchnk ) - - ftem(:ncol,:) = state%omega(:ncol,:)*state%t(:ncol,:) - call outfld('OMEGAT ',ftem, pcols, lchnk ) - ftem(:ncol,:) = state%omega(:ncol,:)*state%u(:ncol,:) - call outfld('OMEGAU ',ftem, pcols, lchnk ) - ftem(:ncol,:) = state%omega(:ncol,:)*state%v(:ncol,:) - call outfld('OMEGAV ',ftem, pcols, lchnk ) - ftem(:ncol,:) = state%omega(:ncol,:)*state%omega(:ncol,:) - call outfld('OMGAOMGA',ftem, pcols, lchnk ) - ! - ! Output omega at 850 and 500 mb pressure levels - ! - if (hist_fld_active('OMEGA850')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%omega, p_surf) - call outfld('OMEGA850', p_surf, pcols, lchnk) - end if - if (hist_fld_active('OMEGA500')) then - call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%omega, p_surf) - call outfld('OMEGA500', p_surf, pcols, lchnk) - end if - - ! Sea level pressure - call pbuf_get_field(pbuf, psl_idx, psl) - call cpslec(ncol, state%pmid, state%phis, state%ps, state%t, psl, gravit, rair) - call outfld('PSL', psl, pcols, lchnk) - - ! Output T,u,v fields on pressure surfaces - ! - if (hist_fld_active('T850')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf, & - extrapolate='T', ps=state%ps, phis=state%phis) - call outfld('T850 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('T500')) then - call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%t, p_surf, & - extrapolate='T', ps=state%ps, phis=state%phis) - call outfld('T500 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('T400')) then - call vertinterp(ncol, pcols, pver, state%pmid, 40000._r8, state%t, p_surf, & - extrapolate='T', ps=state%ps, phis=state%phis) - call outfld('T400 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('T300')) then - call vertinterp(ncol, pcols, pver, state%pmid, 30000._r8, state%t, p_surf) - call outfld('T300 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('T200')) then - call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%t, p_surf) - call outfld('T200 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('U850')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%u, p_surf) - call outfld('U850 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('U500')) then - call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%u, p_surf) - call outfld('U500 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('U250')) then - call vertinterp(ncol, pcols, pver, state%pmid, 25000._r8, state%u, p_surf) - call outfld('U250 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('U200')) then - call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%u, p_surf) - call outfld('U200 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('U010')) then - call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%u, p_surf) - call outfld('U010 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('V850')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%v, p_surf) - call outfld('V850 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('V500')) then - call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%v, p_surf) - call outfld('V500 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('V250')) then - call vertinterp(ncol, pcols, pver, state%pmid, 25000._r8, state%v, p_surf) - call outfld('V250 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('V200')) then - call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%v, p_surf) - call outfld('V200 ', p_surf, pcols, lchnk ) - end if - - ftem(:ncol,:) = state%t(:ncol,:)*state%t(:ncol,:) - call outfld('TT ',ftem ,pcols ,lchnk ) - ! - ! Output U, V, T, P and Z at bottom level - ! - call outfld ('UBOT ', state%u(1,pver) , pcols, lchnk) - call outfld ('VBOT ', state%v(1,pver) , pcols, lchnk) - call outfld ('ZBOT ', state%zm(1,pver) , pcols, lchnk) - - !! Boundary layer atmospheric stability, temperature, water vapor diagnostics - - p_surf_t = -99.0_r8 ! Uninitialized to impossible value - if (hist_fld_active('T1000') .or. & - hist_fld_active('T9251000') .or. & - hist_fld_active('TH9251000') .or. & - hist_fld_active('T8501000') .or. & - hist_fld_active('TH8501000') .or. & - hist_fld_active('T7001000') .or. & - hist_fld_active('TH7001000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%t, p_surf_t(:,surf_100000)) - end if - - if ( hist_fld_active('T925') .or. & - hist_fld_active('T9251000') .or. & - hist_fld_active('TH9251000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%t, p_surf_t(:,surf_092500)) - end if - -!!! at 1000 mb and 925 mb - if (hist_fld_active('T1000')) then - call outfld('T1000 ', p_surf_t(:,surf_100000), pcols, lchnk ) - end if - - if (hist_fld_active('T925')) then - call outfld('T925 ', p_surf_t(:,surf_092500), pcols, lchnk ) - end if - - if (hist_fld_active('T9251000')) then - p_surf = p_surf_t(:,surf_092500) - p_surf_t(:,surf_100000) - call outfld('T9251000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('TH9251000')) then - p_surf = (p_surf_t(:,surf_092500)*(1000.0_r8/925.0_r8)**cappa) - (p_surf_t(:,surf_100000)*(1.0_r8)**cappa) - call outfld('TH9251000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('T8501000') .or. & - hist_fld_active('TH8501000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf_t(:,surf_085000)) - end if - -!!! at 1000 mb and 850 mb - if (hist_fld_active('T8501000')) then - p_surf = p_surf_t(:,surf_085000)-p_surf_t(:,surf_100000) - call outfld('T8501000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('TH8501000')) then - p_surf = (p_surf_t(:,surf_085000)*(1000.0_r8/850.0_r8)**cappa)-(p_surf_t(:,surf_100000)*(1.0_r8)**cappa) - call outfld('TH8501000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('T7001000') .or. & - hist_fld_active('TH7001000') .or. & - hist_fld_active('T700')) then - call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%t, p_surf_t(:,surf_070000)) - end if - -!!! at 700 mb - if (hist_fld_active('T700')) then - call outfld('T700 ', p_surf_t(:,surf_070000), pcols, lchnk ) - end if - -!!! at 1000 mb and 700 mb - if (hist_fld_active('T7001000')) then - p_surf = p_surf_t(:,surf_070000)-p_surf_t(:,surf_100000) - call outfld('T7001000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('TH7001000')) then - p_surf = (p_surf_t(:,surf_070000)*(1000.0_r8/700.0_r8)**cappa)-(p_surf_t(:,surf_100000)*(1.0_r8)**cappa) - call outfld('TH7001000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('T010')) then - call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%t, p_surf) - call outfld('T010 ', p_surf, pcols, lchnk ) - end if - - !--------------------------------------------------------- - ! tidal diagnostics - !--------------------------------------------------------- - call tidal_diag_write(state) - - return - end subroutine diag_phys_writeout_dry - -!=============================================================================== - - subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) - - !----------------------------------------------------------------------- - ! - ! Purpose: record dynamics variables on physics grid - ! - !----------------------------------------------------------------------- - use physconst, only: gravit, rga, rair, cpair, latvap, rearth, cappa - use interpolate_data, only: vertinterp - use constituent_burden, only: constituent_burden_comp - use co2_cycle, only: c_i, co2_transport - !----------------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(inout) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface - ! - !---------------------------Local workspace----------------------------- - ! - real(r8) :: ftem(pcols,pver) ! temporary workspace - real(r8) :: ftem1(pcols,pver) ! another temporary workspace - real(r8) :: ftem2(pcols,pver) ! another temporary workspace - real(r8) :: p_surf(pcols) ! data interpolated to a pressure surface - real(r8) :: p_surf_q1(pcols) ! data interpolated to a pressure surface - real(r8) :: p_surf_q2(pcols) ! data interpolated to a pressure surface - real(r8) :: tem2(pcols,pver) ! temporary workspace - real(r8) :: esl(pcols,pver) ! saturation vapor pressures - real(r8) :: esi(pcols,pver) ! - - real(r8), pointer :: ftem_ptr(:,:) - - integer :: i, k, m, lchnk, ncol - integer :: ixq, ierr - ! - !----------------------------------------------------------------------- - ! - lchnk = state%lchnk - ncol = state%ncol - - call cnst_get_ind('Q', ixq) - - if (co2_transport()) then - do m = 1,4 - call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(1,pver,c_i(m)), pcols, lchnk) - end do - end if - - ! column burdens of all constituents except water vapor - call constituent_burden_comp(state) - - call outfld('PSDRY', state%psdry, pcols, lchnk) - call outfld('PMID', state%pmid, pcols, lchnk) - call outfld('PINT', state%pint, pcols, lchnk) - call outfld('PDELDRY', state%pdeldry, pcols, lchnk) - call outfld('PDEL', state%pdel, pcols, lchnk) - - - ftem(:ncol,:) = state%u(:ncol,:)*state%q(:ncol,:,ixq) - call outfld ('UQ ',ftem ,pcols ,lchnk ) - - ftem(:ncol,:) = state%v(:ncol,:)*state%q(:ncol,:,ixq) - call outfld ('VQ ',ftem ,pcols ,lchnk ) - - ftem(:ncol,:) = state%q(:ncol,:,1)*state%q(:ncol,:,ixq) - call outfld ('QQ ',ftem ,pcols ,lchnk ) - - ! Vertical velocity and advection - ftem(:ncol,:) = state%omega(:ncol,:)*state%q(:ncol,:,ixq) - call outfld('OMEGAQ ',ftem, pcols, lchnk ) - ! - ! Mass of q, by layer and vertically integrated - ! - ftem(:ncol,:) = state%q(:ncol,:,ixq) * state%pdel(:ncol,:) * rga - call outfld ('MQ ',ftem ,pcols ,lchnk ) - - do k=2,pver - ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) - end do - call outfld ('TMQ ',ftem, pcols ,lchnk ) - ! - ! Integrated vapor transport calculation - ! - !compute uq*dp/g and vq*dp/g - ftem1(:ncol,:) = state%q(:ncol,:,ixq) * state%u(:ncol,:) *state%pdel(:ncol,:) * rga - ftem2(:ncol,:) = state%q(:ncol,:,ixq) * state%v(:ncol,:) *state%pdel(:ncol,:) * rga - - do k=2,pver - ftem1(:ncol,1) = ftem1(:ncol,1) + ftem1(:ncol,k) - ftem2(:ncol,1) = ftem2(:ncol,1) + ftem2(:ncol,k) - end do - ! compute ivt - ftem(:ncol,1) = sqrt( ftem1(:ncol,1)**2 + ftem2(:ncol,1)**2) - - call outfld ('IVT ',ftem, pcols ,lchnk ) - - ! output uq*dp/g - call outfld ('uIVT ',ftem1, pcols ,lchnk ) - - ! output vq*dp/g - call outfld ('vIVT ',ftem2, pcols ,lchnk ) - ! - ! Relative humidity - ! - if (hist_fld_active('RELHUM')) then - if (relhum_idx > 0) then - call pbuf_get_field(pbuf, relhum_idx, ftem_ptr) - ftem(:ncol,:) = ftem_ptr(:ncol,:) - else - do k = 1, pver - call qsat(state%t(1:ncol,k), state%pmid(1:ncol,k), tem2(1:ncol,k), ftem(1:ncol,k), ncol) - end do - ftem(:ncol,:) = state%q(:ncol,:,ixq)/ftem(:ncol,:)*100._r8 - end if - call outfld ('RELHUM ',ftem ,pcols ,lchnk ) - end if - - if (hist_fld_active('RHW') .or. hist_fld_active('RHI') .or. hist_fld_active('RHCFMIP') ) then - - ! RH w.r.t liquid (water) - do k = 1, pver - call qsat_water (state%t(1:ncol,k), state%pmid(1:ncol,k), esl(1:ncol,k), ftem(1:ncol,k), ncol) - end do - ftem(:ncol,:) = state%q(:ncol,:,ixq)/ftem(:ncol,:)*100._r8 - call outfld ('RHW ',ftem ,pcols ,lchnk ) - - ! Convert to RHI (ice) - do k=1,pver - call svp_ice_vect(state%t(1:ncol,k), esi(1:ncol,k), ncol) - do i=1,ncol - ftem1(i,k)=ftem(i,k)*esl(i,k)/esi(i,k) - end do - end do - call outfld ('RHI ',ftem1 ,pcols ,lchnk ) - - ! use temperature to decide if you populate with ftem (liquid, above 0 C) or ftem1 (ice, below 0 C) - - ftem2(:ncol,:)=ftem(:ncol,:) - - do i=1,ncol - do k=1,pver - if (state%t(i,k) .gt. 273) then - ftem2(i,k)=ftem(i,k) !!wrt water - else - ftem2(i,k)=ftem1(i,k) !!wrt ice - end if - end do - end do - - call outfld ('RHCFMIP ',ftem2 ,pcols ,lchnk ) - - end if - ! - ! Output q field on pressure surfaces - ! - if (hist_fld_active('Q850')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,ixq), p_surf) - call outfld('Q850 ', p_surf, pcols, lchnk ) - end if - if (hist_fld_active('Q200')) then - call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%q(1,1,ixq), p_surf) - call outfld('Q200 ', p_surf, pcols, lchnk ) - end if - ! - ! Output Q at bottom level - ! - call outfld ('QBOT ', state%q(1,pver,ixq), pcols, lchnk) - - ! Total energy of the atmospheric column for atmospheric heat storage calculations - - !! temporary variable to get surface geopotential in dimensions of (ncol,pver) - do k=1,pver - ftem1(:ncol,k)=state%phis(:ncol) !! surface geopotential in units (m2/s2) - end do - - !! calculate sum of sensible, kinetic, latent, and surface geopotential energy - !! E=CpT+PHIS+Lv*q+(0.5)*(u^2+v^2) - ftem(:ncol,:) = (cpair*state%t(:ncol,:) + ftem1(:ncol,:) + latvap*state%q(:ncol,:,ixq) + & - 0.5_r8*(state%u(:ncol,:)**2+state%v(:ncol,:)**2))*(state%pdel(:ncol,:)/gravit) - !! vertically integrate - do k=2,pver - ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) - end do - call outfld ('ATMEINT ', ftem(:ncol,1), ncol, lchnk) - - !! Boundary layer atmospheric stability, temperature, water vapor diagnostics - - if ( hist_fld_active('THE9251000') .or. & - hist_fld_active('THE8501000') .or. & - hist_fld_active('THE7001000')) then - if (p_surf_t(1, surf_100000) < 0.0_r8) then - call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%t, p_surf_t(:, surf_100000)) - end if - end if - - if ( hist_fld_active('TH9251000') .or. & - hist_fld_active('THE9251000')) then - if (p_surf_t(1, surf_092500) < 0.0_r8) then - call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%t, p_surf_t(:, surf_092500)) - end if - end if - - if ( hist_fld_active('Q1000') .or. & - hist_fld_active('THE9251000') .or. & - hist_fld_active('THE8501000') .or. & - hist_fld_active('THE7001000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%q(1,1,ixq), p_surf_q1) - end if - - if (hist_fld_active('THE9251000') .or. & - hist_fld_active('Q925')) then - call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%q(1,1,ixq), p_surf_q2) - end if - -!!! at 1000 mb and 925 mb - if (hist_fld_active('Q1000')) then - call outfld('Q1000 ', p_surf_q1, pcols, lchnk ) - end if - - if (hist_fld_active('Q925')) then - call outfld('Q925 ', p_surf_q2, pcols, lchnk ) - end if - - if (hist_fld_active('THE9251000')) then - p_surf = ((p_surf_t(:, surf_092500)*(1000.0_r8/925.0_r8)**cappa) * & - exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_092500)))) - & - (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) - call outfld('THE9251000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('THE8501000')) then - if (p_surf_t(1, surf_085000) < 0.0_r8) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf_t(:, surf_085000)) - end if - end if - -!!! at 1000 mb and 850 mb - if (hist_fld_active('THE8501000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,ixq), p_surf_q2) - p_surf = ((p_surf_t(:, surf_085000)*(1000.0_r8/850.0_r8)**cappa) * & - exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_085000)))) - & - (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) - call outfld('THE8501000 ', p_surf, pcols, lchnk ) - end if - - if (hist_fld_active('THE7001000')) then - if (p_surf_t(1, surf_070000) < 0.0_r8) then - call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%t, p_surf_t(:, surf_070000)) - end if - end if - -!!! at 1000 mb and 700 mb - if (hist_fld_active('THE7001000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%q(1,1,ixq), p_surf_q2) - p_surf = ((p_surf_t(:, surf_070000)*(1000.0_r8/700.0_r8)**cappa) * & - exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_070000)))) - & - (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) - call outfld('THE7001000 ', p_surf, pcols, lchnk ) - end if - - return - end subroutine diag_phys_writeout_moist - -!=============================================================================== - - subroutine diag_phys_writeout(state, pbuf) - - !----------------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - ! Local variable - real(r8) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface - - call diag_phys_writeout_dry(state, pbuf, p_surf_t) - - if (moist_physics) then - call diag_phys_writeout_moist(state, pbuf, p_surf_t) - end if - - end subroutine diag_phys_writeout - -!=============================================================================== - - subroutine diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) - - !----------------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(in) :: state - type(physics_ptend), intent(in) :: ptend - integer :: ncol - integer :: lchnk - integer :: ixcldliq - integer :: ixcldice - integer :: ixq - real(r8) :: ztodt - real(r8) :: rtdt - - ! Local variables - - ! Debugging output to look at ice tendencies due to hard clipping negative values - real(r8) :: preclipice(pcols,pver) - real(r8) :: icecliptend(pcols,pver) - real(r8) :: preclipliq(pcols,pver) - real(r8) :: liqcliptend(pcols,pver) - real(r8) :: preclipvap(pcols,pver) - real(r8) :: vapcliptend(pcols,pver) - - ! Initialize to zero - liqcliptend(:,:) = 0._r8 - icecliptend(:,:) = 0._r8 - vapcliptend(:,:) = 0._r8 - - preclipliq(:ncol,:) = state%q(:ncol,:,ixcldliq)+(ptend%q(:ncol,:,ixcldliq)*ztodt) - preclipice(:ncol,:) = state%q(:ncol,:,ixcldice)+(ptend%q(:ncol,:,ixcldice)*ztodt) - preclipvap(:ncol,:) = state%q(:ncol,:,ixq)+(ptend%q(:ncol,:,ixq)*ztodt) - vapcliptend(:ncol,:) = (state%q(:ncol,:,ixq)-preclipvap(:ncol,:))*rtdt - icecliptend(:ncol,:) = (state%q(:ncol,:,ixcldice)-preclipice(:ncol,:))*rtdt - liqcliptend(:ncol,:) = (state%q(:ncol,:,ixcldliq)-preclipliq(:ncol,:))*rtdt - - call outfld('INEGCLPTEND', icecliptend, pcols, lchnk ) - call outfld('LNEGCLPTEND', liqcliptend, pcols, lchnk ) - call outfld('VNEGCLPTEND', vapcliptend, pcols, lchnk ) - - end subroutine diag_clip_tend_writeout - -!=============================================================================== - - subroutine diag_conv(state, ztodt, pbuf) - - !----------------------------------------------------------------------- - ! - ! Output diagnostics associated with all convective processes. - ! - !----------------------------------------------------------------------- - use tidal_diag, only: get_tidal_coeffs - - ! Arguments: - - real(r8), intent(in) :: ztodt ! timestep for computing physics tendencies - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - ! convective precipitation variables - real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8), pointer :: snow_dp(:) ! snow from ZM convection - real(r8), pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8), pointer :: snow_sh(:) ! snow from Hack convection - real(r8), pointer :: prec_sed(:) ! total precipitation from MG sedimentation - real(r8), pointer :: snow_sed(:) ! snow from MG sedimentation - real(r8), pointer :: prec_pcw(:) ! total precipitation from MG prog. cloud - real(r8), pointer :: snow_pcw(:) ! snow from MG prog. cloud - - ! Local variables: - - integer :: i, k, m, lchnk, ncol - - real(r8) :: rtdt - - real(r8):: precc(pcols) ! convective precip rate - real(r8):: precl(pcols) ! stratiform precip rate - real(r8):: snowc(pcols) ! convective snow rate - real(r8):: snowl(pcols) ! stratiform snow rate - real(r8):: prect(pcols) ! total (conv+large scale) precip rate - real(r8) :: dcoef(6) ! for tidal component of T tend - - lchnk = state%lchnk - ncol = state%ncol - - rtdt = 1._r8/ztodt - - if (moist_physics) then - if (prec_dp_idx > 0) then - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) - else - nullify(prec_dp) - end if - if (snow_dp_idx > 0) then - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) - else - nullify(snow_dp) - end if - if (prec_sh_idx > 0) then - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) - else - nullify(prec_sh) - end if - if (snow_sh_idx > 0) then - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) - else - nullify(snow_sh) - end if - if (prec_sed_idx > 0) then - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) - else - nullify(prec_sed) - end if - if (snow_sed_idx > 0) then - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) - else - nullify(snow_sed) - end if - if (prec_pcw_idx > 0) then - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) - else - nullify(prec_pcw) - end if - if (snow_pcw_idx > 0) then - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) - else - nullify(snow_pcw) - end if - - ! Precipitation rates (multi-process) - if (associated(prec_dp) .and. associated(prec_sh)) then - precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) - else if (associated(prec_dp)) then - precc(:ncol) = prec_dp(:ncol) - else if (associated(prec_sh)) then - precc(:ncol) = prec_sh(:ncol) - else - precc(:ncol) = 0._r8 - end if - if (associated(prec_sed) .and. associated(prec_pcw)) then - precl(:ncol) = prec_sed(:ncol) + prec_pcw(:ncol) - else if (associated(prec_sed)) then - precl(:ncol) = prec_sed(:ncol) - else if (associated(prec_pcw)) then - precl(:ncol) = prec_pcw(:ncol) - else - precl(:ncol) = 0._r8 - end if - if (associated(snow_dp) .and. associated(snow_sh)) then - snowc(:ncol) = snow_dp(:ncol) + snow_sh(:ncol) - else if (associated(snow_dp)) then - snowc(:ncol) = snow_dp(:ncol) - else if (associated(snow_sh)) then - snowc(:ncol) = snow_sh(:ncol) - else - snowc(:ncol) = 0._r8 - end if - if (associated(snow_sed) .and. associated(snow_pcw)) then - snowl(:ncol) = snow_sed(:ncol) + snow_pcw(:ncol) - else if (associated(snow_sed)) then - snowl(:ncol) = snow_sed(:ncol) - else if (associated(snow_pcw)) then - snowl(:ncol) = snow_pcw(:ncol) - else - snowl(:ncol) = 0._r8 - end if - prect(:ncol) = precc(:ncol) + precl(:ncol) - - call outfld('PRECC ', precc, pcols, lchnk ) - call outfld('PRECL ', precl, pcols, lchnk ) - if (associated(prec_pcw)) then - call outfld('PREC_PCW', prec_pcw,pcols ,lchnk ) - end if - if (associated(prec_dp)) then - call outfld('PREC_zmc', prec_dp ,pcols ,lchnk ) - end if - call outfld('PRECSC ', snowc, pcols, lchnk ) - call outfld('PRECSL ', snowl, pcols, lchnk ) - call outfld('PRECT ', prect, pcols, lchnk ) - call outfld('PRECTMX ', prect, pcols, lchnk ) - - call outfld('PRECLav ', precl, pcols, lchnk ) - call outfld('PRECCav ', precc, pcols, lchnk ) - - if (write_camiop) call outfld('Prec ' , prect, pcols, lchnk ) - - ! Total convection tendencies. - - do k = 1, pver - do i = 1, ncol - dtcond(i,k,lchnk) = (state%t(i,k) - dtcond(i,k,lchnk))*rtdt - end do - end do - call outfld('DTCOND ', dtcond(:,:,lchnk), pcols, lchnk) - - ! output tidal coefficients - call get_tidal_coeffs( dcoef ) - call outfld( 'DTCOND_24_SIN', dtcond(:ncol,:,lchnk)*dcoef(1), ncol, lchnk ) - call outfld( 'DTCOND_24_COS', dtcond(:ncol,:,lchnk)*dcoef(2), ncol, lchnk ) - call outfld( 'DTCOND_12_SIN', dtcond(:ncol,:,lchnk)*dcoef(3), ncol, lchnk ) - call outfld( 'DTCOND_12_COS', dtcond(:ncol,:,lchnk)*dcoef(4), ncol, lchnk ) - call outfld( 'DTCOND_08_SIN', dtcond(:ncol,:,lchnk)*dcoef(5), ncol, lchnk ) - call outfld( 'DTCOND_08_COS', dtcond(:ncol,:,lchnk)*dcoef(6), ncol, lchnk ) - - do m = 1, dqcond_num - if ( cnst_cam_outfld(m) ) then - do k = 1, pver - do i = 1, ncol - dqcond(m)%cnst(i,k,lchnk) = (state%q(i,k,m) - dqcond(m)%cnst(i,k,lchnk))*rtdt - end do - end do - call outfld(dcconnam(m), dqcond(m)%cnst(:,:,lchnk), pcols, lchnk) - end if - end do - - end if - end subroutine diag_conv - -!=============================================================================== - - subroutine diag_surf (cam_in, cam_out, state, pbuf) - - !----------------------------------------------------------------------- - ! - ! Purpose: record surface diagnostics - ! - !----------------------------------------------------------------------- - - use time_manager, only: is_end_curr_day - use co2_cycle, only: c_i, co2_transport - use constituents, only: sflxnam - - !----------------------------------------------------------------------- - ! - ! Input arguments - ! - type(cam_in_t), intent(in) :: cam_in - type(cam_out_t), intent(in) :: cam_out - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - ! - !---------------------------Local workspace----------------------------- - ! - integer :: i, k, m ! indexes - integer :: lchnk ! chunk identifier - integer :: ncol ! longitude dimension - real(r8) tem2(pcols) ! temporary workspace - real(r8) ftem(pcols) ! temporary workspace - - real(r8), pointer :: trefmnav(:) ! daily minimum tref - real(r8), pointer :: trefmxav(:) ! daily maximum tref - - ! - !----------------------------------------------------------------------- - ! - lchnk = cam_in%lchnk - ncol = cam_in%ncol - - if (moist_physics) then - call outfld('SHFLX', cam_in%shf, pcols, lchnk) - call outfld('LHFLX', cam_in%lhf, pcols, lchnk) - call outfld('QFLX', cam_in%cflx(1,1), pcols, lchnk) - - call outfld('TAUX', cam_in%wsx, pcols, lchnk) - call outfld('TAUY', cam_in%wsy, pcols, lchnk) - call outfld('TREFHT ', cam_in%tref, pcols, lchnk) - call outfld('TREFHTMX', cam_in%tref, pcols, lchnk) - call outfld('TREFHTMN', cam_in%tref, pcols, lchnk) - call outfld('QREFHT', cam_in%qref, pcols, lchnk) - call outfld('U10', cam_in%u10, pcols, lchnk) - call outfld('UGUST', cam_in%ugustOut, pcols, lchnk) - call outfld('U10WITHGUSTS',cam_in%u10withGusts, pcols, lchnk) - - ! - ! Calculate and output reference height RH (RHREFHT) - call qsat(cam_in%tref(1:ncol), state%ps(1:ncol), tem2(1:ncol), ftem(1:ncol), ncol) - ftem(:ncol) = cam_in%qref(:ncol)/ftem(:ncol)*100._r8 - - - call outfld('RHREFHT', ftem, pcols, lchnk) - - - if (write_camiop) then - call outfld('shflx ',cam_in%shf, pcols, lchnk) - call outfld('lhflx ',cam_in%lhf, pcols, lchnk) - call outfld('trefht ',cam_in%tref, pcols, lchnk) - call outfld('Tg', cam_in%ts, pcols, lchnk) - call outfld('Tsair',cam_in%ts, pcols, lchnk) - end if - ! - ! Ouput ocn and ice fractions - ! - call outfld('LANDFRAC', cam_in%landfrac, pcols, lchnk) - call outfld('ICEFRAC', cam_in%icefrac, pcols, lchnk) - call outfld('OCNFRAC', cam_in%ocnfrac, pcols, lchnk) - ! - ! Compute daily minimum and maximum of TREF - ! - call pbuf_get_field(pbuf, trefmxav_idx, trefmxav) - call pbuf_get_field(pbuf, trefmnav_idx, trefmnav) - do i = 1,ncol - trefmxav(i) = max(cam_in%tref(i),trefmxav(i)) - trefmnav(i) = min(cam_in%tref(i),trefmnav(i)) - end do - if (is_end_curr_day()) then - call outfld('TREFMXAV', trefmxav,pcols, lchnk ) - call outfld('TREFMNAV', trefmnav,pcols, lchnk ) - trefmxav(:ncol) = -1.0e36_r8 - trefmnav(:ncol) = 1.0e36_r8 - endif - - call outfld('TBOT', cam_out%tbot, pcols, lchnk) - call outfld('TS', cam_in%ts, pcols, lchnk) - call outfld('TSMN', cam_in%ts, pcols, lchnk) - call outfld('TSMX', cam_in%ts, pcols, lchnk) - call outfld('SNOWHLND', cam_in%snowhland, pcols, lchnk) - call outfld('SNOWHICE', cam_in%snowhice, pcols, lchnk) - call outfld('ASDIR', cam_in%asdir, pcols, lchnk) - call outfld('ASDIF', cam_in%asdif, pcols, lchnk) - call outfld('ALDIR', cam_in%aldir, pcols, lchnk) - call outfld('ALDIF', cam_in%aldif, pcols, lchnk) - call outfld('SST', cam_in%sst, pcols, lchnk) - - if (co2_transport()) then - do m = 1,4 - call outfld(sflxnam(c_i(m)), cam_in%cflx(:,c_i(m)), pcols, lchnk) - end do - end if - end if - - end subroutine diag_surf - -!=============================================================================== - - subroutine diag_export(cam_out) - - !----------------------------------------------------------------------- - ! - ! Purpose: Write export state to history file - ! - !----------------------------------------------------------------------- - - ! arguments - type(cam_out_t), intent(inout) :: cam_out - - ! Local variables: - integer :: lchnk ! chunk identifier - logical :: atm_dep_flux ! true ==> sending deposition fluxes to coupler. - ! Otherwise, set them to zero. - !----------------------------------------------------------------------- - - lchnk = cam_out%lchnk - - call phys_getopts(atm_dep_flux_out=atm_dep_flux) - - if (.not. atm_dep_flux) then - ! set the fluxes to zero before outfld and sending them to the - ! coupler - cam_out%bcphiwet = 0.0_r8 - cam_out%bcphidry = 0.0_r8 - cam_out%bcphodry = 0.0_r8 - cam_out%ocphiwet = 0.0_r8 - cam_out%ocphidry = 0.0_r8 - cam_out%ocphodry = 0.0_r8 - cam_out%dstwet1 = 0.0_r8 - cam_out%dstdry1 = 0.0_r8 - cam_out%dstwet2 = 0.0_r8 - cam_out%dstdry2 = 0.0_r8 - cam_out%dstwet3 = 0.0_r8 - cam_out%dstdry3 = 0.0_r8 - cam_out%dstwet4 = 0.0_r8 - cam_out%dstdry4 = 0.0_r8 - end if - - if (moist_physics) then - call outfld('a2x_BCPHIWET', cam_out%bcphiwet, pcols, lchnk) - call outfld('a2x_BCPHIDRY', cam_out%bcphidry, pcols, lchnk) - call outfld('a2x_BCPHODRY', cam_out%bcphodry, pcols, lchnk) - call outfld('a2x_OCPHIWET', cam_out%ocphiwet, pcols, lchnk) - call outfld('a2x_OCPHIDRY', cam_out%ocphidry, pcols, lchnk) - call outfld('a2x_OCPHODRY', cam_out%ocphodry, pcols, lchnk) - call outfld('a2x_DSTWET1', cam_out%dstwet1, pcols, lchnk) - call outfld('a2x_DSTDRY1', cam_out%dstdry1, pcols, lchnk) - call outfld('a2x_DSTWET2', cam_out%dstwet2, pcols, lchnk) - call outfld('a2x_DSTDRY2', cam_out%dstdry2, pcols, lchnk) - call outfld('a2x_DSTWET3', cam_out%dstwet3, pcols, lchnk) - call outfld('a2x_DSTDRY3', cam_out%dstdry3, pcols, lchnk) - call outfld('a2x_DSTWET4', cam_out%dstwet4, pcols, lchnk) - call outfld('a2x_DSTDRY4', cam_out%dstdry4, pcols, lchnk) - end if - - end subroutine diag_export - -!####################################################################### - - subroutine diag_physvar_ic (lchnk, pbuf, cam_out, cam_in) - ! - !--------------------------------------------- - ! - ! Purpose: record physics variables on IC file - ! - !--------------------------------------------- - ! - - ! - ! Arguments - ! - integer , intent(in) :: lchnk ! chunk identifier - type(physics_buffer_desc), pointer :: pbuf(:) - - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(inout) :: cam_in - ! - !---------------------------Local workspace----------------------------- - ! - integer :: itim_old ! indices - - real(r8), pointer, dimension(:,:) :: cwat_var - real(r8), pointer, dimension(:,:) :: conv_var_3d - real(r8), pointer, dimension(: ) :: conv_var_2d - real(r8), pointer :: tpert(:), pblh(:), qpert(:) - ! - !----------------------------------------------------------------------- - ! - if( write_inithist() .and. moist_physics ) then - - ! - ! Associate pointers with physics buffer fields - ! - itim_old = pbuf_old_tim_idx() - - if (qcwat_idx > 0) then - call pbuf_get_field(pbuf, qcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call outfld('QCWAT&IC ',cwat_var, pcols,lchnk) - end if - - if (tcwat_idx > 0) then - call pbuf_get_field(pbuf, tcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call outfld('TCWAT&IC ',cwat_var, pcols,lchnk) - end if - - if (lcwat_idx > 0) then - call pbuf_get_field(pbuf, lcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call outfld('LCWAT&IC ',cwat_var, pcols,lchnk) - end if - - if (cld_idx > 0) then - call pbuf_get_field(pbuf, cld_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call outfld('CLOUD&IC ',cwat_var, pcols,lchnk) - end if - - if (concld_idx > 0) then - call pbuf_get_field(pbuf, concld_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call outfld('CONCLD&IC ',cwat_var, pcols,lchnk) - end if - - if (cush_idx > 0) then - call pbuf_get_field(pbuf, cush_idx, conv_var_2d ,(/1,itim_old/), (/pcols,1/)) - call outfld('CUSH&IC ',conv_var_2d, pcols,lchnk) - - end if - - if (tke_idx > 0) then - call pbuf_get_field(pbuf, tke_idx, conv_var_3d) - call outfld('TKE&IC ',conv_var_3d, pcols,lchnk) - end if - - if (kvm_idx > 0) then - call pbuf_get_field(pbuf, kvm_idx, conv_var_3d) - call outfld('KVM&IC ',conv_var_3d, pcols,lchnk) - end if - - if (kvh_idx > 0) then - call pbuf_get_field(pbuf, kvh_idx, conv_var_3d) - call outfld('KVH&IC ',conv_var_3d, pcols,lchnk) - end if - - if (qpert_idx > 0) then - call pbuf_get_field(pbuf, qpert_idx, qpert) - call outfld('QPERT&IC ', qpert, pcols, lchnk) - end if - - if (pblh_idx > 0) then - call pbuf_get_field(pbuf, pblh_idx, pblh) - call outfld('PBLH&IC ', pblh, pcols, lchnk) - end if - - if (tpert_idx > 0) then - call pbuf_get_field(pbuf, tpert_idx, tpert) - call outfld('TPERT&IC ', tpert, pcols, lchnk) - end if - - end if - - end subroutine diag_physvar_ic - - -!####################################################################### - - subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) - - !--------------------------------------------------------------- - ! - ! Purpose: Dump physics tendencies for temperature - ! - !--------------------------------------------------------------- - - use check_energy, only: check_energy_get_integrals - use physconst, only: cpair - - ! Arguments - - type(physics_state), intent(in) :: state - - type(physics_buffer_desc), pointer :: pbuf(:) - type(physics_tend ), intent(in) :: tend - real(r8), intent(in) :: ztodt ! physics timestep - - !---------------------------Local workspace----------------------------- - - integer :: lchnk ! chunk index - integer :: ncol ! number of columns in chunk - real(r8) :: ftem2(pcols) ! Temporary workspace for outfld variables - real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables - real(r8) :: heat_glob ! global energy integral (FV only) - real(r8) :: tedif_glob ! energy flux from fixer - ! CAM pointers to get variables from the physics buffer - real(r8), pointer, dimension(:,:) :: t_ttend - real(r8), pointer, dimension(:,:) :: t_utend - real(r8), pointer, dimension(:,:) :: t_vtend - integer :: itim_old,m - - !----------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - - ! Dump out post-physics state (FV only) - - call outfld('TAP', state%t, pcols, lchnk ) - call outfld('UAP', state%u, pcols, lchnk ) - call outfld('VAP', state%v, pcols, lchnk ) - - ! Total physics tendency for Temperature - ! (remove global fixer tendency from total for FV and SE dycores) - - call check_energy_get_integrals(heat_glob_out=heat_glob,tedif_glob_out=tedif_glob) !+tedif - ftem2(:ncol) = tedif_glob/ztodt - call outfld('EBREAK', ftem2, pcols, lchnk) - ftem2(:ncol) = heat_glob/cpair - call outfld('TFIX', ftem2, pcols, lchnk) - - ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair - call outfld('PTTEND',ftem3, pcols, lchnk ) - ftem3(:ncol,:pver) = tend%dudt(:ncol,:pver) - call outfld('UTEND_PHYSTOT',ftem3, pcols, lchnk ) - ftem3(:ncol,:pver) = tend%dvdt(:ncol,:pver) - call outfld('VTEND_PHYSTOT',ftem3, pcols, lchnk ) - - ! Total (physics+dynamics, everything!) tendency for Temperature - - !! get temperature, U, and V stored in physics buffer - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, t_ttend_idx, t_ttend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, t_utend_idx, t_utend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, t_vtend_idx, t_vtend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - !! calculate and outfld the total temperature, U, and V tendencies - ftem3(:ncol,:) = (state%t(:ncol,:) - t_ttend(:ncol,:))/ztodt - call outfld('TTEND_TOT', ftem3, pcols, lchnk) - ftem3(:ncol,:) = (state%u(:ncol,:) - t_utend(:ncol,:))/ztodt - call outfld('UTEND_TOT', ftem3, pcols, lchnk) - ftem3(:ncol,:) = (state%v(:ncol,:) - t_vtend(:ncol,:))/ztodt - call outfld('VTEND_TOT', ftem3, pcols, lchnk) - - !! update physics buffer with this time-step's temperature, U, and V - t_ttend(:ncol,:) = state%t(:ncol,:) - t_utend(:ncol,:) = state%u(:ncol,:) - t_vtend(:ncol,:) = state%v(:ncol,:) - - end subroutine diag_phys_tend_writeout_dry - -!####################################################################### - - subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & - qini, cldliqini, cldiceini) - - !--------------------------------------------------------------- - ! - ! Purpose: Dump physics tendencies for moisture - ! - !--------------------------------------------------------------- - - ! Arguments - - type(physics_state), intent(in) :: state - - type(physics_buffer_desc), pointer :: pbuf(:) - type(physics_tend ), intent(in) :: tend - real(r8), intent(in) :: ztodt ! physics timestep - real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics - - !---------------------------Local workspace----------------------------- - - integer :: lchnk ! chunk index - integer :: ncol ! number of columns in chunk - real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables - real(r8) :: rtdt - integer :: ixcldice, ixcldliq! constituent indices for cloud liquid and ice water. - - lchnk = state%lchnk - ncol = state%ncol - rtdt = 1._r8/ztodt - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - - if ( cnst_cam_outfld( 1) ) then - call outfld (apcnst( 1), state%q(1,1, 1), pcols, lchnk) - end if - if (ixcldliq > 0) then - if (cnst_cam_outfld(ixcldliq)) then - call outfld (apcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) - end if - end if - if (ixcldice > 0) then - if ( cnst_cam_outfld(ixcldice) ) then - call outfld (apcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) - end if - end if - - ! Total physics tendency for moisture and other tracers - - if ( cnst_cam_outfld( 1) ) then - ftem3(:ncol,:pver) = (state%q(:ncol,:pver, 1) - qini (:ncol,:pver) )*rtdt - call outfld (ptendnam( 1), ftem3, pcols, lchnk) - end if - if (ixcldliq > 0) then - if (cnst_cam_outfld(ixcldliq) ) then - ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixcldliq) - cldliqini(:ncol,:pver) )*rtdt - call outfld (ptendnam(ixcldliq), ftem3, pcols, lchnk) - end if - end if - if (ixcldice > 0) then - if ( cnst_cam_outfld(ixcldice) ) then - ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixcldice) - cldiceini(:ncol,:pver) )*rtdt - call outfld (ptendnam(ixcldice), ftem3, pcols, lchnk) - end if - end if - - end subroutine diag_phys_tend_writeout_moist - -!####################################################################### - - subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & - qini, cldliqini, cldiceini) - - !--------------------------------------------------------------- - ! - ! Purpose: Dump physics tendencies for moisture and temperature - ! - !--------------------------------------------------------------- - - ! Arguments - - type(physics_state), intent(in) :: state - - type(physics_buffer_desc), pointer :: pbuf(:) - type(physics_tend ), intent(in) :: tend - real(r8), intent(in) :: ztodt ! physics timestep - real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics - - !----------------------------------------------------------------------- - - call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) - if (moist_physics) then - call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & - qini, cldliqini, cldiceini) - end if - - end subroutine diag_phys_tend_writeout - -!####################################################################### - - subroutine diag_state_b4_phys_write_dry (state) - ! - !--------------------------------------------------------------- - ! - ! Purpose: Dump dry state just prior to executing physics - ! - !--------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(in) :: state - ! - !---------------------------Local workspace----------------------------- - ! - integer :: lchnk ! chunk index - ! - !----------------------------------------------------------------------- - ! - lchnk = state%lchnk - - call outfld('TBP', state%t, pcols, lchnk ) - call outfld('UBP', state%u, pcols, lchnk ) - call outfld('VBP', state%v, pcols, lchnk ) - - end subroutine diag_state_b4_phys_write_dry - - subroutine diag_state_b4_phys_write_moist (state) - ! - !--------------------------------------------------------------- - ! - ! Purpose: Dump moist state just prior to executing physics - ! - !--------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(in) :: state - ! - !---------------------------Local workspace----------------------------- - ! - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - integer :: lchnk ! chunk index - ! - !----------------------------------------------------------------------- - ! - lchnk = state%lchnk - - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - - if ( cnst_cam_outfld( 1) ) then - call outfld (bpcnst( 1), state%q(1,1, 1), pcols, lchnk) - end if - if (ixcldliq > 0) then - if (cnst_cam_outfld(ixcldliq)) then - call outfld (bpcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) - end if - end if - if (ixcldice > 0) then - if (cnst_cam_outfld(ixcldice)) then - call outfld (bpcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) - end if - end if - - end subroutine diag_state_b4_phys_write_moist - - subroutine diag_state_b4_phys_write (state) - ! - !--------------------------------------------------------------- - ! - ! Purpose: Dump state just prior to executing physics - ! - !--------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(in) :: state - ! - - call diag_state_b4_phys_write_dry(state) - if (moist_physics) then - call diag_state_b4_phys_write_moist(state) - end if - end subroutine diag_state_b4_phys_write - -end module cam_diagnostics From 597b6f07051cbc11c3fbfa1ba1f4cda65d8e5453 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 28 Sep 2025 19:52:34 +0200 Subject: [PATCH 18/78] moved physics/camnor_phys/physics/cam_thermo.F90 to utils/cam_thermo.F90 --- .../camnor_phys/physics/cam_thermo.F90 | 2435 ----------------- .../camnor_phys/physics/physics_types.F90 | 110 +- src/utils/cam_thermo.F90 | 637 ++++- 3 files changed, 667 insertions(+), 2515 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/cam_thermo.F90 diff --git a/src/physics/camnor_phys/physics/cam_thermo.F90 b/src/physics/camnor_phys/physics/cam_thermo.F90 deleted file mode 100644 index 4fe5650d55..0000000000 --- a/src/physics/camnor_phys/physics/cam_thermo.F90 +++ /dev/null @@ -1,2435 +0,0 @@ -! cam_thermo module provides interfaces to compute thermodynamic quantities -module cam_thermo - - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_abortutils, only: endrun - use air_composition, only: thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx - use air_composition, only: thermodynamic_active_species_idx_dycore - use air_composition, only: thermodynamic_active_species_cp - use air_composition, only: thermodynamic_active_species_R - use air_composition, only: thermodynamic_active_species_mwi - use air_composition, only: thermodynamic_active_species_kv - use air_composition, only: thermodynamic_active_species_kc - use air_composition, only: thermodynamic_active_species_liq_num - use air_composition, only: thermodynamic_active_species_ice_num - use air_composition, only: thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_liq_idx_dycore - use air_composition, only: thermodynamic_active_species_ice_idx - use air_composition, only: thermodynamic_active_species_ice_idx_dycore - use air_composition, only: dry_air_species_num - use air_composition, only: enthalpy_reference_state - use air_composition, only: mmro2, mmrn2, o2_mwi, n2_mwi, mbar - - !use air_composition, only: cpliq, t00a, h00a !+tht - - implicit none - private - save - - ! subroutines to compute thermodynamic quantities - ! - ! See Lauritzen et al. (2018) for formulae - ! DOI: 10.1029/2017MS001257 - ! https://opensky.ucar.edu/islandora/object/articles:21929 - - public :: get_conserved_energy, inv_conserved_energy !+tht - ! cam_thermo_init: Initialize constituent dependent properties - public :: cam_thermo_init - ! cam_thermo_dry_air_update: Update dry air composition dependent properties - public :: cam_thermo_dry_air_update - ! cam_thermo_water_update: Update water dependent properties - public :: cam_thermo_water_update -! public :: cam_thermo_water_update_conserve - ! get_enthalpy: enthalpy quantity = dp*cp*T - public :: get_enthalpy - ! get_virtual_temp: virtual temperature - public :: get_virtual_temp - ! get_sum_species: sum of thermodynamically active species: - ! Note: dp = dp_dry * sum_species - public :: get_sum_species - ! get_virtual_theta: virtual potential temperature - public :: get_virtual_theta - ! cam_thermo_calc_kappav: update species dependent kappa for FV dycore - public :: cam_thermo_calc_kappav - ! get_dp: pressure level thickness from dry dp and dry mixing ratios - public :: get_dp - ! get_pmid_from_dp: full level pressure from dp (approximation depends on dycore) - public :: get_pmid_from_dp - ! get_ps: surface pressure - public :: get_ps - ! get_gz: geopotential - public :: get_gz - ! get_Richardson_number: Richardson number at layer interfaces - public :: get_Richardson_number - ! get_kappa_dry: (generalized) dry kappa = R_dry/cp_dry - public :: get_kappa_dry - ! get_dp_ref: reference pressure layer thickness (include topography) - public :: get_dp_ref - ! get_molecular_diff_coef: molecular diffusion and thermal conductivity - public :: get_molecular_diff_coef - ! get_molecular_diff_coef_reference: reference vertical profile of density, - ! molecular diffusion and thermal conductivity - public :: get_molecular_diff_coef_reference - ! get_rho_dry: dry density from temperature (temp) and - ! pressure (dp_dry and tracer) - public :: get_rho_dry - ! get_exner: Exner pressure - public :: get_exner - ! get_hydrostatic_energy: Vertically integrated total energy - public :: get_hydrostatic_energy - - ! Public variables - ! mixing_ratio options - integer, public, parameter :: DRY_MIXING_RATIO = 1 - integer, public, parameter :: MASS_MIXING_RATIO = 2 - -!+tht - !public condtr - !real(r8), parameter :: condtr = 273.16_r8 -!-tht - - !--------------- Variables below here are for WACCM-X --------------------- - ! kmvis: molecular viscosity kg/m/s - real(r8), public, protected, allocatable :: kmvis(:,:,:) - ! kmcnd: molecular conductivity J/m/s/K - real(r8), public, protected, allocatable :: kmcnd(:,:,:) - - !------------- Variables for consistent themodynamics -------------------- - ! - - ! - ! Interfaces for public routines - interface get_gz - ! get_gz_geopotential (with dp_dry, ptop, temp, and phis as input) - module procedure get_gz_from_dp_dry_ptop_temp_1hd - ! get_gz_given_dp_Tv_Rdry: geopotential (with dp,dry R and Tv as input) - module procedure get_gz_given_dp_Tv_Rdry_1hd - module procedure get_gz_given_dp_Tv_Rdry_2hd - end interface get_gz - - interface get_enthalpy - module procedure get_enthalpy_1hd - module procedure get_enthalpy_2hd - end interface get_enthalpy - - interface get_virtual_temp - module procedure get_virtual_temp_1hd - module procedure get_virtual_temp_2hd - end interface get_virtual_temp - - interface get_sum_species - module procedure get_sum_species_1hd - module procedure get_sum_species_2hd - end interface get_sum_species - - interface get_dp - module procedure get_dp_1hd - module procedure get_dp_2hd - end interface get_dp - - interface get_pmid_from_dp - module procedure get_pmid_from_dpdry_1hd - module procedure get_pmid_from_dp_1hd - end interface get_pmid_from_dp - - interface get_exner - module procedure get_exner_1hd - end interface get_exner - - interface get_virtual_theta - module procedure get_virtual_theta_1hd - end interface get_virtual_theta - - interface get_Richardson_number - module procedure get_Richardson_number_1hd - end interface get_Richardson_number - - interface get_ps - module procedure get_ps_1hd - module procedure get_ps_2hd - end interface get_ps - - interface get_kappa_dry - module procedure get_kappa_dry_1hd - module procedure get_kappa_dry_2hd - end interface get_kappa_dry - - interface get_dp_ref - module procedure get_dp_ref_1hd - module procedure get_dp_ref_2hd - end interface get_dp_ref - - interface get_rho_dry - module procedure get_rho_dry_1hd - module procedure get_rho_dry_2hd - end interface get_rho_dry - - interface get_molecular_diff_coef - module procedure get_molecular_diff_coef_1hd - module procedure get_molecular_diff_coef_2hd - end interface get_molecular_diff_coef - - interface cam_thermo_calc_kappav - ! Since this routine is currently only used by the FV dycore, - ! a 1-d interface is not needed (but can easily be added) - module procedure cam_thermo_calc_kappav_2hd - end interface cam_thermo_calc_kappav - - interface get_hydrostatic_energy - module procedure get_hydrostatic_energy_1hd - ! This routine is currently only called from the physics so a - ! 2-d interface is not needed (but can easily be added) - end interface get_hydrostatic_energy - - integer, public, parameter :: thermo_budget_num_vars = 10 - integer, public, parameter :: wvidx = 1 - integer, public, parameter :: wlidx = 2 - integer, public, parameter :: wiidx = 3 - integer, public, parameter :: seidx = 4 ! enthalpy or internal energy (W/m2) index - integer, public, parameter :: poidx = 5 ! surface potential or potential energy index - integer, public, parameter :: keidx = 6 ! kinetic energy index - integer, public, parameter :: mridx = 7 - integer, public, parameter :: moidx = 8 - integer, public, parameter :: ttidx = 9 - integer, public, parameter :: teidx = 10 - character (len = 2) ,public, dimension(thermo_budget_num_vars) :: thermo_budget_vars = & - (/"WV" ,"WL" ,"WI" ,"SE" ,"PO" ,"KE" ,"MR" ,"MO" ,"TT" ,"TE" /) - character (len = 46) ,public, dimension(thermo_budget_num_vars) :: thermo_budget_vars_descriptor = (/& - "Total column water vapor ",& - "Total column liquid water ",& - "Total column frozen water ",& - "Total column enthalpy or internal energy ",& - "Total column srf potential or potential energy",& - "Total column kinetic energy ",& - "Total column wind axial angular momentum ",& - "Total column mass axial angular momentum ",& - "Total column test_tracer ",& - "Total column energy (ke + se + po) "/) - - character (len = 14), public, dimension(thermo_budget_num_vars) :: & - thermo_budget_vars_unit = (/& - "kg/m2 ","kg/m2 ","kg/m2 ","J/m2 ",& - "J/m2 ","J/m2 ","kg*m2/s*rad2 ","kg*m2/s*rad2 ",& - "kg/m2 ","J/m2 "/) - logical ,public, dimension(thermo_budget_num_vars) :: thermo_budget_vars_massv = (/& - .true.,.true.,.true.,.false.,.false.,.false.,.false.,.false.,.true.,.false./) -CONTAINS - - !=========================================================================== - - subroutine cam_thermo_init() - use shr_infnan_mod, only: assignment(=), shr_infnan_qnan - use ppgrid, only: pcols, pver, pverp, begchunk, endchunk - - integer :: ierr - character(len=*), parameter :: subname = "cam_thermo_init" - character(len=*), parameter :: errstr = subname//": failed to allocate " - - !------------------------------------------------------------------------ - ! Allocate constituent dependent properties - !------------------------------------------------------------------------ - allocate(kmvis(pcols,pverp,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"kmvis") - end if - allocate(kmcnd(pcols,pverp,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"kmcnd") - end if - - !------------------------------------------------------------------------ - ! Initialize constituent dependent properties - !------------------------------------------------------------------------ - kmvis(:pcols, :pver, begchunk:endchunk) = shr_infnan_qnan - kmcnd(:pcols, :pver, begchunk:endchunk) = shr_infnan_qnan - - end subroutine cam_thermo_init - ! - !*************************************************************************** - ! - ! cam_thermo_dry_air_update: update dry air species dependent constants for physics - ! - !*************************************************************************** - ! - subroutine cam_thermo_dry_air_update(mmr, T, lchnk, ncol, to_dry_factor) - use air_composition, only: dry_air_composition_update - use string_utils, only: int2str - !------------------------------Arguments---------------------------------- - !(mmr = dry mixing ratio, if not use to_dry_factor to convert) - real(r8), intent(in) :: mmr(:,:,:) ! constituents array - real(r8), intent(in) :: T(:,:) ! temperature - integer, intent(in) :: lchnk ! Chunk number - integer, intent(in) :: ncol ! number of columns - real(r8), optional, intent(in) :: to_dry_factor(:,:)!if mmr moist convert - ! - !---------------------------Local storage------------------------------- - real(r8):: sponge_factor(SIZE(mmr, 2)) - character(len=*), parameter :: subname = 'cam_thermo_update: ' - - if (present(to_dry_factor)) then - if (SIZE(to_dry_factor, 1) /= ncol) then - call endrun(subname//'DIM 1 of to_dry_factor is'//int2str(SIZE(to_dry_factor,1))//'but should be'//int2str(ncol)) - end if - end if - - sponge_factor = 1.0_r8 - call dry_air_composition_update(mmr, lchnk, ncol, to_dry_factor=to_dry_factor) - call get_molecular_diff_coef(T(:ncol,:), .true., sponge_factor, kmvis(:ncol,:,lchnk), & - kmcnd(:ncol,:,lchnk), tracer=mmr(:ncol,:,:), fact=to_dry_factor, & - active_species_idx_dycore=thermodynamic_active_species_idx) - end subroutine cam_thermo_dry_air_update - ! - !*************************************************************************** - ! - ! cam_thermo_water+update: update water species dependent constants for physics - ! - !*************************************************************************** - ! - subroutine cam_thermo_water_update(mmr, lchnk, ncol, vcoord, to_dry_factor) - use air_composition, only: water_composition_update - !----------------------------------------------------------------------- - ! Update the physics "constants" that vary - !------------------------------------------------------------------------- - - !------------------------------Arguments---------------------------------- - - real(r8), intent(in) :: mmr(:,:,:) ! constituents array - integer, intent(in) :: lchnk ! Chunk number - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: vcoord - real(r8), optional, intent(in) :: to_dry_factor(:,:) - ! - logical :: lcp - - call water_composition_update(mmr, lchnk, ncol, vcoord, to_dry_factor=to_dry_factor) - - end subroutine cam_thermo_water_update - -! !=========================================================================== -! subroutine cam_thermo_water_update_conserve(state, lchnk, ncol, vcoord, to_dry_factor, init) -! use air_composition, only: water_composition_update -! !----------------------------------------------------------------------- -! ! Update the physics "constants" that vary -! !------------------------------------------------------------------------- -! use physics_types, only: physics_state ! leads to circular dependency -! -! !------------------------------Arguments---------------------------------- -! -! type(physics_state),intent(inout):: state -! integer, intent(in) :: lchnk ! Chunk number -! integer, intent(in) :: ncol ! number of columns -! integer, intent(in) :: vcoord -! real(r8), optional, intent(in) :: to_dry_factor(:,:) -! logical, optional, intent(in) :: init -! ! -! logical :: lcp -! -! call water_composition_update(state%q(:ncol,:,:), lchnk, ncol, vcoord, to_dry_factor=to_dry_factor, init=init) -! -!!add code to change T and Phi such that cp*T+Phi remains constant -!!(method: start from bottom, at each step first rescaling T=(state%s-Phi)/cp then integrating Phi) -! -! end subroutine cam_thermo_water_update_conserve -! - !=========================================================================== - - ! - !*********************************************************************** - ! - ! Compute enthalpy = cp*T*dp, where dp is pressure level thickness, - ! cp is generalized cp and T temperature - ! - ! Note: tracer is in units of m*dp_dry ("mass") - ! - !*********************************************************************** - ! - subroutine get_enthalpy_1hd(tracer_mass, temp, dp_dry, & - enthalpy, active_species_idx_dycore) - use air_composition, only: dry_air_species_num, get_cp_dry - ! Dummy arguments - ! tracer_mass: tracer array (mass weighted) - real(r8), intent(in) :: tracer_mass(:,:,:) - ! temp: temperature - real(r8), intent(in) :: temp(:,:) - ! dp_dry: dry presure level thickness - real(r8), intent(in) :: dp_dry(:,:) - ! enthalpy: enthalpy in each column: sum cp*T*dp - real(r8), intent(out) :: enthalpy(:,:) - ! - ! active_species_idx_dycore: - ! array of indicies for index of thermodynamic active species in - ! dycore tracer array (if different from physics index) - ! - integer, optional, intent(in) :: active_species_idx_dycore(:) - - ! Local vars - integer :: qdx, itrac - character(len=*), parameter :: subname = 'get_enthalpy: ' - - ! - ! "mass-weighted" cp (dp must be dry) - ! - if (dry_air_species_num == 0) then - enthalpy(:,:) = thermodynamic_active_species_cp(0) * & - dp_dry(:,:) - else - if (present(active_species_idx_dycore)) then - call get_cp_dry(tracer_mass, active_species_idx_dycore, & - enthalpy, fact=1.0_r8/dp_dry(:,:)) - else - call get_cp_dry(tracer_mass, thermodynamic_active_species_idx, & - enthalpy, fact=1.0_r8/dp_dry(:,:)) - end if - enthalpy(:,:) = enthalpy(:,:) * dp_dry(:,:) - end if - ! - ! tracer is in units of m*dp ("mass"), where: - ! m is the dry mixing ratio - ! dp is the dry pressure level thickness - ! - !enthalpy(:,:) = enthalpy(:,:) * temp(:,:) !+tht - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - if (present(active_species_idx_dycore)) then - itrac = active_species_idx_dycore(qdx) - else - itrac = thermodynamic_active_species_idx(qdx) - end if - enthalpy(:,:) = enthalpy(:,:) + & - (thermodynamic_active_species_cp(qdx) * tracer_mass(:,:,itrac)) - !+tht assuming "tracer" really means water! - !enthalpy(:,:) = enthalpy(:,:) + & - ! tracer_mass(:,:,itrac)*(thermodynamic_active_species_cp(qdx) *(temp(:,:)-t00a) + cpliq*t00a + h00a) - !-tht (actually, this causes havoc -- reverting all changes) - end do - enthalpy(:,:) = enthalpy(:,:) * temp(:,:) !tht c'd out - - end subroutine get_enthalpy_1hd - - !=========================================================================== - - subroutine get_enthalpy_2hd(tracer_mass, temp, dp_dry, & - enthalpy, active_species_idx_dycore) - ! Dummy arguments - ! tracer_mass: tracer array (mass weighted) - real(r8), intent(in) :: tracer_mass(:,:,:,:) - ! temp: temperature - real(r8), intent(in) :: temp(:,:,:) - ! dp_dry: dry presure level thickness - real(r8), intent(in) :: dp_dry(:,:,:) - ! enthalpy: enthalpy in each column: sum cp*T*dp - real(r8), intent(out) :: enthalpy(:,:,:) - ! - ! active_species_idx_dycore: - ! array of indicies for index of thermodynamic active species in - ! dycore tracer array (if different from physics index) - ! - integer, optional, intent(in) :: active_species_idx_dycore(:) - - ! Local variables - integer :: jdx - character(len=*), parameter :: subname = 'get_enthalpy_2hd: ' - - do jdx = 1, SIZE(tracer_mass, 2) - call get_enthalpy(tracer_mass(:, jdx, :, :), temp(:, jdx, :), & - dp_dry(:, jdx, :), enthalpy(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - end do - - end subroutine get_enthalpy_2hd - - !=========================================================================== - - !************************************************************************** - ! - ! get_virtual_temp: Compute virtual temperature T_v - ! - ! tracer is in units of dry mixing ratio unless optional argument - ! dp_dry is present in which case tracer is in units of "mass" (=m*dp) - ! - ! If temperature is not supplied then just return factor that T - ! needs to be multiplied by to get T_v - ! - !************************************************************************** - ! - subroutine get_virtual_temp_1hd(tracer, T_v, temp, dp_dry, sum_q, & - active_species_idx_dycore) - use cam_abortutils, only: endrun - use string_utils, only: int2str - use air_composition, only: dry_air_species_num, get_R_dry - - ! Dummy Arguments - ! tracer: tracer array - real(r8), intent(in) :: tracer(:, :, :) - ! T_v: virtual temperature - real(r8), intent(out) :: T_v(:, :) - ! temp: temperature - real(r8), optional, intent(in) :: temp(:, :) - ! dp_dry: dry pressure level thickness - real(r8), optional, intent(in) :: dp_dry(:, :) - ! sum_q: sum tracer - real(r8), optional, intent(out) :: sum_q(:, :) - ! - ! array of indicies for index of thermodynamic active species in - ! dycore tracer array (if different from physics index) - ! - integer, optional, intent(in) :: active_species_idx_dycore(:) - - ! Local Variables - integer :: itrac, qdx - real(r8) :: sum_species(SIZE(tracer, 1), SIZE(tracer, 2)) - real(r8) :: factor(SIZE(tracer, 1), SIZE(tracer, 2)) - real(r8) :: Rd(SIZE(tracer, 1), SIZE(tracer, 2)) - integer :: idx_local(thermodynamic_active_species_num) - character(len=*), parameter :: subname = 'get_virtual_temp_1hd: ' - - if (present(active_species_idx_dycore)) then - if (SIZE(active_species_idx_dycore) /= & - thermodynamic_active_species_num) then - call endrun(subname//"SIZE mismatch "// & - int2str(SIZE(active_species_idx_dycore))//' /= '// & - int2str(thermodynamic_active_species_num)) - end if - idx_local = active_species_idx_dycore - else - idx_local = thermodynamic_active_species_idx - end if - - call get_sum_species(tracer, idx_local, sum_species, dp_dry=dp_dry, factor=factor) - - call get_R_dry(tracer, idx_local, Rd, fact=factor) - t_v(:, :) = Rd(:, :) - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - itrac = idx_local(qdx) - t_v(:, :) = t_v(:, :) + (thermodynamic_active_species_R(qdx) * & - tracer(:, :, itrac) * factor(:, :)) - end do - if (present(temp)) then - t_v(:, :) = t_v(:, :) * temp(:, :) / (Rd(:, :) * sum_species) - else - t_v(:, :) = t_v(:, :) / (Rd(:, :) * sum_species) - end if - if (present(sum_q)) then - sum_q = sum_species - end if - - end subroutine get_virtual_temp_1hd - - !=========================================================================== - - subroutine get_virtual_temp_2hd(tracer, T_v, temp, dp_dry, sum_q, & - active_species_idx_dycore) - - ! Dummy Arguments - ! tracer: tracer array - real(r8), intent(in) :: tracer(:, :, :, :) - ! T_v: virtual temperature - real(r8), intent(out) :: T_v(:, :, :) - ! temp: temperature - real(r8), optional, intent(in) :: temp(:, :, :) - ! dp_dry: dry pressure level thickness - real(r8), optional, intent(in) :: dp_dry(:, :, :) - ! sum_q: sum tracer - real(r8), optional, intent(out) :: sum_q(:, :, :) - ! - ! array of indicies for index of thermodynamic active species in - ! dycore tracer array (if different from physics index) - ! - integer, optional, intent(in) :: active_species_idx_dycore(:) - - ! Local vars - integer :: jdx - character(len=*), parameter :: subname = 'get_virtual_temp_2hd: ' - - ! Rather than do a bunch of copying into temp variables, do the - ! combinatorics - do jdx = 1, SIZE(tracer, 2) - if (present(temp) .and. present(dp_dry) .and. present(sum_q)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - temp=temp(:, jdx, :), dp_dry=dp_dry(:, jdx, :), & - sum_q=sum_q(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(temp) .and. present(dp_dry)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - temp=temp(:, jdx, :), dp_dry=dp_dry(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(temp) .and. present(sum_q)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - temp=temp(:, jdx, :), sum_q=sum_q(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(dp_dry) .and. present(sum_q)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - dp_dry=dp_dry(:, jdx, :), sum_q=sum_q(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(temp)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - temp=temp(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(dp_dry)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - dp_dry=dp_dry(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(sum_q)) then - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - sum_q=sum_q(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else - call get_virtual_temp(tracer(:, jdx, :, :), T_v(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - end if - end do - - end subroutine get_virtual_temp_2hd - - !=========================================================================== - - ! - !*************************************************************************** - ! - ! get_sum_species: - ! - ! Compute sum of thermodynamically active species - ! - ! tracer is in units of dry mixing ratio unless optional argument - ! dp_dry is present in which case tracer is in units of "mass" (=m*dp) - ! - !*************************************************************************** - ! - subroutine get_sum_species_1hd(tracer, active_species_idx, & - sum_species, dp_dry, factor) - use air_composition, only: dry_air_species_num - - ! Dummy arguments - ! tracer: Tracer array - real(r8), intent(in) :: tracer(:, :, :) - ! active_species_idx: Index for thermodynamic active tracers - integer, intent(in) :: active_species_idx(:) - ! dp_dry: Dry pressure level thickness. - ! If present, then tracer is in units of mass - real(r8), optional, intent(in) :: dp_dry(:, :) - ! sum_species: sum species - real(r8), intent(out) :: sum_species(:, :) - ! factor: to moist factor - real(r8), optional, intent(out) :: factor(:, :) - ! Local variables - real(r8) :: factor_loc(SIZE(tracer, 1), SIZE(tracer, 2)) - integer :: qdx, itrac - if (present(dp_dry)) then - factor_loc = 1.0_r8 / dp_dry(:,:) - else - factor_loc = 1.0_r8 - end if - sum_species = 1.0_r8 ! all dry air species sum to 1 - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - itrac = active_species_idx(qdx) - sum_species(:,:) = sum_species(:,:) + (tracer(:,:,itrac) * factor_loc(:,:)) - end do - if (present(factor)) then - factor = factor_loc - end if - end subroutine get_sum_species_1hd - - !=========================================================================== - - subroutine get_sum_species_2hd(tracer, active_species_idx, & - sum_species,dp_dry, factor) - - ! Dummy arguments - ! tracer: Tracer array - real(r8), intent(in) :: tracer(:, :, :, :) - ! active_species_idx: Index for thermodynamic active tracers - integer, intent(in) :: active_species_idx(:) - ! dp_dry: Dry pressure level thickness. - ! If present, then tracer is in units of mass - real(r8), optional, intent(in) :: dp_dry(:, :, :) - ! sum_species: sum species - real(r8), intent(out) :: sum_species(:, :, :) - ! factor: to moist factor - real(r8), optional, intent(out) :: factor(:, :, :) - ! Local variable - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(dp_dry) .and. present(factor)) then - call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & - sum_species(:, jdx, :), dp_dry=dp_dry(:, jdx, :), factor=factor(:, jdx, :)) - else if (present(dp_dry)) then - call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & - sum_species(:, jdx, :), dp_dry=dp_dry(:, jdx, :)) - else if (present(factor)) then - call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & - sum_species(:, jdx, :), factor=factor(:, jdx, :)) - else - call get_sum_species(tracer(:, jdx, :, :), active_species_idx, & - sum_species(:, jdx, :)) - end if - end do - - end subroutine get_sum_species_2hd - - !=========================================================================== - - !*************************************************************************** - ! - ! get_dp: Compute pressure level thickness from dry pressure and - ! thermodynamic active species mixing ratios - ! - ! Tracer can either be in units of dry mixing ratio (mixing_ratio=1) or - ! "mass" (=m*dp_dry) (mixing_ratio=2) - ! - !*************************************************************************** - ! - subroutine get_dp_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, dp, ps, ptop) - use air_composition, only: dry_air_species_num - use string_utils, only: int2str - - real(r8), intent(in) :: tracer(:, :, :) ! tracers; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:, :) ! dry pressure level thickness - real(r8), intent(out) :: dp(:, :) ! pressure level thickness - real(r8), optional,intent(out) :: ps(:) ! surface pressure (if ps present then ptop - ! must be present) - real(r8), optional,intent(in) :: ptop ! pressure at model top - - integer :: idx, kdx, m_cnst, qdx - - character(len=*), parameter :: subname = 'get_dp_1hd: ' - - dp = dp_dry - if (mixing_ratio == DRY_MIXING_RATIO) then - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - m_cnst = active_species_idx(qdx) - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - dp(idx, kdx) = dp(idx, kdx) + dp_dry(idx, kdx)*tracer(idx, kdx, m_cnst) - end do - end do - end do - else if (mixing_ratio == MASS_MIXING_RATIO) then - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - m_cnst = active_species_idx(qdx) - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - dp(idx, kdx) = dp(idx, kdx) + tracer(idx, kdx, m_cnst) - end do - end do - end do - else - call endrun(subname//'unrecognized input ('//int2str(mixing_ratio)//') for mixing_ratio') - end if - if (present(ps)) then - if (present(ptop)) then - ps = ptop - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - ps(idx) = ps(idx) + dp(idx, kdx) - end do - end do - else - call endrun(subname//'if ps is present ptop must be present') - end if - end if - end subroutine get_dp_1hd - - subroutine get_dp_2hd(tracer, mixing_ratio, active_species_idx, dp_dry, dp, ps, ptop) - ! Version of get_dp for arrays that have a second horizontal index - real(r8), intent(in) :: tracer(:,:,:,:) ! tracers; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:,:,:) ! dry pressure level thickness - real(r8), intent(out) :: dp(:,:,:) ! pressure level thickness - real(r8), optional,intent(out) :: ps(:,:) ! surface pressure - real(r8), optional,intent(in) :: ptop ! pressure at model top - - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(ps)) then - call get_dp(tracer(:, jdx, :, :), mixing_ratio, active_species_idx, & - dp_dry(:, jdx, :), dp(:, jdx, :), ps=ps(:,jdx), ptop=ptop) - else - call get_dp(tracer(:, jdx, :, :), mixing_ratio, active_species_idx, & - dp_dry(:, jdx, :), dp(:, jdx, :), ptop=ptop) - end if - end do - - end subroutine get_dp_2hd - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute mid-level (full level) pressure from dry pressure and water tracers - ! - !************************************************************************************************************************* - ! - subroutine get_pmid_from_dpdry_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, pmid, pint, dp) - - real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness - real(r8), intent(in) :: ptop ! model top pressure - real(r8), intent(out) :: pmid(:,:) ! mid-level pressure - real(r8), optional, intent(out) :: pint(:,:) ! half-level pressure - real(r8), optional, intent(out) :: dp(:,:) ! presure level thickness - - real(r8) :: dp_local(SIZE(tracer, 1), SIZE(tracer, 2)) ! local pressure level thickness - real(r8) :: pint_local(SIZE(tracer, 1), SIZE(tracer, 2) + 1)! local interface pressure - - call get_dp(tracer, mixing_ratio, active_species_idx, dp_dry, dp_local) - - call get_pmid_from_dp(dp_local, ptop, pmid, pint_local) - - if (present(pint)) pint=pint_local - if (present(dp)) dp=dp_local - end subroutine get_pmid_from_dpdry_1hd - - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute mid-level (full level) pressure - ! - !************************************************************************************************************************* - ! - subroutine get_pmid_from_dp_1hd(dp, ptop, pmid, pint) - use dycore, only: dycore_is - real(r8), intent(in) :: dp(:,:) ! pressure level thickness - real(r8), intent(in) :: ptop ! pressure at model top - real(r8), intent(out) :: pmid(:,:) ! mid (full) level pressure - real(r8), optional, intent(out) :: pint(:,:) ! pressure at interfaces (half levels) - - real(r8) :: pint_local(SIZE(dp, 1), SIZE(dp,2) + 1) - integer :: kdx - - pint_local(:, 1) = ptop - do kdx = 2, SIZE(dp, 2) + 1 - pint_local(:, kdx) = dp(:, kdx - 1) + pint_local(:, kdx - 1) - end do - - if (dycore_is('LR') .or. dycore_is('FV3')) then - do kdx = 1, SIZE(dp, 2) - pmid(:, kdx) = dp(:, kdx) / (log(pint_local(:, kdx + 1)) - log(pint_local(:, kdx))) - end do - else - do kdx = 1, SIZE(dp, 2) - pmid(:, kdx) = 0.5_r8 * (pint_local(:, kdx) + pint_local(:, kdx + 1)) - end do - end if - if (present(pint)) pint=pint_local - end subroutine get_pmid_from_dp_1hd - - !=========================================================================== - - !**************************************************************************************************************** - ! - ! Compute Exner pressure - ! - !**************************************************************************************************************** - ! - subroutine get_exner_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, inv_exner, exner, poverp0) - use string_utils, only: int2str - real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness - real(r8), intent(in) :: ptop ! pressure at model top - real(r8), intent(in) :: p00 ! reference pressure for Exner pressure (usually 1000hPa) - logical , intent(in) :: inv_exner ! logical for outputting inverse Exner or Exner pressure - real(r8), intent(out) :: exner(:,:) - real(r8), optional, intent(out) :: poverp0(:,:) ! for efficiency when a routine needs this variable - - real(r8) :: pmid(SIZE(tracer, 1), SIZE(tracer, 2)) - real(r8) :: kappa_dry(SIZE(tracer, 1), SIZE(tracer, 2)) - character(len=*), parameter :: subname = 'get_exner_1hd: ' - ! - ! compute mid level pressure - ! - call get_pmid_from_dp(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, pmid) - ! - ! compute kappa = Rd / cpd - ! - if (mixing_ratio == DRY_MIXING_RATIO) then - call get_kappa_dry(tracer, active_species_idx, kappa_dry) - else if (mixing_ratio == MASS_MIXING_RATIO) then - call get_kappa_dry(tracer, active_species_idx, kappa_dry, 1.0_r8 / dp_dry) - else - call endrun(subname//'unrecognized input ('//int2str(mixing_ratio)//') for mixing_ratio') - end if - if (inv_exner) then - exner(:,:) = (p00 / pmid(:,:)) ** kappa_dry(:,:) - else - exner(:,:) = (pmid(:,:) / p00) ** kappa_dry(:,:) - end if - if (present(poverp0)) poverp0 = pmid(:,:) / p00 - end subroutine get_exner_1hd - - !=========================================================================== - - !**************************************************************************************************************** - ! - ! Compute virtual potential temperature from dp_dry, m, T and ptop. - ! - !**************************************************************************************************************** - ! - subroutine get_virtual_theta_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, temp, theta_v) - real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness - real(r8), intent(in) :: ptop ! pressure at model top - real(r8), intent(in) :: p00 ! reference pressure for Exner pressure (usually 1000hPa) - real(r8), intent(in) :: temp(:,:) ! temperature - real(r8), intent(out) :: theta_v(:,:) ! virtual potential temperature - - real(r8) :: iexner(SIZE(tracer, 1), SIZE(tracer, 2)) - - call get_exner(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, .true., iexner) - - theta_v(:,:) = temp(:,:) * iexner(:,:) - - end subroutine get_virtual_theta_1hd - - !=========================================================================== - - !**************************************************************************************************************** - ! - ! Compute geopotential from dry pressure level thichkness, water tracers, model top pressure and temperature - ! - !**************************************************************************************************************** - ! - subroutine get_gz_from_dp_dry_ptop_temp_1hd(tracer, mixing_ratio, active_species_idx, & - dp_dry, ptop, temp, phis, gz, pmid, dp, T_v) - use air_composition, only: get_R_dry - use string_utils, only: int2str - real(r8), intent(in) :: tracer(:,:,:) ! tracer; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness - real(r8), intent(in) :: ptop ! pressure at model top - real(r8), intent(in) :: temp(:,:) ! temperature - real(r8), intent(in) :: phis(:) ! surface geopotential - real(r8), intent(out) :: gz(:,:) ! geopotential - real(r8), optional, intent(out) :: pmid(:,:) ! mid-level pressure - real(r8), optional, intent(out) :: dp(:,:) ! pressure level thickness - real(r8), optional, intent(out) :: t_v(:,:) ! virtual temperature - - - real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: pmid_local, t_v_local, dp_local, R_dry - real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2) + 1) :: pint - character(len=*), parameter :: subname = 'get_gz_from_dp_dry_ptop_temp_1hd: ' - - - call get_pmid_from_dp(tracer, mixing_ratio, active_species_idx, & - dp_dry, ptop, pmid_local, pint=pint, dp=dp_local) - if (mixing_ratio == DRY_MIXING_RATIO) then - call get_virtual_temp(tracer, t_v_local, temp=temp, active_species_idx_dycore=active_species_idx) - call get_R_dry(tracer, active_species_idx, R_dry) - else if (mixing_ratio == MASS_MIXING_RATIO) then - call get_virtual_temp(tracer, t_v_local, temp=temp, dp_dry=dp_dry, active_species_idx_dycore=active_species_idx) - call get_R_dry(tracer,active_species_idx, R_dry, fact=1.0_r8 / dp_dry) - else - call endrun(subname//'unrecognized input ('//int2str(mixing_ratio)//') for mixing_ratio') - end if - call get_gz(dp_local, T_v_local, R_dry, phis, ptop, gz, pmid_local) - - if (present(pmid)) pmid=pmid_local - if (present(T_v)) T_v=T_v_local - if (present(dp)) dp=dp_local - end subroutine get_gz_from_dp_dry_ptop_temp_1hd - - !=========================================================================== - - !*************************************************************************** - ! - ! Compute geopotential from pressure level thickness and virtual temperature - ! - !*************************************************************************** - ! - subroutine get_gz_given_dp_Tv_Rdry_1hd(dp, T_v, R_dry, phis, ptop, gz, pmid) - use dycore, only: dycore_is - real(r8), intent(in) :: dp (:,:) ! pressure level thickness - real(r8), intent(in) :: T_v (:,:) ! virtual temperature - real(r8), intent(in) :: R_dry(:,:) ! R dry - real(r8), intent(in) :: phis (:) ! surface geopotential - real(r8), intent(in) :: ptop ! model top presure - real(r8), intent(out) :: gz(:,:) ! geopotential - real(r8), optional, intent(out) :: pmid(:,:) ! mid-level pressure - - - real(r8), dimension(SIZE(dp, 1), SIZE(dp, 2)) :: pmid_local - real(r8), dimension(SIZE(dp, 1), SIZE(dp, 2) + 1) :: pint - real(r8), dimension(SIZE(dp, 1)) :: gzh, Rdry_tv - integer :: kdx - - call get_pmid_from_dp(dp, ptop, pmid_local, pint) - - ! - ! integrate hydrostatic eqn - ! - gzh = phis - if (dycore_is('LR') .or. dycore_is('FV3')) then - do kdx = SIZE(dp, 2), 1, -1 - Rdry_tv(:) = R_dry(:, kdx) * T_v(:, kdx) - gz(:, kdx) = gzh(:) + Rdry_tv(:) * (1.0_r8 - pint(:, kdx) / pmid_local(:, kdx)) - gzh(:) = gzh(:) + Rdry_tv(:) * (log(pint(:, kdx + 1)) - log(pint(:, kdx))) - end do - else - do kdx = SIZE(dp,2), 1, -1 - Rdry_tv(:) = R_dry(:,kdx) * T_v(:, kdx) - gz(:,kdx) = gzh(:) + Rdry_tv(:) * 0.5_r8 * dp(:, kdx) / pmid_local(:, kdx) - gzh(:) = gzh(:) + Rdry_tv(:) * dp(:, kdx) / pmid_local(:, kdx) - end do - end if - if (present(pmid)) pmid=pmid_local - end subroutine get_gz_given_dp_Tv_Rdry_1hd - - subroutine get_gz_given_dp_Tv_Rdry_2hd(dp, T_v, R_dry, phis, ptop, gz, pmid) - ! Version of get_gz_given_dp_Tv_Rdry for arrays that have a second horizontal index - real(r8), intent(in) :: dp (:,:,:) ! pressure level thickness - real(r8), intent(in) :: T_v (:,:,:) ! virtual temperature - real(r8), intent(in) :: R_dry(:,:,:) ! R dry - real(r8), intent(in) :: phis (:,:) ! surface geopotential - real(r8), intent(in) :: ptop ! model top presure - real(r8), intent(out) :: gz(:,:,:) ! geopotential - real(r8), optional, intent(out) :: pmid(:,:,:) ! mid-level pressure - - integer :: jdx - - do jdx = 1, SIZE(dp, 2) - if (present(pmid)) then - call get_gz(dp(:, jdx, :), T_v(:, jdx, :), R_dry(:, jdx, :), phis(:, jdx), & - ptop, gz(:, jdx, :), pmid=pmid(:, jdx, :)) - else - call get_gz(dp(:, jdx, :), T_v(:, jdx, :), R_dry(:, jdx, :), phis(:, jdx), ptop, gz(:, jdx, :)) - end if - end do - - - end subroutine get_gz_given_dp_Tv_Rdry_2hd - - !=========================================================================== - - !*************************************************************************** - ! - ! Compute Richardson number at cell interfaces (half levels) - ! - !*************************************************************************** - ! - subroutine get_Richardson_number_1hd(tracer,mixing_ratio, active_species_idx, dp_dry, ptop, & - p00, temp, v, Richardson_number, pmid, dp) - real(r8), intent(in) :: tracer(:,:,:) ! tracer; quantity specified by mixing_ratio arg - integer, intent(in) :: mixing_ratio ! 1 => tracer is dry mixing ratio - ! 2 => tracer is mass (q*dp) - integer, intent(in) :: active_species_idx(:) ! index for thermodynamic species in tracer array - real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness - real(r8), intent(in) :: ptop ! pressure at model top - real(r8), intent(in) :: p00 ! reference pressure for Exner pressure (usually 1000hPa) - real(r8), intent(in) :: temp(:,:) ! temperature - real(r8), intent(in) :: v(:,:,:) ! velocity components - real(r8), intent(out) :: Richardson_number(:,:) - real(r8), optional, intent(out) :: pmid(:,:) - real(r8), optional, intent(out) :: dp(:,:) - - real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: gz, theta_v - real(r8), dimension(SIZE(tracer, 1)) :: pt1, pt2, phis - integer :: kdx, kdxm1 - real(r8), parameter:: ustar2 = 1.E-4_r8 - - phis = 0.0_r8 - call get_gz(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, temp, phis, gz, pmid=pmid, dp=dp) - call get_virtual_theta(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, p00, temp, theta_v) - Richardson_number(:, 1) = 0.0_r8 - Richardson_number(:, SIZE(tracer, 2) + 1) = 0.0_r8 - do kdx = SIZE(tracer, 2), 2, -1 - kdxm1 = kdx - 1 - pt1(:) = theta_v(:, kdxm1) - pt2(:) = theta_v(:, kdx) - Richardson_number(:, kdx) = (gz(:, kdxm1) - gz(:, kdx)) * (pt1 - pt2) / ( 0.5_r8*(pt1 + pt2) * & - ((v(:, 1, kdxm1) - v(:, 1, kdx)) ** 2 + (v(:, 2, kdxm1) - v(:, 2, kdx)) ** 2 + ustar2) ) - end do - end subroutine get_Richardson_number_1hd - - ! - !**************************************************************************************************************** - ! - ! get surface pressure from dry pressure and thermodynamic active species (e.g., forms of water: water vapor, cldliq, etc.) - ! - !**************************************************************************************************************** - ! - subroutine get_ps_1hd(tracer_mass, active_species_idx, dp_dry, ps, ptop) - use air_composition, only: dry_air_species_num - - real(r8), intent(in) :: tracer_mass(:,:,:) ! Tracer array (q*dp) - real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness - real(r8), intent(out) :: ps(:) ! surface pressure - real(r8), intent(in) :: ptop - integer, intent(in) :: active_species_idx(:) - - integer :: idx, kdx, m_cnst, qdx - real(r8) :: dp(SIZE(tracer_mass, 1), SIZE(tracer_mass, 2)) ! dry pressure level thickness - - dp = dp_dry - do qdx = dry_air_species_num + 1, thermodynamic_active_species_num - m_cnst = active_species_idx(qdx) - do kdx = 1, SIZE(tracer_mass, 2) - do idx = 1, SIZE(tracer_mass, 1) - dp(idx, kdx) = dp(idx, kdx) + tracer_mass(idx, kdx, m_cnst) - end do - end do - end do - ps = ptop - do kdx = 1, SIZE(tracer_mass, 2) - do idx = 1, SIZE(tracer_mass, 1) - ps(idx) = ps(idx) + dp(idx, kdx) - end do - end do - end subroutine get_ps_1hd - - subroutine get_ps_2hd(tracer_mass, active_species_idx, dp_dry, ps, ptop) - ! Version of get_ps for arrays that have a second horizontal index - real(r8), intent(in) :: tracer_mass(:,:,:,:) ! Tracer array (q*dp) - real(r8), intent(in) :: dp_dry(:,:,:) ! dry pressure level thickness - real(r8), intent(out) :: ps(:,:) ! surface pressure - real(r8), intent(in) :: ptop - integer, intent(in) :: active_species_idx(:) - - integer :: jdx - - do jdx = 1, SIZE(tracer_mass, 2) - call get_ps(tracer_mass(:, jdx, :, :), active_species_idx, dp_dry(:, jdx, :), ps(:, jdx), ptop) - end do - - end subroutine get_ps_2hd - - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute generalized kappa =Rdry/cpdry - ! - !************************************************************************************************************************* - ! - subroutine get_kappa_dry_1hd(tracer, active_species_idx, kappa_dry, fact) - use air_composition, only: dry_air_species_num, get_R_dry, get_cp_dry - use physconst, only: rair, cpair - - real(r8), intent(in) :: tracer(:,:,:) !tracer array - integer, intent(in) :: active_species_idx(:) !index of thermodynamic active tracers - real(r8), intent(out) :: kappa_dry(:,:) !kappa dry - real(r8), optional, intent(in) :: fact(:,:) !factor for converting tracer to dry mixing ratio - ! - real(r8), allocatable, dimension(:,:) :: cp_dry,R_dry - integer :: ierr - character(len=*), parameter :: subname = "get_kappa_dry_1hd" - character(len=*), parameter :: errstr = subname//": failed to allocate " - ! - ! dry air not species dependent - if (dry_air_species_num==0) then - kappa_dry = rair / cpair - else - allocate(R_dry(SIZE(kappa_dry, 1), SIZE(kappa_dry, 2)), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"R_dry") - end if - allocate(cp_dry(SIZE(kappa_dry, 1), SIZE(kappa_dry, 2)), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"cp_dry") - end if - call get_cp_dry(tracer, active_species_idx, cp_dry, fact=fact) - call get_R_dry( tracer, active_species_idx, R_dry, fact=fact) - kappa_dry = R_dry / cp_dry - deallocate(R_dry, cp_dry) - end if - end subroutine get_kappa_dry_1hd - - subroutine get_kappa_dry_2hd(tracer, active_species_idx, kappa_dry, fact) - ! Version of get_kappa_dry for arrays that have a second horizontal index - real(r8), intent(in) :: tracer(:,:,:,:) !tracer array - integer, intent(in) :: active_species_idx(:) !index of thermodynamic active tracers - real(r8), intent(out) :: kappa_dry(:,:,:) !kappa dry - real(r8), optional, intent(in) :: fact(:,:,:) !factor for converting tracer to dry mixing ratio - - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(fact)) then - call get_kappa_dry(tracer(:, jdx, :, :), active_species_idx, kappa_dry(:, jdx, :), fact=fact(:, jdx, :)) - else - call get_kappa_dry(tracer(:, jdx, :, :), active_species_idx, kappa_dry(:, jdx, :)) - end if - end do - - end subroutine get_kappa_dry_2hd - - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute reference pressure levels - ! - !************************************************************************************************************************* - ! - subroutine get_dp_ref_1hd(hyai, hybi, ps0, phis, dp_ref, ps_ref) - use physconst, only: tref, rair - real(r8), intent(in) :: hyai(:) - real(r8), intent(in) :: hybi(:) - real(r8), intent(in) :: ps0 - real(r8), intent(in) :: phis(:) - real(r8), intent(out) :: dp_ref(:,:) - real(r8), intent(out) :: ps_ref(:) - integer :: kdx - ! - ! use static reference pressure (hydrostatic balance incl. effect of topography) - ! - ps_ref(:) = ps0 * exp(-phis(:) / (rair * tref)) - do kdx = 1, SIZE(dp_ref, 2) - dp_ref(:,kdx) = ((hyai(kdx + 1) - hyai(kdx)) * ps0 + (hybi(kdx + 1) - hybi(kdx)) * ps_ref(:)) - end do - end subroutine get_dp_ref_1hd - - subroutine get_dp_ref_2hd(hyai, hybi, ps0, phis, dp_ref, ps_ref) - ! Version of get_dp_ref for arrays that have a second horizontal index - real(r8), intent(in) :: hyai(:) - real(r8), intent(in) :: hybi(:) - real(r8), intent(in) :: ps0 - real(r8), intent(in) :: phis(:,:) - real(r8), intent(out) :: dp_ref(:,:,:) - real(r8), intent(out) :: ps_ref(:,:) - integer :: jdx - - do jdx = 1, SIZE(dp_ref, 2) - call get_dp_ref(hyai, hybi, ps0, phis(:, jdx), dp_ref(:, jdx, :), ps_ref(:, jdx)) - end do - - end subroutine get_dp_ref_2hd - - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute dry densisty from temperature (temp) and pressure (dp_dry and tracer) - ! - !************************************************************************************************************************* - ! - subroutine get_rho_dry_1hd(tracer, temp, ptop, dp_dry, tracer_mass, rho_dry, rhoi_dry, & - active_species_idx_dycore) - use air_composition, only: get_R_dry - ! args - real(r8), intent(in) :: tracer(:,:,:) ! Tracer array - real(r8), intent(in) :: temp(:,:) ! Temperature - real(r8), intent(in) :: ptop - real(r8), intent(in) :: dp_dry(:,:) - logical, intent(in) :: tracer_mass - real(r8), optional,intent(out) :: rho_dry(:,:) - real(r8), optional,intent(out) :: rhoi_dry(:,:) - ! - ! array of indicies for index of thermodynamic active species in dycore tracer array - ! (if different from physics index) - ! - integer, optional, intent(in) :: active_species_idx_dycore(:) - - ! local vars - integer :: idx, kdx - real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: pmid - real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2) + 1) :: pint - real(r8), allocatable :: R_dry(:,:) - integer, dimension(thermodynamic_active_species_num) :: idx_local - integer :: ierr - character(len=*), parameter :: subname = "get_rho_dry_1hd" - character(len=*), parameter :: errstr = subname//": failed to allocate " - - if (present(active_species_idx_dycore)) then - idx_local = active_species_idx_dycore - else - idx_local = thermodynamic_active_species_idx - end if - ! - ! we assume that air is dry where molecular viscosity may be significant - ! - call get_pmid_from_dp(dp_dry, ptop, pmid, pint=pint) - if (present(rhoi_dry)) then - allocate(R_dry(SIZE(tracer, 1), SIZE(tracer, 2) + 1), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"R_dry") - end if - if (tracer_mass) then - call get_R_dry(tracer, idx_local, R_dry, fact=1.0_r8 / dp_dry) - else - call get_R_dry(tracer, idx_local, R_dry) - end if - do kdx = 2, SIZE(tracer, 2) + 1 - rhoi_dry(:, kdx) = 0.5_r8 * (temp(:, kdx) + temp(:, kdx - 1))!could be more accurate! - rhoi_dry(:, kdx) = pint(:,kdx) / (rhoi_dry(:, kdx) * R_dry(:, kdx)) !ideal gas law for dry air - end do - ! - ! extrapolate top level value - ! - kdx=1 - rhoi_dry(:, kdx) = 1.5_r8 * (temp(:, kdx) - 0.5_r8 * temp(:, kdx + 1)) - rhoi_dry(:, kdx) = pint(:, kdx) / (rhoi_dry(:, kdx) * R_dry(:, kdx)) !ideal gas law for dry air - deallocate(R_dry) - end if - if (present(rho_dry)) then - allocate(R_dry(SIZE(tracer, 1), size(rho_dry, 2)), stat=ierr) - if (ierr /= 0) then - call endrun(errstr//"R_dry") - end if - if (tracer_mass) then - call get_R_dry(tracer, idx_local, R_dry, fact=1.0_r8 / dp_dry) - else - call get_R_dry(tracer, idx_local, R_dry) - end if - do kdx = 1, SIZE(rho_dry, 2) - do idx = 1, SIZE(rho_dry, 1) - rho_dry(idx, kdx) = pmid(idx, kdx) / (temp(idx, kdx) * R_dry(idx, kdx)) !ideal gas law for dry air - end do - end do - deallocate(R_dry) - end if - end subroutine get_rho_dry_1hd - - subroutine get_rho_dry_2hd(tracer, temp, ptop, dp_dry, tracer_mass, rho_dry, rhoi_dry, & - active_species_idx_dycore) - ! Version of get_rho_dry for arrays that have a second horizontal index - real(r8), intent(in) :: tracer(:,:,:,:) ! Tracer array - real(r8), intent(in) :: temp(:,:,:) ! Temperature - real(r8), intent(in) :: ptop - real(r8), intent(in) :: dp_dry(:,:,:) - logical, intent(in) :: tracer_mass - real(r8), optional,intent(out) :: rho_dry(:,:,:) - real(r8), optional,intent(out) :: rhoi_dry(:,:,:) - ! - ! array of indicies for index of thermodynamic active species in dycore tracer array - ! (if different from physics index) - ! - integer, optional, intent(in) :: active_species_idx_dycore(:) - - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(rho_dry) .and. present(rhoi_dry)) then - call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), & - tracer_mass, rho_dry=rho_dry(:, jdx, :), rhoi_dry=rhoi_dry(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(rho_dry)) then - call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), & - tracer_mass, rho_dry=rho_dry(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore) - else if (present(rhoi_dry)) then - call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), & - tracer_mass, rhoi_dry=rhoi_dry(:, jdx, :), active_species_idx_dycore=active_species_idx_dycore) - else - call get_rho_dry(tracer(:, jdx, :, :), temp(:, jdx, :), ptop, dp_dry(:, jdx, :), tracer_mass, & - active_species_idx_dycore=active_species_idx_dycore) - end if - end do - - end subroutine get_rho_dry_2hd - !=========================================================================== - - !************************************************************************************************************************* - ! - ! compute 3D molecular diffusion and thermal conductivity - ! - !************************************************************************************************************************* - ! - subroutine get_molecular_diff_coef_1hd(temp, get_at_interfaces, sponge_factor, kmvis, kmcnd, & - tracer, fact, active_species_idx_dycore, mbarv_in) - use air_composition, only: dry_air_species_num, get_mbarv - use air_composition, only: kv1, kc1, kv2, kc2, kv_temp_exp, kc_temp_exp - - ! args - real(r8), intent(in) :: temp(:,:) ! temperature - logical, intent(in) :: get_at_interfaces ! true: compute kmvis and kmcnd at interfaces - ! false: compute kmvis and kmcnd at mid-levels - real(r8), intent(in) :: sponge_factor(:) ! multiply kmvis and kmcnd with sponge_factor - ! (for sponge layer) - real(r8), intent(out) :: kmvis(:,:) - real(r8), intent(out) :: kmcnd(:,:) - real(r8), intent(in) :: tracer(:,:,:) ! tracer array - integer, intent(in), optional :: active_species_idx_dycore(:) ! index of active species in tracer - real(r8), intent(in), optional :: fact(:,:) ! if tracer is in units of mass or moist - ! fact converts to dry mixing ratio: tracer/fact - real(r8), intent(in), optional :: mbarv_in(:,:) ! composition dependent atmosphere mean mass - ! - ! local vars - ! - integer :: idx, kdx, icnst, ispecies - real(r8):: mbarvi, mm, residual ! Mean mass at mid level - real(r8):: cnst_vis, cnst_cnd, temp_local - real(r8), dimension(SIZE(tracer,1), SIZE(sponge_factor, 1)) :: factor, mbarv - integer, dimension(thermodynamic_active_species_num) :: idx_local - character(len=*), parameter :: subname = 'get_molecular_diff_coef_1hd: ' - - !-------------------------------------------- - ! Set constants needed for updates - !-------------------------------------------- - - if (dry_air_species_num==0) then - - cnst_vis = (kv1 * mmro2 * o2_mwi + kv2 * mmrn2 * n2_mwi) * mbar - cnst_cnd = (kc1 * mmro2 * o2_mwi + kc2 * mmrn2 * n2_mwi) * mbar - if (get_at_interfaces) then - do kdx = 2, SIZE(sponge_factor, 1) - do idx = 1, SIZE(tracer, 1) - temp_local = 0.5_r8 * (temp(idx, kdx) + temp(idx, kdx - 1)) - kmvis(idx, kdx) = sponge_factor(kdx) * cnst_vis * temp_local ** kv_temp_exp - kmcnd(idx, kdx) = sponge_factor(kdx) * cnst_cnd * temp_local ** kc_temp_exp - end do - end do - ! - ! extrapolate top level value - ! - kmvis(1:SIZE(tracer, 1), 1) = 1.5_r8 * kmvis(1:SIZE(tracer, 1), 2) - 0.5_r8 * kmvis(1:SIZE(tracer, 1), 3) - kmcnd(1:SIZE(tracer, 1), 1) = 1.5_r8 * kmcnd(1:SIZE(tracer, 1), 2) - 0.5_r8 * kmcnd(1:SIZE(tracer, 1), 3) - else if (.not. get_at_interfaces) then - do kdx = 1, SIZE(sponge_factor, 1) - do idx = 1, SIZE(tracer, 1) - kmvis(idx, kdx) = sponge_factor(kdx) * cnst_vis * temp(idx, kdx) ** kv_temp_exp - kmcnd(idx, kdx) = sponge_factor(kdx) * cnst_cnd * temp(idx, kdx) ** kc_temp_exp - end do - end do - else - call endrun(subname//'get_at_interfaces must be .true. or .false.') - end if - else - if (present(active_species_idx_dycore)) then - idx_local = active_species_idx_dycore - else - idx_local = thermodynamic_active_species_idx - end if - if (present(fact)) then - factor = fact(:,:) - else - factor = 1.0_r8 - endif - if (present(mbarv_in)) then - mbarv = mbarv_in - else - call get_mbarv(tracer, idx_local, mbarv, fact=factor) - end if - ! - ! major species dependent code - ! - if (get_at_interfaces) then - do kdx = 2, SIZE(sponge_factor, 1) - do idx = 1, SIZE(tracer, 1) - kmvis(idx, kdx) = 0.0_r8 - kmcnd(idx, kdx) = 0.0_r8 - residual = 1.0_r8 - do icnst = 1, dry_air_species_num - ispecies = idx_local(icnst) - mm = 0.5_r8 * (tracer(idx, kdx, ispecies) * factor(idx, kdx) + & - tracer(idx, kdx - 1, ispecies) * factor(idx, kdx-1)) - kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & - thermodynamic_active_species_mwi(icnst) * mm - kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & - thermodynamic_active_species_mwi(icnst) * mm - residual = residual - mm - end do - icnst = 0 ! N2 - kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & - thermodynamic_active_species_mwi(icnst) * residual - kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & - thermodynamic_active_species_mwi(icnst) * residual - - temp_local = 0.5_r8 * (temp(idx, kdx - 1) + temp(idx, kdx)) - mbarvi = 0.5_r8 * (mbarv(idx, kdx - 1) + mbarv(idx, kdx)) - kmvis(idx, kdx) = kmvis(idx, kdx) * mbarvi * temp_local ** kv_temp_exp - kmcnd(idx, kdx) = kmcnd(idx, kdx) * mbarvi * temp_local ** kc_temp_exp - enddo - end do - do idx = 1, SIZE(tracer, 1) - kmvis(idx, 1) = 1.5_r8 * kmvis(idx, 2) - .5_r8 * kmvis(idx, 3) - kmcnd(idx, 1) = 1.5_r8 * kmcnd(idx, 2) - .5_r8 * kmcnd(idx, 3) - kmvis(idx, SIZE(sponge_factor, 1) + 1) = kmvis(idx, SIZE(sponge_factor, 1)) - kmcnd(idx, SIZE(sponge_factor, 1) + 1) = kmcnd(idx, SIZE(sponge_factor, 1)) - end do - else if (.not. get_at_interfaces) then - do kdx = 1, SIZE(sponge_factor, 1) - do idx = 1, SIZE(tracer, 1) - kmvis(idx, kdx) = 0.0_r8 - kmcnd(idx, kdx) = 0.0_r8 - residual = 1.0_r8 - do icnst = 1, dry_air_species_num - 1 - ispecies = idx_local(icnst) - mm = tracer(idx, kdx, ispecies) * factor(idx, kdx) - kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & - thermodynamic_active_species_mwi(icnst) * mm - kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & - thermodynamic_active_species_mwi(icnst) * mm - residual = residual - mm - end do - icnst = dry_air_species_num - kmvis(idx, kdx) = kmvis(idx, kdx) + thermodynamic_active_species_kv(icnst) * & - thermodynamic_active_species_mwi(icnst) * residual - kmcnd(idx, kdx) = kmcnd(idx, kdx) + thermodynamic_active_species_kc(icnst) * & - thermodynamic_active_species_mwi(icnst) * residual - - kmvis(idx, kdx) = kmvis(idx, kdx) * mbarv(idx, kdx) * temp(idx, kdx) ** kv_temp_exp - kmcnd(idx, kdx) = kmcnd(idx, kdx) * mbarv(idx, kdx) * temp(idx, kdx) ** kc_temp_exp - end do - end do - else - call endrun(subname//'get_at_interfaces must be .true. or .false.') - end if - end if - end subroutine get_molecular_diff_coef_1hd - - subroutine get_molecular_diff_coef_2hd(temp, get_at_interfaces, sponge_factor, kmvis, kmcnd, & - tracer, fact, active_species_idx_dycore, mbarv_in) - ! Version of get_molecular_diff_coef for arrays that have a second horizontal index - real(r8), intent(in) :: temp(:,:,:) ! temperature - logical, intent(in) :: get_at_interfaces ! true: compute kmvis and kmcnd at interfaces - ! false: compute kmvis and kmcnd at mid-levels - real(r8), intent(in) :: sponge_factor(:) ! multiply kmvis and kmcnd with sponge_factor - ! (for sponge layer) - real(r8), intent(out) :: kmvis(:,:,:) - real(r8), intent(out) :: kmcnd(:,:,:) - real(r8), intent(in) :: tracer(:,:,:,:) ! tracer array - integer, intent(in), optional :: active_species_idx_dycore(:) ! index of active species in tracer - real(r8), intent(in), optional :: fact(:,:,:) ! if tracer is in units of mass or moist - ! fact converts to dry mixing ratio: tracer/fact - real(r8), intent(in), optional :: mbarv_in(:,:,:) ! composition dependent atmosphere mean mass - integer :: jdx - - do jdx = 1, SIZE(tracer, 2) - if (present(fact) .and. present(mbarv_in)) then - call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & - kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), fact=fact(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore, mbarv_in=mbarv_in(:, jdx, :)) - else if (present(fact)) then - call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & - kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), fact=fact(:, jdx, :), & - active_species_idx_dycore=active_species_idx_dycore) - else if (present(mbarv_in)) then - call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & - kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), & - active_species_idx_dycore=active_species_idx_dycore, mbarv_in=mbarv_in(:, jdx, :)) - else - call get_molecular_diff_coef(temp(:, jdx, :), get_at_interfaces, sponge_factor, & - kmvis(:, jdx, :), kmcnd(:, jdx, :), tracer(:, jdx, :, :), & - active_species_idx_dycore=active_species_idx_dycore) - end if - end do - - end subroutine get_molecular_diff_coef_2hd - !=========================================================================== - - !*************************************************************************** - ! - ! compute reference vertical profile of density, molecular diffusion and thermal conductivity - ! - !*************************************************************************** - ! - subroutine get_molecular_diff_coef_reference(tref,press,sponge_factor,kmvis_ref,kmcnd_ref,rho_ref) - use physconst, only: rair - use air_composition, only: kv1, kv2, kc1, kc2, kv_temp_exp, kc_temp_exp - ! args - real(r8), intent(in) :: tref !reference temperature - real(r8), intent(in) :: press(:) !pressure - real(r8), intent(in) :: sponge_factor(:) !multiply kmvis and kmcnd with sponge_factor (for sponge layer) - real(r8), intent(out) :: kmvis_ref(:) !reference molecular diffusion coefficient - real(r8), intent(out) :: kmcnd_ref(:) !reference thermal conductivity coefficient - real(r8), intent(out) :: rho_ref(:) !reference density - - ! local vars - integer :: kdx - - !-------------------------------------------- - ! Set constants needed for updates - !-------------------------------------------- - - do kdx = 1, SIZE(press, 1) - rho_ref(kdx) = press(kdx) / (tref * rair) !ideal gas law for dry air - kmvis_ref(kdx) = sponge_factor(kdx) * & - (kv1 * mmro2 * o2_mwi + & - kv2 * mmrn2 * n2_mwi) * mbar * & - tref ** kv_temp_exp - kmcnd_ref(kdx) = sponge_factor(kdx) * & - (kc1 * mmro2 * o2_mwi + & - kc2 * mmrn2 * n2_mwi) * mbar * & - tref ** kc_temp_exp - end do - end subroutine get_molecular_diff_coef_reference - - !========================================================================== - - ! - !*************************************************************************** - ! - ! cam_thermo_calc_kappav: update species dependent kappa for FV dycore - ! - !*************************************************************************** - ! - subroutine cam_thermo_calc_kappav_2hd(tracer, kappav, cpv) - use air_composition, only: get_R_dry, get_cp_dry - ! assumes moist MMRs - - ! Dummy arguments - real(r8), intent(in) :: tracer(:, :, :, :) - real(r8), intent(out) :: kappav(:, :, :) - real(r8), optional, intent(out) :: cpv(:, :, :) - - ! Local variables - real(r8) :: rgas_var(SIZE(tracer, 1), SIZE(tracer, 2), SIZE(tracer, 3)) - real(r8) :: cp_var(SIZE(tracer, 1), SIZE(tracer, 2), SIZE(tracer, 3)) - integer :: ind, jnd, knd - - !----------------------------------------------------------------------- - ! Calculate constituent dependent specific heat, gas constant and cappa - !----------------------------------------------------------------------- - call get_R_dry(tracer, thermodynamic_active_species_idx, rgas_var) - call get_cp_dry(tracer, thermodynamic_active_species_idx, cp_var) - !$omp parallel do private(ind,jnd,knd) - do knd = 1, SIZE(tracer, 3) - do jnd = 1, SIZE(tracer, 2) - do ind = 1, SIZE(tracer, 1) - kappav(ind,jnd,knd) = rgas_var(ind,jnd,knd) / cp_var(ind,jnd,knd) - end do - end do - end do - - if (present(cpv)) then - cpv(:,:,:) = cp_var(:,:,:) - end if - - end subroutine cam_thermo_calc_kappav_2hd - - !=========================================================================== - ! - !*************************************************************************** - ! - ! compute column integrated total energy consistent with vertical - ! coordinate as well as vertical integrals of water mass (H2O,wv,liq,ice) - ! - ! if subroutine is asked to compute "te" then the latent heat terms are - ! added to the kinetic (ke), internal + geopotential (se) energy terms - ! - ! subroutine assumes that enthalpy term (rho*cp*T) uses dry air heat capacity !tht: why? not true - ! - !*************************************************************************** - ! - subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & - cp_or_cv, U, V, T, vcoord, ptop, phis, z_mid, dycore_idx, qidx, & - te, se, po, ke, wv, H2O, liq, ice) - - use cam_logfile, only: iulog - use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure - use air_composition, only: wv_idx - use physconst, only: rga, latvap, latice - use physconst, only: cpliq, cpice, cpwv, tmelt - use air_composition, only: t00a, h00a, h00a_vap, h00a_ice !+tht - - ! Dummy arguments - ! tracer: tracer mixing ratio - ! - ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry - real(r8), intent(in) :: tracer(:,:,:) - logical, intent(in) :: moist_mixing_ratio - ! pdel: pressure level thickness - real(r8), intent(in) :: pdel_in(:,:) - ! cp_or_cv: dry air heat capacity under constant pressure or - ! constant volume (depends on vcoord) - real(r8), intent(in) :: cp_or_cv(:,:) - real(r8), intent(in) :: U(:,:) - real(r8), intent(in) :: V(:,:) - real(r8), intent(in) :: T(:,:) - integer, intent(in) :: vcoord ! vertical coordinate - real(r8), intent(in), optional :: ptop(:) - real(r8), intent(in), optional :: phis(:) - real(r8), intent(in), optional :: z_mid(:,:) - ! dycore_idx: use dycore index for thermodynamic active species - logical, intent(in), optional :: dycore_idx - ! qidx: Index of water vapor - integer, intent(in), optional :: qidx - ! H2O: vertically integrated total water - real(r8), intent(out), optional :: H2O(:) - ! TE: vertically integrated total energy - real(r8), intent(out), optional :: te (:) - ! KE: vertically integrated kinetic energy - real(r8), intent(out), optional :: ke (:) - ! SE: vertically integrated enthalpy (pressure coordinate) - ! or internal energy (z coordinate) - real(r8), intent(out), optional :: se (:) - ! PO: vertically integrated PHIS term (pressure coordinate) - ! or potential energy (z coordinate) - real(r8), intent(out), optional :: po (:) - ! WV: vertically integrated water vapor - real(r8), intent(out), optional :: wv (:) - ! liq: vertically integrated liquid - real(r8), intent(out), optional :: liq(:) - ! ice: vertically integrated ice - real(r8), intent(out), optional :: ice(:) - - ! Local variables - real(r8) :: ke_vint(SIZE(tracer, 1)) ! Vertical integral of KE - real(r8) :: se_vint(SIZE(tracer, 1)) ! Vertical integral of enthalpy or internal energy - real(r8) :: po_vint(SIZE(tracer, 1)) ! Vertical integral of PHIS or potential energy - real(r8) :: wv_vint(SIZE(tracer, 1)) ! Vertical integral of wv - real(r8) :: liq_vint(SIZE(tracer, 1)) ! Vertical integral of liq - real(r8) :: ice_vint(SIZE(tracer, 1)) ! Vertical integral of ice - real(r8) :: wtot_vint(SIZE(tracer, 1))! Vertical integral of water - real(r8) :: pdel(SIZE(tracer, 1),SIZE(tracer, 2)) !moist pressure level thickness - real(r8) :: latsub ! latent heat of sublimation - - integer :: ierr - integer :: kdx, idx ! coord indices - integer :: qdx ! tracer index - integer :: wvidx ! water vapor index - integer, allocatable :: species_idx(:) - integer, allocatable :: species_liq_idx(:) - integer, allocatable :: species_ice_idx(:) - character(len=*), parameter :: subname = 'get_hydrostatic_energy' - - allocate(species_idx(thermodynamic_active_species_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_idx array') - end if - allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_liq_idx array') - end if - allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_ice_idx array') - end if - - if (present(dycore_idx))then - if (dycore_idx) then - species_idx(:) = thermodynamic_active_species_idx_dycore(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) - else - species_idx(:) = thermodynamic_active_species_idx(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) - end if - else - species_idx(:) = thermodynamic_active_species_idx(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) - end if - - if (present(qidx)) then - wvidx = qidx - else - wvidx = wv_idx - end if - - if (moist_mixing_ratio) then - pdel = pdel_in - else - pdel = pdel_in - do qdx = dry_air_species_num+1, thermodynamic_active_species_num - pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx)) - end do - end if - - ke_vint = 0._r8 - se_vint = 0._r8 - select case (vcoord) - case(vc_moist_pressure, vc_dry_pressure) - if (.not. present(ptop).or. (.not. present(phis))) then - write(iulog, *) subname, ' ptop and phis must be present for ', & - 'moist/dry pressure vertical coordinate' - call endrun(subname//': ptop and phis must be present for '// & - 'moist/dry pressure vertical coordinate') - end if - po_vint = ptop - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - ke_vint(idx) = ke_vint(idx) + (pdel(idx, kdx) * & - 0.5_r8 * (U(idx, kdx)**2 + V(idx, kdx)**2)) * rga - se_vint(idx) = se_vint(idx) + (T(idx, kdx) * & - cp_or_cv(idx, kdx) * pdel(idx, kdx) * rga) - po_vint(idx) = po_vint(idx)+pdel(idx, kdx) - - end do - end do - do idx = 1, SIZE(tracer, 1) - po_vint(idx) = (phis(idx) * po_vint(idx) * rga) - end do - case(vc_height) - if (.not. present(phis)) then - write(iulog, *) subname, ' phis must be present for ', & - 'heigt-based vertical coordinate' - call endrun(subname//': phis must be present for '// & - 'height-based vertical coordinate') - end if - po_vint = 0._r8 - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - ke_vint(idx) = ke_vint(idx) + (pdel(idx, kdx) * & - 0.5_r8 * (U(idx, kdx)**2 + V(idx, kdx)**2) * rga) - se_vint(idx) = se_vint(idx) + (T(idx, kdx) * & - cp_or_cv(idx, kdx) * pdel(idx, kdx) * rga) - ! z_mid is height above ground - po_vint(idx) = po_vint(idx) + (z_mid(idx, kdx) + & - phis(idx) * rga) * pdel(idx, kdx) - end do - end do - case default - write(iulog, *) subname, ' vertical coordinate not supported: ', vcoord - call endrun(subname//': vertical coordinate not supported') - end select - if (present(te)) then - te = se_vint + po_vint+ ke_vint - end if - if (present(se)) then - se = se_vint - end if - if (present(po)) then - po = po_vint - end if - if (present(ke)) then - ke = ke_vint - end if - ! - ! vertical integral of total liquid water - ! - if (.not.moist_mixing_ratio) then - pdel = pdel_in! set pseudo density to dry - end if - - wv_vint = 0._r8 - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - wv_vint(idx) = wv_vint(idx) + (tracer(idx, kdx, wvidx) * & - pdel(idx, kdx) * rga) - end do - end do - if (present(wv)) wv = wv_vint - - liq_vint = 0._r8 - do qdx = 1, thermodynamic_active_species_liq_num - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - liq_vint(idx) = liq_vint(idx) + (pdel(idx, kdx) * & - tracer(idx, kdx, species_liq_idx(qdx)) * rga) - end do - end do - end do - if (present(liq)) liq = liq_vint - - ! - ! vertical integral of total frozen (ice) water - ! - ice_vint = 0._r8 - do qdx = 1, thermodynamic_active_species_ice_num - do kdx = 1, SIZE(tracer, 2) - do idx = 1, SIZE(tracer, 1) - ice_vint(idx) = ice_vint(idx) + (pdel(idx, kdx) * & - tracer(idx, kdx, species_ice_idx(qdx)) * rga) - end do - end do - end do - if (present(ice)) ice = ice_vint - - ! Compute vertical integrals of total water. - wtot_vint = wv_vint + liq_vint + ice_vint - if (present(H2O)) then - H2O = wtot_vint - end if - - ! latent heat terms depend on enthalpy reference state - !tht: note choices in physconst however, ensuring they actually - latsub = latvap + latice - if (present(te)) then - select case (TRIM(enthalpy_reference_state)) - case('ice') - te = te + (latsub * wv_vint) + (latice * liq_vint) - !+tht: add t00 and h00 terms - if(vcoord.ne.vc_moist_pressure) then - te = te + wv_vint*(cpice-cpwv )*t00a - te = te + liq_vint*(cpice-cpliq)*t00a - te = te + wtot_vint*h00a_ice - endif - case('liq') - te = te + (latvap * wv_vint) - (latice * ice_vint) - !+tht: add t00 and h00 terms - if(vcoord.ne.vc_moist_pressure) then - te = te + wv_vint*(cpliq-cpwv )*t00a - te = te + ice_vint*(cpliq-cpice)*t00a - te = te + wtot_vint*h00a - endif - case('vap') - te = te - (latvap * liq_vint) - (latsub * ice_vint) - !+tht: add t00 and h00 terms - if(vcoord.ne.vc_moist_pressure) then - te = te + liq_vint*(cpwv -cpliq)*t00a - te = te + ice_vint*(cpwv -cpice)*t00a - te = te + wtot_vint*h00a_vap - endif - case default - write(iulog, *) subname, ' enthalpy reference state not ', & - 'supported: ', TRIM(enthalpy_reference_state) - call endrun(subname//': enthalpy reference state not supported') - end select - end if - deallocate(species_idx, species_liq_idx, species_ice_idx) - end subroutine get_hydrostatic_energy_1hd -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!+tht - subroutine get_conserved_energy(moist_mixing_ratio, ktop, kbot & - , cp_or_cv, T, tracer, pdel_in & - , pdel, te & - , qini, liqini, iceini & - , phis & - , gph & - , U, V, W, rairv & - , flatent,latent,potential,kinetic,temce & - , refstate, vcoord, dycore_idx) - - use dycore, only: dycore_is - use cam_logfile, only: iulog - use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure - use air_composition, only: wv_idx - use physconst, only: rga, latvap, latice - use physconst, only: cpliq, cpice, cpwv, tmelt - use air_composition, only: t00a, h00a, h00a_vap, h00a_ice - -! ARGUMENTS: -! IN: - ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry - logical , intent(in) :: moist_mixing_ratio - integer , intent(in) :: ktop, kbot - ! cp_or_cv: dry air heat capacity under constant pressure or - ! constant volume (depends on vcoord) - real(r8), intent(in) :: cp_or_cv(:,:) - real(r8), intent(in) :: T(:,:) - real(r8), intent(in) :: tracer(:,:,:) - ! pdel: pressure level thickness - real(r8), intent(in) :: pdel_in(:,:) !N.B. this should be g*\rho*dz for MPAS -! OUT: conserved total energy/enthalpy per unit mass - real(r8), intent(out) :: te (:,:) - ! pdel: layer mass - real(r8), intent(out) :: pdel(:,:) !N.B. this should be g*\rho*dz for MPAS -! optional args: - real(r8), intent(in), optional :: qini(:,:), liqini(:,:), iceini(:,:) - ! surface geopotential -- should be made mandatory arg - real(r8), intent(in), optional :: phis(:) - ! geopotential height, required for MPAS: te=u_m:=c_v*T+latent+gz+KE - ! dycore_is('MPAS') and gph not present -> stop - real(r8), intent(in), optional :: gph(:,:) - !N.B. either PHIS or GPH must be present - ! horizontal winds --> add KE (should be made mandatory arguments) - real(r8), intent(in), optional :: U(:,:) - real(r8), intent(in), optional :: V(:,:) - ! vertical wind --> add to KE (non-hydrostatic) - real(r8), intent(in), optional :: W(:,:) - real(r8), intent(in), optional :: Rairv(:,:) - character(len=3),intent(in),optional :: refstate - integer, intent(in), optional :: vcoord ! vertical coordinate - ! dycore_idx: use dycore index for thermodynamic active species - logical, intent(in) , optional :: dycore_idx - real(r8), intent(out), optional :: flatent(:,:) - real(r8), intent(out), optional :: latent(:,:) - real(r8), intent(out), optional :: potential(:,:) - real(r8), intent(out), optional :: kinetic(:,:) - real(r8), intent(out), optional :: temce(:,:) ! Total Enthalpy Minus Conserved Energy - - ! Local variables - real(r8) :: qwv (SIZE(tracer, 1),SIZE(tracer, 2)) & - ,qliq(SIZE(tracer, 1),SIZE(tracer, 2)) & - ,qice(SIZE(tracer, 1),SIZE(tracer, 2)) & - ,qtot(SIZE(tracer, 1),SIZE(tracer, 2)), latsub - real(r8) :: work(SIZE(tracer, 1),SIZE(tracer, 2)) - - integer :: ierr - integer :: kdx, idx, nkd, nid ! coord indices - integer :: qdx ! tracer index - integer :: wvidx ! water vapor index - integer, allocatable :: species_idx(:) - integer, allocatable :: species_liq_idx(:) - integer, allocatable :: species_ice_idx(:) - character(len=3) :: loc_refstate - character(len=*), parameter :: subname = 'get_conserved_energy' - - allocate(species_idx(thermodynamic_active_species_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_idx array') - end if - allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_liq_idx array') - end if - allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_ice_idx array') - end if - - nkd=SIZE(tracer, 2) - nid=SIZE(tracer, 1) - - if(present(refstate))then - loc_refstate=trim(refstate) - else - loc_refstate=trim(enthalpy_reference_state) - endif - - if (present(dycore_idx))then - if (dycore_idx) then - species_idx(:) = thermodynamic_active_species_idx_dycore(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) - else - species_idx(:) = thermodynamic_active_species_idx(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) - end if - else - species_idx(:) = thermodynamic_active_species_idx(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) - end if - - if (moist_mixing_ratio) then - pdel = pdel_in*rga - else - pdel = pdel_in*rga - if(present(qini).and.present(liqini).and.present(iceini))then - pdel(:,:) = pdel(:,:) + pdel_in(:, :)*(qini(:,:)+liqini(:,:)+iceini(:,:))*rga - else - do qdx = dry_air_species_num+1, thermodynamic_active_species_num - pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx))*rga - end do - endif - end if - - do kdx = ktop, kbot - do idx = 1, nid - te(idx,kdx) = T(idx,kdx)*cp_or_cv(idx, kdx) - end do - end do - - work(:,:)=0._r8 - if(present(phis))then - do kdx = ktop, kbot - do idx = 1, nid - work(idx,kdx) = phis(idx) - end do - end do - endif - if(dycore_is('MPAS')) then - if(.not.present(gph)) call endrun(subname//': conserved_energy function'// & - ' requires GPH in input for non-hydrostatic case') - do kdx = ktop, kbot - do idx = 1, nid - work(idx,kdx) = work(idx,kdx) + gph(idx,kdx)/rga - end do - end do - endif - if (present(potential)) then - do kdx = ktop, kbot - do idx = 1, nid - potential(idx,kdx) = work(idx,kdx) - end do - end do - else - do kdx = ktop, kbot - do idx = 1, nid - te(idx,kdx) = te(idx,kdx) + work(idx,kdx) - end do - end do - endif - - if(present(qini).and.present(liqini).and.present(iceini))then - qwv (:,:)=qini (:,:) - qliq(:,:)=liqini(:,:) - qice(:,:)=iceini(:,:) - else - qwv (:,:) = tracer(:,:,wv_idx) - qliq(:,:) = 0._r8 - do qdx = 1, thermodynamic_active_species_liq_num - qliq(:,:) = qliq(:,:) + tracer(:,:,species_liq_idx(qdx)) - enddo - qice(:,:) = 0._r8 - do qdx = 1, thermodynamic_active_species_ice_num - qice(:,:) = qice(:,:) + tracer(:,:,species_ice_idx(qdx)) - enddo - endif - - latsub = latvap + latice - select case (TRIM(loc_refstate)) - case('ice') - work(:,:) = (latsub * qwv ) + (latice * qliq) - case('liq') - work(:,:) = (latvap * qwv ) - (latice * qice) - case('vap') - work(:,:) =-(latvap * qliq) - (latsub * qice) - case default - write(iulog, *) subname, ' enthalpy reference state not ', & - 'supported: ', TRIM(loc_refstate) - call endrun(subname//': enthalpy reference state not supported') - end select - if (present(latent).or.present(flatent)) then - if (present(flatent)) then - do kdx = ktop, kbot - do idx = 1, nid - flatent(idx,kdx) = work(idx,kdx) - end do - end do - endif - if (present(latent)) then - do kdx = ktop, kbot - do idx = 1, nid - latent(idx,kdx) = work(idx,kdx) - end do - end do - endif - else - do kdx = ktop, kbot - do idx = 1, nid - te(idx,kdx) = te(idx,kdx) + work(idx,kdx) - end do - end do - endif - - ! add t00 and h00 terms - if(present(vcoord))then - if(vcoord.ne.vc_moist_pressure) then - qtot(:,:) = qice(:,:) + qliq(:,:) + qwv (:,:) - select case (TRIM(loc_refstate)) - case('ice') - work(:,:) = qwv (:,:)*(cpice-cpwv )*t00a & - + qliq(:,:)*(cpice-cpliq)*t00a & - + qtot(:,:)*h00a_ice - case('liq') - work(:,:) = qwv (:,:)*(cpliq-cpwv )*t00a & - + qice(:,:)*(cpliq-cpice)*t00a & - + qtot(:,:)*h00a - case('vap') - work(:,:) = qliq(:,:)*(cpwv -cpliq)*t00a & - + qice(:,:)*(cpwv -cpice)*t00a & - + qtot(:,:)*h00a_vap - end select - if (present(latent)) then - do kdx = ktop, kbot - do idx = 1, nid - latent(idx,kdx) = latent(idx,kdx)+work(idx,kdx) - end do - end do - else - do kdx = ktop, kbot - do idx = 1, nid - te(idx,kdx) = te(idx,kdx) + work(idx,kdx) - end do - end do - endif - endif - endif - - if(present(U).and.present(V)) then - do kdx = ktop, kbot - do idx = 1, nid - work(idx,kdx) = .5_r8*(u(idx,kdx)**2+v(idx,kdx)**2) - enddo - enddo - if (present(kinetic)) then - do kdx = ktop, kbot - do idx = 1, nid - kinetic(idx,kdx)= work(idx,kdx) - end do - end do - else - do kdx = ktop, kbot - do idx = 1, nid - te(idx,kdx) = te(idx,kdx) + work(idx,kdx) - end do - end do - endif - endif - - if(present(temce)) then - if(dycore_is('MPAS'))then - if(.not.(present(rairv))) call endrun(subname//': TEMCE required but'// & - ' Rairv not provided in non-hydrostatic case') - do kdx = ktop, kbot - do idx = 1, nid - temce(idx,kdx) = T(idx,kdx)*rairv(idx, kdx) - end do - end do - else - if(.not.(present(gph))) call endrun(subname//': TEMCE required but'// & - ' GPH not provided in hydrostatic case') - do kdx = ktop, kbot - do idx = 1, nid - temce(idx,kdx) = gph(idx,kdx)/rga - end do - end do - endif - endif - - deallocate(species_idx, species_liq_idx, species_ice_idx) - - end subroutine get_conserved_energy - - subroutine inv_conserved_energy(moist_mixing_ratio & - , ktop, kbot & - , te, cp_or_cv, tracer, pdel_in & - , pdel, T & - , phis & - , gph & - , U, V, W & - , flatent,latent,potential,kinetic & - , refstate, vcoord, dycore_idx) - - use cam_logfile, only: iulog - use dycore, only: dycore_is - use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure - use air_composition, only: wv_idx - use physconst, only: rga, latvap, latice - use physconst, only: cpliq, cpice, cpwv, tmelt - use air_composition, only: t00a, h00a, h00a_vap, h00a_ice - -! ARGUMENTS: -! IN: - ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry - logical , intent(in) :: moist_mixing_ratio - integer , intent(in) :: ktop, kbot - ! conserved energy/enthalpy - real(r8), intent(in) :: te(:,:) - ! cp_or_cv: dry air heat capacity under constant pressure or - ! constant volume (depends on vcoord) - real(r8), intent(in) :: cp_or_cv(:,:) - real(r8), intent(in) :: tracer(:,:,:) - ! pdel: pressure level thickness - real(r8), intent(in) :: pdel_in(:,:) !N.B. this should be g*\rho*dz for MPAS -! OUT: temperature - real(r8), intent(out) :: T(:,:) - ! pdel: layer mass - real(r8), intent(out) :: pdel(:,:) !N.B. this should be g*\rho*dz for MPAS -! optional args: - ! surface geopotential --> compute te=e_m:=c_p*T+latent+phis+KE (hydrostatic) - real(r8), intent(in), optional :: phis(:) - ! geopotential height --> compute te=u_m:=c_v*T+latent+gz+KE (MPAS) - ! should be =z_mid in output os subroutine geopotential_t - real(r8), intent(in), optional :: gph(:,:) - character(len=3),intent(in),optional :: refstate - integer, intent(in), optional :: vcoord ! vertical coordinate - !N.B. either PHIS or GPH must be present - ! dycore_idx: use dycore index for thermodynamic active species - logical, intent(in), optional :: dycore_idx - ! horizontal winds --> add KE (will be made mandatory arguments later) - real(r8), intent(in), optional :: U(:,:) - real(r8), intent(in), optional :: V(:,:) - ! vertical wind --> add to KE (MPAS) - real(r8), intent(in), optional :: W(:,:) - real(r8), intent(in), optional :: flatent(:,:) - real(r8), intent(in), optional :: latent(:,:) - real(r8), intent(in), optional :: potential(:,:) - real(r8), intent(in), optional :: kinetic(:,:) - - ! Local variables - real(r8) ::tetmp(SIZE(tracer, 1),SIZE(tracer, 2)) - real(r8) :: qwv (SIZE(tracer, 1),SIZE(tracer, 2)) & - ,qliq(SIZE(tracer, 1),SIZE(tracer, 2)) & - ,qice(SIZE(tracer, 1),SIZE(tracer, 2)) & - ,qtot(SIZE(tracer, 1),SIZE(tracer, 2)), latsub - - integer :: ierr - integer :: kdx, idx, nkd, nid ! coord indices - integer :: qdx ! tracer index - integer :: wvidx ! water vapor index - integer, allocatable :: species_idx(:) - integer, allocatable :: species_liq_idx(:) - integer, allocatable :: species_ice_idx(:) - character(len=3) :: loc_refstate - character(len=*), parameter :: subname = 'get_conserved_energy' - - allocate(species_idx(thermodynamic_active_species_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_idx array') - end if - allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_liq_idx array') - end if - allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) - if ( ierr /= 0 ) then - call endrun(subname//': allocation error for species_ice_idx array') - end if - - nkd=SIZE(tracer, 2) - nid=SIZE(tracer, 1) - - if(present(refstate))then - loc_refstate=trim(refstate) - else - loc_refstate=trim(enthalpy_reference_state) - endif - - if (present(dycore_idx))then - if (dycore_idx) then - species_idx(:) = thermodynamic_active_species_idx_dycore(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) - else - species_idx(:) = thermodynamic_active_species_idx(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) - end if - else - species_idx(:) = thermodynamic_active_species_idx(:) - species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) - species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) - end if - - if (moist_mixing_ratio) then - pdel = pdel_in*rga - else - pdel = pdel_in*rga - do qdx = dry_air_species_num+1, thermodynamic_active_species_num - pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx))*rga - end do - end if - - if(present(kinetic)) then - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = te(idx,kdx) - kinetic(idx,kdx) - enddo - enddo - else if(present(U).and.present(V)) then - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = te(idx,kdx) - .5_r8*(u(idx,kdx)**2+v(idx,kdx)**2) - enddo - enddo - else - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = te(idx,kdx) - end do - end do - endif - - if(present(potential)) then - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = tetmp(idx,kdx) - potential(idx,kdx) - end do - end do - else - if(present(phis))then - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = tetmp(idx,kdx) - phis(idx) - end do - end do - endif - if(dycore_is('MPAS')) then - if(.not.present(gph)) call endrun(subname//': conserved_energy function'// & - ' requires GPH in input for non-hydrostatic case') - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = tetmp(idx,kdx) - gph(idx,kdx)/rga - end do - end do - endif - endif - - if (present(latent)) then - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = tetmp(idx,kdx) - latent(idx,kdx) - end do - end do - else - qwv (:,:) = tracer(:,:,wv_idx) - qliq(:,:) = 0._r8 - do qdx = 1, thermodynamic_active_species_liq_num - qliq(:,:) = qliq(:,:) + tracer(:,:,species_liq_idx(qdx)) - enddo - qice(:,:) = 0._r8 - do qdx = 1, thermodynamic_active_species_ice_num - qice(:,:) = qice(:,:) + tracer(:,:,species_ice_idx(qdx)) - enddo - qtot(:,:) = qice(:,:) + qliq(:,:) + qwv (:,:) - if (present(flatent)) then - do kdx = ktop, kbot - do idx = 1, nid - tetmp(idx,kdx) = tetmp(idx,kdx) - flatent(idx,kdx) - end do - end do - if(present(vcoord))then - if(vcoord.ne.vc_moist_pressure) then - ! add t00 and h00 terms - select case (TRIM(loc_refstate)) - case('ice') - tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpice-cpwv )*t00a & - +qliq(:,:)*(cpice-cpliq)*t00a & - +qtot(:,:)*h00a_ice ) - case('liq') - tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpliq-cpwv )*t00a & - +qice(:,:)*(cpliq-cpice)*t00a & - +qtot(:,:)*h00a ) - case('vap') - tetmp(:,:) = tetmp(:,:) -(qliq(:,:)*(cpwv -cpliq)*t00a & - +qice(:,:)*(cpwv -cpice)*t00a & - +qtot(:,:)*h00a_vap ) - case default - write(iulog, *) subname, ' enthalpy reference state not ', & - 'supported: ', TRIM(loc_refstate) - call endrun(subname//': enthalpy reference state not supported') - end select - endif - endif - else - latsub = latvap + latice - select case (TRIM(loc_refstate)) - case('ice') - tetmp(:,:) = tetmp(:,:) - (latsub * qwv ) - (latice * qliq) - if(present(vcoord))then - if(vcoord.ne.vc_moist_pressure) then - tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpice-cpwv )*t00a & - +qliq(:,:)*(cpice-cpliq)*t00a & - +qtot(:,:)*h00a_ice ) - endif - endif - case('liq') - tetmp(:,:) = tetmp(:,:) - (latvap * qwv ) + (latice * qice) - if(present(vcoord))then - if(vcoord.ne.vc_moist_pressure) then - tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpliq-cpwv )*t00a & - +qice(:,:)*(cpliq-cpice)*t00a & - +qtot(:,:)*h00a ) - endif - endif - case('vap') - tetmp(:,:) = tetmp(:,:) + (latvap * qliq) + (latsub * qice) - if(present(vcoord))then - if(vcoord.ne.vc_moist_pressure) then - tetmp(:,:) = tetmp(:,:) -(qliq(:,:)*(cpwv -cpliq)*t00a & - +qice(:,:)*(cpwv -cpice)*t00a & - +qtot(:,:)*h00a_vap ) - endif - endif - case default - write(iulog, *) subname, ' enthalpy reference state not ', & - 'supported: ', TRIM(loc_refstate) - call endrun(subname//': enthalpy reference state not supported') - end select - endif - endif - - do kdx = ktop, kbot - do idx = 1, nid - T(idx,kdx) = tetmp(idx,kdx)/cp_or_cv(idx, kdx) - end do - end do - - deallocate(species_idx, species_liq_idx, species_ice_idx) - - end subroutine inv_conserved_energy -!-tht -!------------------------------------------------------------------------------- -end module cam_thermo diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 0a926f095f..c9642f145c 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -58,7 +58,7 @@ module physics_types integer, parameter, public :: dyn_te_idx = 2 integer, parameter, public :: num_hflx = 4 - + integer, parameter, public :: ihrain = 1 ! index for enthalpy flux associated with liquid precipitation integer, parameter, public :: ihsnow = 2 ! index for enthalpy flux associated with frozen precipiation integer, parameter, public :: ifrain = 3 ! index for flux of liquid precipitation @@ -109,7 +109,7 @@ module physics_types ! Second dimension is (phys_te_idx) CAM physics total energy and ! (dyn_te_idx) dycore total energy computed in physics te_ini, &! vertically integrated total (kinetic + static) energy of initial state - te_cur ! vertically integrated total (kinetic + static) energy of current state + te_cur ! vertically integrated total (kinetic + static) energy of current state real(r8), dimension(: ),allocatable :: & tw_ini, &! vertically integrated total water of initial state tw_cur ! vertically integrated total water of new state @@ -192,14 +192,14 @@ module physics_types ! 5 possibilities (-> = currently reccommended): ! 1) conserve_dycore=.false., conserve_physics=.false. (no conservation = current CAM) ! 2) conserve_dycore=.true., bndry_flx_surface=.true. (full conservation, bad climatology) - ! -> 3) conserve_dycore=.true., bndry_flx_local=.true. (requires fixer to match correct surface fluxes) + ! -> 3) conserve_dycore=.true., bndry_flx_local=.true. (requires fixer to match correct surface fluxes) ! 4) conserve_physics=.true., bndry_flx_local=.true. (as 3., plus fixer for atmo energy) ! 5) conserve_physics=.true., bndry_flx_surface=.true. (no advantage wrt option 2) ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. logical, parameter :: conserve_dycore =.true. & - ,bndry_flx_surface=.true. - !,bndry_flx_surface=.true. + ,bndry_flx_surface=.true. + !,bndry_flx_surface=.true. logical, parameter :: conserve_physics =(.not.conserve_dycore).and..true. & ,bndry_flx_local = .not.bndry_flx_surface !-tht @@ -245,7 +245,7 @@ subroutine physics_update(state, ptend, dt, tend ) ! tht use scamMod, only: scm_crm_mode, single_column use phys_control, only: phys_getopts use cam_thermo, only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X) - use cam_thermo, only: get_conserved_energy,inv_conserved_energy !+tht + use cam_thermo, only: get_conserved_energy, inv_conserved_energy use air_composition, only: dry_air_species_num use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx use air_composition, only: compute_enthalpy_flux @@ -1271,7 +1271,7 @@ subroutine physics_cnst_limit(state) end subroutine physics_cnst_limit !=============================================================================== -!+tht: gatekeeper module to control options for dme adjustment +!+tht: gatekeeper module to control options for dme adjustment subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt & , dme_energy_adjust , step & , ntrnprd, ntsnprd & @@ -1283,7 +1283,7 @@ subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt & , dycore_is_hydrostatic) !use phys_control, only: phys_getopts -! 25.06.14 Added new formulation of Thomas Toniazzo (Bjerknes Centre / NORCE) +! 25.06.14 Added new formulation of Thomas Toniazzo (Bjerknes Centre / NORCE) ! obligate args type(physics_state), intent(inout) :: state type(physics_tend ), intent(inout) :: tend @@ -1306,18 +1306,18 @@ subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt & real(r8), intent(out), optional :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) real(r8), intent(out), optional :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) -! local work space +! local work space integer :: ncol,icol !real(r8) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) real(r8) :: tevp (pcols) ! temperature for surface evaporation real(r8) :: tprc (pcols) ! temperature for precipitation at surface real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" - real(r8) :: mdq (pcols,pver) ! total water tendency - logical :: hydrostatic =.true. + real(r8) :: mdq (pcols,pver) ! total water tendency + logical :: hydrostatic =.true. real(r8), parameter :: rtiny = 1e-04_r8 ! a small number (relative to total q change) - if(present(dycore_is_hydrostatic)) hydrostatic =dycore_is_hydrostatic + if(present(dycore_is_hydrostatic)) hydrostatic =dycore_is_hydrostatic if (present(dme_energy_adjust)) then if (dme_energy_adjust) then @@ -1390,13 +1390,13 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h ,cam_thermo_water_update use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure - !----------------------------------------------------------------------- - ! + !----------------------------------------------------------------------- + ! ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to ! atmospheric moisture change - ! + ! ! Method - ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) + ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, ! CONDEPS, and a matching heat exchange betweeen air and condensated ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). @@ -1425,12 +1425,12 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust real(r8), intent(out ) :: mdq (pcols,pver) ! total water increment for dme_adjust character(len=*),optional,intent(in)::step !which call in physpkg - real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer - real(r8), intent(in) , optional :: eflx (pcols) ! input : boundary enthalpy flux - real(r8), intent(in) , optional :: mflx (pcols) ! input : boundary mass flux + real(r8), intent(in) , optional :: eflx (pcols) ! input : boundary enthalpy flux + real(r8), intent(in) , optional :: mflx (pcols) ! input : boundary mass flux !---------------------------Local workspace----------------------------- @@ -1456,7 +1456,7 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h real(r8) :: tot_water_chg(pcols) ! work array: total water change integer :: m_cnst - real(r8) :: ps_old(pcols) ! old surface pressure + real(r8) :: ps_old(pcols) ! old surface pressure real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) real(r8) :: dvap (pcols,pver) ! wv mass adjustment @@ -1482,16 +1482,16 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h real(r8) :: uf(pcols), vf(pcols) ! work arrays - real(r8) :: pint_old(pcols,pver+1)! work array - !real(r8) :: tbot(pcols) ! work array - real(r8) :: dummy(pcols,pver) ! work array + real(r8) :: pint_old(pcols,pver+1)! work array + !real(r8) :: tbot(pcols) ! work array + real(r8) :: dummy(pcols,pver) ! work array integer :: is_invalid(pcols) logical , parameter :: conserve = conserve_dycore .or. conserve_physics real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) - + ! set to T to use distribute implied heating over column section to the surface - logical, parameter :: l_nolocdcpttend=.true. + logical, parameter :: l_nolocdcpttend=.true. logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot @@ -1548,9 +1548,9 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h m = thermodynamic_active_species_idx(m_cnst) tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) end do - mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) + mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) - dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) + dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) dliq(:ncol,k) = -liqini(:ncol,k) do m_cnst=1,thermodynamic_active_species_liq_num m = thermodynamic_active_species_liq_idx(m_cnst) @@ -1573,16 +1573,16 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h if (present(mflx)) then if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) - if (masterproc.and.logorrhoic) & ! for testing + if (masterproc.and.logorrhoic) & ! for testing print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) - endif + endif where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) is_invalid(:ncol)=1 endwhere if (maxval(is_invalid(:ncol)).gt.0) then k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) if (abs(eflx(k)).gt.rtiny) then - if (masterproc.and.logorrhoic) & ! for testing + if (masterproc.and.logorrhoic) & ! for testing print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) endif endif @@ -1677,7 +1677,7 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h elsewhere dcqm(:ncol)=0._r8 endwhere - do k=1,pver + do k=1,pver where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) endwhere @@ -1712,25 +1712,25 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h enddo endif - ! new surface pressure - state%ps(:ncol) = state%pint(:ncol,1) + ! new surface pressure + state%ps(:ncol) = state%pint(:ncol,1) do k = 1, pver state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) end do ! heat exchange with condensates - htx_cond(:ncol,:) = 0._r8 + htx_cond(:ncol,:) = 0._r8 do k = 1, pver do i=1,ncol if(l_nolocdcpttend)then ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below - if(k.eq.1) then + if(k.eq.1) then condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) else condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & - +condepsf(i,k-1) + +condepsf(i,k-1) endif else condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) @@ -1744,11 +1744,11 @@ subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, h ! compute new total pressure variables state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) - + end do - ! original pressure - state%ps (:ncol) = ps_old (:ncol) + ! original pressure + state%ps (:ncol) = ps_old (:ncol) state%pint(:ncol,:) = pint_old(:ncol,:) end subroutine physics_dme_bflx @@ -1773,11 +1773,11 @@ subroutine physics_dme_adjust_THT(state, tend, dt & use dycore, only: dycore_is ! might be rm'd when code is cleaned up use cam_history, only: outfld - !----------------------------------------------------------------------- - ! + !----------------------------------------------------------------------- + ! ! Purpose: Adjust the dry mass in each layer back to the value of physics input state ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. - ! + ! ! Method ! Revised adjustment towards consistency with local energy conservation. ! Hydrostatic pressure work, de = alpha * dp, where alpha is the specific volume @@ -1807,7 +1807,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & type(physics_state), intent(inout) :: state type(physics_tend ), intent(inout) :: tend real(r8), intent(in ) :: dt ! model physics timestep - real(r8), intent(in) :: htx_cond(pcols,pver)! exchange heating with q's leaving/entering column + real(r8), intent(in) :: htx_cond(pcols,pver)! exchange heating with q's leaving/entering column real(r8), intent(in) :: mdq (pcols,pver) ! mass adjustment real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid @@ -1815,7 +1815,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & character(len=*),optional,intent(in)::step !which call in physpkg real(r8), intent(out), optional :: ent_tnd (pcols) ! diagnostic: column-integrated enthalpy tendency real(r8), intent(out), optional :: pdel_rf (pcols,pver)! diagnostic: ratio old pdel / new pdel - logical , intent(in) , optional :: hydrostatic ! flag to set energy function to hydrostatic + logical , intent(in) , optional :: hydrostatic ! flag to set energy function to hydrostatic !---------------------------Local workspace----------------------------- @@ -1843,7 +1843,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & real(r8) :: tot_water_chg(pcols) ! total water change integer :: m_cnst - real(r8) :: ps_old(pcols) ! old surface pressure + real(r8) :: ps_old(pcols) ! old surface pressure real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) @@ -1881,7 +1881,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & if (conserve_dycore) then vcoord=vc_dycore cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) - else + else vcoord=vc_physics cpm(:ncol,:)=cpairv(:ncol,:,lchnk) endif @@ -1890,7 +1890,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & tp(:ncol,k) = state%t(:ncol,k) enddo - call get_conserved_energy(levels_are_moist & + call get_conserved_energy(levels_are_moist & ,1 ,pver & ,cpm(:ncol,:) & ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & @@ -1908,9 +1908,9 @@ subroutine physics_dme_adjust_THT(state, tend, dt & m = thermodynamic_active_species_idx(m_cnst) tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) enddo - ! new surface pressure + ! new surface pressure state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - ! make all tracers wet + ! make all tracers wet do m=1,pcnst if (cnst_type(m).eq.'dry') & state%q(:ncol,k,m) = state%q(:ncol,k,m)*(1._r8-tot_water(:ncol)) @@ -1933,7 +1933,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & !------------------- start adjustment loop ------------------------------------------ do k = 1, pver - ! new Dp (=:Dp") + ! new Dp (=:Dp") pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) fdq(:ncol) = pdel_new(:ncol,k)/state%pdel(:ncol,k) ! this is Dp"/Dp @@ -2011,7 +2011,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & enddo enddo - !call QNEG3 (cf physics_update) + !call QNEG3 (cf physics_update) do m = 1, pcnst if (m /= ixnumice .and. m /= ixnumliq .and. & m /= ixnumrain .and. m /= ixnumsnow ) then @@ -2038,7 +2038,7 @@ subroutine physics_dme_adjust_THT(state, tend, dt & ,pdel_new(:ncol,:) ,tp(:ncol,:) & ,flatent=latent(:ncol,:)*0._r8 & ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,vcoord=vcoord ,refstate='liq' & + ,vcoord=vcoord ,refstate='liq' & ,U=state%u(:ncol,:) ,V=state%v(:ncol,:)) if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then @@ -2157,10 +2157,10 @@ subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) do k = 1, pver !tht: removed heavily misleading comment state%ps(:ncol) = state%pint(:ncol,1) - + ! adjustment factor is just change in water vapor fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k) - + ! adjust constituents to conserve mass in each layer do m = 1, pcnst state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) diff --git a/src/utils/cam_thermo.F90 b/src/utils/cam_thermo.F90 index f65649c4ef..5a4fe9ee30 100644 --- a/src/utils/cam_thermo.F90 +++ b/src/utils/cam_thermo.F90 @@ -31,6 +31,7 @@ module cam_thermo ! DOI: 10.1029/2017MS001257 ! https://opensky.ucar.edu/islandora/object/articles:21929 + public :: get_conserved_energy, inv_conserved_energy ! cam_thermo_init: Initialize constituent dependent properties public :: cam_thermo_init ! cam_thermo_dry_air_update: Update dry air composition dependent properties @@ -79,6 +80,7 @@ module cam_thermo ! mixing_ratio options integer, public, parameter :: DRY_MIXING_RATIO = 1 integer, public, parameter :: MASS_MIXING_RATIO = 2 + !--------------- Variables below here are for WACCM-X --------------------- ! kmvis: molecular viscosity kg/m/s real(r8), public, protected, allocatable :: kmvis(:,:,:) @@ -285,29 +287,29 @@ subroutine cam_thermo_water_update(mmr, lchnk, ncol, vcoord, to_dry_factor) !------------------------------Arguments---------------------------------- real(r8), intent(in) :: mmr(:,:,:) ! constituents array - integer, intent(in) :: lchnk ! Chunk number - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: vcoord - real(r8), optional, intent(in) :: to_dry_factor(:,:) + integer, intent(in) :: lchnk ! Chunk number + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: vcoord + real(r8), optional, intent(in) :: to_dry_factor(:,:) ! logical :: lcp call water_composition_update(mmr, lchnk, ncol, vcoord, to_dry_factor=to_dry_factor) end subroutine cam_thermo_water_update - !=========================================================================== + !=========================================================================== - ! - !*********************************************************************** - ! - ! Compute enthalpy = cp*T*dp, where dp is pressure level thickness, - ! cp is generalized cp and T temperature - ! - ! Note: tracer is in units of m*dp_dry ("mass") - ! - !*********************************************************************** - ! - subroutine get_enthalpy_1hd(tracer_mass, temp, dp_dry, & + ! + !*********************************************************************** + ! + ! Compute enthalpy = cp*T*dp, where dp is pressure level thickness, + ! cp is generalized cp and T temperature + ! + ! Note: tracer is in units of m*dp_dry ("mass") + ! + !*********************************************************************** + ! + subroutine get_enthalpy_1hd(tracer_mass, temp, dp_dry, & enthalpy, active_species_idx_dycore) use air_composition, only: dry_air_species_num, get_cp_dry ! Dummy arguments @@ -567,7 +569,7 @@ subroutine get_sum_species_1hd(tracer, active_species_idx, & real(r8), optional, intent(in) :: dp_dry(:, :) ! sum_species: sum species real(r8), intent(out) :: sum_species(:, :) - ! factor: to moist factor + ! factor: to moist factor real(r8), optional, intent(out) :: factor(:, :) ! Local variables real(r8) :: factor_loc(SIZE(tracer, 1), SIZE(tracer, 2)) @@ -722,7 +724,7 @@ end subroutine get_dp_2hd ! compute mid-level (full level) pressure from dry pressure and water tracers ! !************************************************************************************************************************* - ! + ! subroutine get_pmid_from_dpdry_1hd(tracer, mixing_ratio, active_species_idx, dp_dry, ptop, pmid, pint, dp) real(r8), intent(in) :: tracer(:,:,:) ! tracers; quantity specified by mixing_ratio arg @@ -883,7 +885,7 @@ subroutine get_gz_from_dp_dry_ptop_temp_1hd(tracer, mixing_ratio, active_species real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2)) :: pmid_local, t_v_local, dp_local, R_dry real(r8), dimension(SIZE(tracer, 1), SIZE(tracer, 2) + 1) :: pint character(len=*), parameter :: subname = 'get_gz_from_dp_dry_ptop_temp_1hd: ' - + call get_pmid_from_dp(tracer, mixing_ratio, active_species_idx, & dp_dry, ptop, pmid_local, pint=pint, dp=dp_local) @@ -1024,7 +1026,7 @@ end subroutine get_Richardson_number_1hd ! subroutine get_ps_1hd(tracer_mass, active_species_idx, dp_dry, ps, ptop) use air_composition, only: dry_air_species_num - + real(r8), intent(in) :: tracer_mass(:,:,:) ! Tracer array (q*dp) real(r8), intent(in) :: dp_dry(:,:) ! dry pressure level thickness real(r8), intent(out) :: ps(:) ! surface pressure @@ -1571,7 +1573,7 @@ end subroutine cam_thermo_calc_kappav_2hd ! if subroutine is asked to compute "te" then the latent heat terms are ! added to the kinetic (ke), internal + geopotential (se) energy terms ! - ! subroutine assumes that enthalpy term (rho*cp*T) uses dry air heat capacity + ! subroutine assumes that enthalpy term (rho*cp*T) uses dry air heat capacity !tht: why? not true ! !*************************************************************************** ! @@ -1583,6 +1585,8 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure use air_composition, only: wv_idx use physconst, only: rga, latvap, latice + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a, h00a_vap, h00a_ice ! Dummy arguments ! tracer: tracer mixing ratio @@ -1612,7 +1616,7 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & real(r8), intent(out), optional :: te (:) ! KE: vertically integrated kinetic energy real(r8), intent(out), optional :: ke (:) - ! SE: vertically integrated enthalpy (pressure coordinate) + ! SE: vertically integrated enthalpy (pressure coordinate) ! or internal energy (z coordinate) real(r8), intent(out), optional :: se (:) ! PO: vertically integrated PHIS term (pressure coordinate) @@ -1632,6 +1636,7 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & real(r8) :: wv_vint(SIZE(tracer, 1)) ! Vertical integral of wv real(r8) :: liq_vint(SIZE(tracer, 1)) ! Vertical integral of liq real(r8) :: ice_vint(SIZE(tracer, 1)) ! Vertical integral of ice + real(r8) :: wtot_vint(SIZE(tracer, 1))! Vertical integral of water real(r8) :: pdel(SIZE(tracer, 1),SIZE(tracer, 2)) !moist pressure level thickness real(r8) :: latsub ! latent heat of sublimation @@ -1787,22 +1792,42 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & end do end do if (present(ice)) ice = ice_vint + ! Compute vertical integrals of total water. if (present(H2O)) then H2O = wv_vint + liq_vint + ice_vint end if - ! + ! latent heat terms depend on enthalpy reference state - ! + ! note choices in physconst however, ensuring they actually + wtot_vint = wv_vint + liq_vint + ice_vint latsub = latvap + latice if (present(te)) then select case (TRIM(enthalpy_reference_state)) case('ice') te = te + (latsub * wv_vint) + (latice * liq_vint) + if (vcoord .ne. vc_moist_pressure) then + ! add t00 and h00 terms + te = te + wv_vint*(cpice-cpwv )*t00a + te = te + liq_vint*(cpice-cpliq)*t00a + te = te + wtot_vint*h00a_ice + endif case('liq') te = te + (latvap * wv_vint) - (latice * ice_vint) - case('wv') + if (vcoord .ne. vc_moist_pressure) then + ! add t00 and h00 terms + te = te + wv_vint*(cpliq-cpwv )*t00a + te = te + ice_vint*(cpliq-cpice)*t00a + te = te + wtot_vint*h00a + endif + case('vap') te = te - (latvap * liq_vint) - (latsub * ice_vint) + if(vcoord .ne. vc_moist_pressure) then + ! add t00 and h00 terms + te = te + liq_vint*(cpwv -cpliq)*t00a + te = te + ice_vint*(cpwv -cpice)*t00a + te = te + wtot_vint*h00a_vap + endif case default write(iulog, *) subname, ' enthalpy reference state not ', & 'supported: ', TRIM(enthalpy_reference_state) @@ -1812,4 +1837,566 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & deallocate(species_idx, species_liq_idx, species_ice_idx) end subroutine get_hydrostatic_energy_1hd + !=========================================================================== + + subroutine get_conserved_energy(moist_mixing_ratio, ktop, kbot & + , cp_or_cv, T, tracer, pdel_in & + , pdel, te & + , qini, liqini, iceini & + , phis & + , gph & + , U, V, W, rairv & + , flatent,latent,potential,kinetic,temce & + , refstate, vcoord, dycore_idx) + + use dycore, only: dycore_is + use cam_logfile, only: iulog + use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure + use air_composition, only: wv_idx + use physconst, only: rga, latvap, latice + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a, h00a_vap, h00a_ice + + ! arguments in: + ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry + logical , intent(in) :: moist_mixing_ratio + integer , intent(in) :: ktop, kbot + ! cp_or_cv: dry air heat capacity under constant pressure or + ! constant volume (depends on vcoord) + real(r8), intent(in) :: cp_or_cv(:,:) + real(r8), intent(in) :: T(:,:) + real(r8), intent(in) :: tracer(:,:,:) + ! pdel: pressure level thickness + real(r8), intent(in) :: pdel_in(:,:) !N.B. this should be g*\rho*dz for MPAS + + ! arguments out: + ! conserved total energy/enthalpy per unit mass + real(r8), intent(out) :: te (:,:) + ! pdel: layer mass + real(r8), intent(out) :: pdel(:,:) !N.B. this should be g*\rho*dz for MPAS + + ! arguments optional: + real(r8), intent(in), optional :: qini(:,:), liqini(:,:), iceini(:,:) + ! surface geopotential -- should be made mandatory arg + real(r8), intent(in), optional :: phis(:) + ! geopotential height, required for MPAS: te=u_m:=c_v*T+latent+gz+KE + ! dycore_is('MPAS') and gph not present -> stop + real(r8), intent(in), optional :: gph(:,:) + ! N.B. either PHIS or GPH must be present + ! horizontal winds --> add KE (should be made mandatory arguments) + real(r8), intent(in), optional :: U(:,:) + real(r8), intent(in), optional :: V(:,:) + ! vertical wind --> add to KE (non-hydrostatic) + real(r8), intent(in), optional :: W(:,:) + real(r8), intent(in), optional :: Rairv(:,:) + character(len=3),intent(in),optional :: refstate + integer, intent(in), optional :: vcoord ! vertical coordinate + ! dycore_idx: use dycore index for thermodynamic active species + logical, intent(in) , optional :: dycore_idx + real(r8), intent(out), optional :: flatent(:,:) + real(r8), intent(out), optional :: latent(:,:) + real(r8), intent(out), optional :: potential(:,:) + real(r8), intent(out), optional :: kinetic(:,:) + real(r8), intent(out), optional :: temce(:,:) ! Total Enthalpy Minus Conserved Energy + + ! Local variables + real(r8) :: qwv (SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qliq(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qice(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qtot(SIZE(tracer, 1),SIZE(tracer, 2)), latsub + real(r8) :: work(SIZE(tracer, 1),SIZE(tracer, 2)) + + integer :: ierr + integer :: kdx, idx, nkd, nid ! coord indices + integer :: qdx ! tracer index + integer :: wvidx ! water vapor index + integer, allocatable :: species_idx(:) + integer, allocatable :: species_liq_idx(:) + integer, allocatable :: species_ice_idx(:) + character(len=3) :: loc_refstate + character(len=*), parameter :: subname = 'get_conserved_energy' + + allocate(species_idx(thermodynamic_active_species_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_idx array') + end if + allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_liq_idx array') + end if + allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_ice_idx array') + end if + + nkd=SIZE(tracer, 2) + nid=SIZE(tracer, 1) + + if(present(refstate))then + loc_refstate=trim(refstate) + else + loc_refstate=trim(enthalpy_reference_state) + endif + + if (present(dycore_idx))then + if (dycore_idx) then + species_idx(:) = thermodynamic_active_species_idx_dycore(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + + if (moist_mixing_ratio) then + pdel = pdel_in*rga + else + pdel = pdel_in*rga + if (present(qini).and.present(liqini).and.present(iceini))then + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*(qini(:,:)+liqini(:,:)+iceini(:,:))*rga + else + do qdx = dry_air_species_num+1, thermodynamic_active_species_num + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx))*rga + end do + endif + end if + + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = T(idx,kdx)*cp_or_cv(idx, kdx) + end do + end do + + work(:,:)=0._r8 + if(present(phis))then + do kdx = ktop, kbot + do idx = 1, nid + work(idx,kdx) = phis(idx) + end do + end do + endif + if(dycore_is('MPAS')) then + if(.not.present(gph)) call endrun(subname//': conserved_energy function'// & + ' requires GPH in input for non-hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + work(idx,kdx) = work(idx,kdx) + gph(idx,kdx)/rga + end do + end do + endif + if (present(potential)) then + do kdx = ktop, kbot + do idx = 1, nid + potential(idx,kdx) = work(idx,kdx) + end do + end do + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + + if(present(qini).and.present(liqini).and.present(iceini))then + qwv (:,:)=qini (:,:) + qliq(:,:)=liqini(:,:) + qice(:,:)=iceini(:,:) + else + qwv (:,:) = tracer(:,:,wv_idx) + qliq(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_liq_num + qliq(:,:) = qliq(:,:) + tracer(:,:,species_liq_idx(qdx)) + enddo + qice(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_ice_num + qice(:,:) = qice(:,:) + tracer(:,:,species_ice_idx(qdx)) + enddo + endif + + latsub = latvap + latice + select case (TRIM(loc_refstate)) + case('ice') + work(:,:) = (latsub * qwv ) + (latice * qliq) + case('liq') + work(:,:) = (latvap * qwv ) - (latice * qice) + case('vap') + work(:,:) =-(latvap * qliq) - (latsub * qice) + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(loc_refstate) + call endrun(subname//': enthalpy reference state not supported') + end select + if (present(latent).or.present(flatent)) then + if (present(flatent)) then + do kdx = ktop, kbot + do idx = 1, nid + flatent(idx,kdx) = work(idx,kdx) + end do + end do + endif + if (present(latent)) then + do kdx = ktop, kbot + do idx = 1, nid + latent(idx,kdx) = work(idx,kdx) + end do + end do + endif + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + + ! add t00 and h00 terms + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + qtot(:,:) = qice(:,:) + qliq(:,:) + qwv (:,:) + select case (TRIM(loc_refstate)) + case('ice') + work(:,:) = qwv (:,:)*(cpice-cpwv )*t00a & + + qliq(:,:)*(cpice-cpliq)*t00a & + + qtot(:,:)*h00a_ice + case('liq') + work(:,:) = qwv (:,:)*(cpliq-cpwv )*t00a & + + qice(:,:)*(cpliq-cpice)*t00a & + + qtot(:,:)*h00a + case('vap') + work(:,:) = qliq(:,:)*(cpwv -cpliq)*t00a & + + qice(:,:)*(cpwv -cpice)*t00a & + + qtot(:,:)*h00a_vap + end select + if (present(latent)) then + do kdx = ktop, kbot + do idx = 1, nid + latent(idx,kdx) = latent(idx,kdx)+work(idx,kdx) + end do + end do + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + endif + endif + + if(present(U).and.present(V)) then + do kdx = ktop, kbot + do idx = 1, nid + work(idx,kdx) = .5_r8*(u(idx,kdx)**2+v(idx,kdx)**2) + enddo + enddo + if (present(kinetic)) then + do kdx = ktop, kbot + do idx = 1, nid + kinetic(idx,kdx)= work(idx,kdx) + end do + end do + else + do kdx = ktop, kbot + do idx = 1, nid + te(idx,kdx) = te(idx,kdx) + work(idx,kdx) + end do + end do + endif + endif + + if(present(temce)) then + if(dycore_is('MPAS'))then + if(.not.(present(rairv))) call endrun(subname//': TEMCE required but'// & + ' Rairv not provided in non-hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + temce(idx,kdx) = T(idx,kdx)*rairv(idx, kdx) + end do + end do + else + if(.not.(present(gph))) call endrun(subname//': TEMCE required but'// & + ' GPH not provided in hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + temce(idx,kdx) = gph(idx,kdx)/rga + end do + end do + endif + endif + + deallocate(species_idx, species_liq_idx, species_ice_idx) + + end subroutine get_conserved_energy + + !=========================================================================== + + subroutine inv_conserved_energy(moist_mixing_ratio & + , ktop, kbot & + , te, cp_or_cv, tracer, pdel_in & + , pdel, T & + , phis & + , gph & + , U, V, W & + , flatent,latent,potential,kinetic & + , refstate, vcoord, dycore_idx) + + use cam_logfile, only: iulog + use dycore, only: dycore_is + use dyn_tests_utils, only: vc_height, vc_moist_pressure, vc_dry_pressure + use air_composition, only: wv_idx + use physconst, only: rga, latvap, latice + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a, h00a_vap, h00a_ice + + ! arguments in: + ! note - if pdeldry passed to subroutine then tracer mixing ratio must be dry + logical , intent(in) :: moist_mixing_ratio + integer , intent(in) :: ktop, kbot + ! conserved energy/enthalpy + real(r8), intent(in) :: te(:,:) + ! cp_or_cv: dry air heat capacity under constant pressure or + ! constant volume (depends on vcoord) + real(r8), intent(in) :: cp_or_cv(:,:) + real(r8), intent(in) :: tracer(:,:,:) + ! pdel: pressure level thickness + real(r8), intent(in) :: pdel_in(:,:) !N.B. this should be g*\rho*dz for MPAS + + ! arguments out: + ! temperature + real(r8), intent(out) :: T(:,:) + ! pdel: layer mass + real(r8), intent(out) :: pdel(:,:) !N.B. this should be g*\rho*dz for MPAS + + ! arguments optional: + ! surface geopotential --> compute te=e_m:=c_p*T+latent+phis+KE (hydrostatic) + real(r8), intent(in), optional :: phis(:) + ! geopotential height --> compute te=u_m:=c_v*T+latent+gz+KE (MPAS) + ! should be =z_mid in output os subroutine geopotential_t + real(r8), intent(in), optional :: gph(:,:) + character(len=3),intent(in),optional :: refstate + integer, intent(in), optional :: vcoord ! vertical coordinate + !N.B. either PHIS or GPH must be present + ! dycore_idx: use dycore index for thermodynamic active species + logical, intent(in), optional :: dycore_idx + ! horizontal winds --> add KE (will be made mandatory arguments later) + real(r8), intent(in), optional :: U(:,:) + real(r8), intent(in), optional :: V(:,:) + ! vertical wind --> add to KE (MPAS) + real(r8), intent(in), optional :: W(:,:) + real(r8), intent(in), optional :: flatent(:,:) + real(r8), intent(in), optional :: latent(:,:) + real(r8), intent(in), optional :: potential(:,:) + real(r8), intent(in), optional :: kinetic(:,:) + + ! Local variables + real(r8) ::tetmp(SIZE(tracer, 1),SIZE(tracer, 2)) + real(r8) :: qwv (SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qliq(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qice(SIZE(tracer, 1),SIZE(tracer, 2)) & + ,qtot(SIZE(tracer, 1),SIZE(tracer, 2)), latsub + + integer :: ierr + integer :: kdx, idx, nkd, nid ! coord indices + integer :: qdx ! tracer index + integer :: wvidx ! water vapor index + integer, allocatable :: species_idx(:) + integer, allocatable :: species_liq_idx(:) + integer, allocatable :: species_ice_idx(:) + character(len=3) :: loc_refstate + character(len=*), parameter :: subname = 'get_conserved_energy' + + allocate(species_idx(thermodynamic_active_species_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_idx array') + end if + allocate(species_liq_idx(thermodynamic_active_species_liq_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_liq_idx array') + end if + allocate(species_ice_idx(thermodynamic_active_species_ice_num), stat=ierr) + if ( ierr /= 0 ) then + call endrun(subname//': allocation error for species_ice_idx array') + end if + + nkd=SIZE(tracer, 2) + nid=SIZE(tracer, 1) + + if(present(refstate))then + loc_refstate=trim(refstate) + else + loc_refstate=trim(enthalpy_reference_state) + endif + + if (present(dycore_idx))then + if (dycore_idx) then + species_idx(:) = thermodynamic_active_species_idx_dycore(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx_dycore(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx_dycore(:) + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + else + species_idx(:) = thermodynamic_active_species_idx(:) + species_liq_idx(:) = thermodynamic_active_species_liq_idx(:) + species_ice_idx(:) = thermodynamic_active_species_ice_idx(:) + end if + + if (moist_mixing_ratio) then + pdel = pdel_in*rga + else + pdel = pdel_in*rga + do qdx = dry_air_species_num+1, thermodynamic_active_species_num + pdel(:,:) = pdel(:,:) + pdel_in(:, :)*tracer(:,:,species_idx(qdx))*rga + end do + end if + + if(present(kinetic)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = te(idx,kdx) - kinetic(idx,kdx) + enddo + enddo + else if(present(U).and.present(V)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = te(idx,kdx) - .5_r8*(u(idx,kdx)**2+v(idx,kdx)**2) + enddo + enddo + else + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = te(idx,kdx) + end do + end do + endif + + if(present(potential)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - potential(idx,kdx) + end do + end do + else + if(present(phis))then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - phis(idx) + end do + end do + endif + if(dycore_is('MPAS')) then + if(.not.present(gph)) call endrun(subname//': conserved_energy function'// & + ' requires GPH in input for non-hydrostatic case') + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - gph(idx,kdx)/rga + end do + end do + endif + endif + + if (present(latent)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - latent(idx,kdx) + end do + end do + else + qwv (:,:) = tracer(:,:,wv_idx) + qliq(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_liq_num + qliq(:,:) = qliq(:,:) + tracer(:,:,species_liq_idx(qdx)) + enddo + qice(:,:) = 0._r8 + do qdx = 1, thermodynamic_active_species_ice_num + qice(:,:) = qice(:,:) + tracer(:,:,species_ice_idx(qdx)) + enddo + qtot(:,:) = qice(:,:) + qliq(:,:) + qwv (:,:) + if (present(flatent)) then + do kdx = ktop, kbot + do idx = 1, nid + tetmp(idx,kdx) = tetmp(idx,kdx) - flatent(idx,kdx) + end do + end do + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + ! add t00 and h00 terms + select case (TRIM(loc_refstate)) + case('ice') + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpice-cpwv )*t00a & + +qliq(:,:)*(cpice-cpliq)*t00a & + +qtot(:,:)*h00a_ice ) + case('liq') + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpliq-cpwv )*t00a & + +qice(:,:)*(cpliq-cpice)*t00a & + +qtot(:,:)*h00a ) + case('vap') + tetmp(:,:) = tetmp(:,:) -(qliq(:,:)*(cpwv -cpliq)*t00a & + +qice(:,:)*(cpwv -cpice)*t00a & + +qtot(:,:)*h00a_vap ) + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(loc_refstate) + call endrun(subname//': enthalpy reference state not supported') + end select + endif + endif + else + latsub = latvap + latice + select case (TRIM(loc_refstate)) + case('ice') + tetmp(:,:) = tetmp(:,:) - (latsub * qwv ) - (latice * qliq) + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpice-cpwv )*t00a & + +qliq(:,:)*(cpice-cpliq)*t00a & + +qtot(:,:)*h00a_ice ) + endif + endif + case('liq') + tetmp(:,:) = tetmp(:,:) - (latvap * qwv ) + (latice * qice) + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + tetmp(:,:) = tetmp(:,:) -(qwv (:,:)*(cpliq-cpwv )*t00a & + +qice(:,:)*(cpliq-cpice)*t00a & + +qtot(:,:)*h00a ) + endif + endif + case('vap') + tetmp(:,:) = tetmp(:,:) + (latvap * qliq) + (latsub * qice) + if(present(vcoord))then + if(vcoord.ne.vc_moist_pressure) then + tetmp(:,:) = tetmp(:,:) -(qliq(:,:)*(cpwv -cpliq)*t00a & + +qice(:,:)*(cpwv -cpice)*t00a & + +qtot(:,:)*h00a_vap ) + endif + endif + case default + write(iulog, *) subname, ' enthalpy reference state not ', & + 'supported: ', TRIM(loc_refstate) + call endrun(subname//': enthalpy reference state not supported') + end select + endif + endif + + do kdx = ktop, kbot + do idx = 1, nid + T(idx,kdx) = tetmp(idx,kdx)/cp_or_cv(idx, kdx) + end do + end do + + deallocate(species_idx, species_liq_idx, species_ice_idx) + + end subroutine inv_conserved_energy + +!------------------------------------------------------------------------------- end module cam_thermo From 31ae178bc878e6ddd60c46a6508f4ff566eac107 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 29 Sep 2025 12:00:41 +0200 Subject: [PATCH 19/78] udpated src/physics/cam/check_energy.F90 and removed src/physics/camnor_phys/physics/check_energy.F90 and src/physics/camnor_phys/physics/check_energy_chng.F90 --- src/physics/cam/check_energy.F90 | 294 +++- .../camnor_phys/physics/check_energy.F90 | 1178 ----------------- .../camnor_phys/physics/check_energy_chng.F90 | 426 ------ 3 files changed, 289 insertions(+), 1609 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/check_energy.F90 delete mode 100644 src/physics/camnor_phys/physics/check_energy_chng.F90 diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index d1d59e173f..7ffbacfb97 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -21,12 +21,12 @@ module check_energy !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver + use ppgrid, only: pcols, pver, begchunk, endchunk use spmd_utils, only: masterproc - use physconst, only: rga + use physconst, only: gravit, rga, latvap, latice, cpair, rair use air_composition, only: cpairv, cp_or_cv_dycore - use physics_types, only: physics_state + use physics_types, only: physics_state, physics_tend, physics_ptend, physics_ptend_init use constituents, only: cnst_get_ind, pcnst, cnst_name, cnst_get_type_byind use cam_logfile, only: iulog @@ -55,6 +55,8 @@ module check_energy public :: check_energy_cam_fix ! add heating rate required for global mean total energy conservation + public :: enthalpy_adjustment + ! Private module data logical :: print_energy_errors = .false. @@ -67,6 +69,7 @@ module check_energy real(r8) :: heat_glob ! global mean heating rate ! Physics buffer indices + integer, public :: teout_idx = 0 ! teout index in physics buffer integer, public :: dtcore_idx = 0 ! dtcore index in physics buffer integer, public :: dqcore_idx = 0 ! dqcore index in physics buffer @@ -793,9 +796,7 @@ subroutine check_energy_cam_chng(state, tend, name, nstep, ztodt, & if(.not. all(cpairv(:,:,:) == cpair)) then call endrun('check_energy_chng: cpairv is not allowed to vary when subcolumns are turned on') endif - local_cp_phys(:,:) = cpair - ! Note: cp_or_cv set above for pressure coordinate if (vc_dycore == ENERGY_FORMULA_DYCORE_MPAS) then ! compute cv if vertical coordinate is height: cv = cp - R @@ -920,4 +921,287 @@ subroutine check_energy_cam_fix(state, ptend, nstep, eshflx) ) end subroutine check_energy_cam_fix + +!=============================================================================== + + subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, itim_old,& + qini,totliqini,toticeini,tend) + + use camsrfexch, only: cam_in_t, cam_out_t, get_prec_vars + use physics_buffer, only: pbuf_get_index, physics_buffer_desc, pbuf_set_field, pbuf_get_field + use cam_abortutils, only: endrun + use air_composition, only: hliq_idx, hice_idx, fliq_idx, fice_idx, num_enthalpy_vars + use air_composition, only: cpairv, cp_or_cv_dycore, te_init + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx + use physconst, only: cpliq, cpice, cpwv, tmelt + use air_composition, only: t00a, h00a + use physconst, only: rga, latvap, latice + use dyn_tests_utils, only: vc_dycore + use cam_thermo, only: get_hydrostatic_energy + use physics_types, only: physics_dme_adjust, dyn_te_idx + use cam_thermo, only: cam_thermo_water_update + use cam_history, only: outfld + use cam_budget, only: thermo_budget_history + use time_manager, only: get_nstep + + ! Arguments + integer, intent(in) :: ncol, lchnk + type(physics_state), intent(inout) :: state + type(cam_in_t), intent(in ) :: cam_in + type(cam_out_t), intent(inout) :: cam_out + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: ztodt + integer, intent(in) :: itim_old + real(r8), dimension(pcols,pver), intent(in) :: qini, totliqini, toticeini + type(physics_tend ) , intent(inout) :: tend + + ! Local variables + integer:: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx + real(r8), dimension(:,:), pointer :: enthalpy_prec_bc + real(r8), dimension(pcols,num_enthalpy_vars) :: enthalpy_prec_ac + real(r8), dimension(pcols) :: fliq_tot, fice_tot + + integer:: dp_ntprp_idx, dp_ntsnp_idx + real(r8), dimension(:,:), pointer :: dp_ntprp, dp_ntsnp + integer:: qrain_mg_idx,qsnow_mg_idx + real(r8), dimension(:,:), pointer :: qrain_mg, qsnow_mg + + real(r8), dimension(pcols) :: te , se , po , ke + real(r8), dimension(pcols) :: te_endphys, se_endphys, po_endphys, ke_endphys + real(r8), dimension(pcols) :: te_dme , se_dme , po_dme , ke_dme + real(r8), dimension(pcols) :: te_enth_fix , se_enth_fix , po_enth_fix , ke_enth_fix + real(r8), dimension(pcols) :: fct_bc_tot, fct_ac_tot + real(r8), dimension(pcols) :: enthalpy_heating_fix_bc, enthalpy_heating_fix_ac + + real(r8), dimension(pcols) :: dEdt_physics + real(r8), dimension(pcols) :: dEdt_dme + real(r8), dimension(pcols) :: dEdt_cpdycore + real(r8), dimension(pcols) :: dEdt_enth_fix, dEdt_efix + real(r8), dimension(pcols) :: constant_latent_heat_surface !xxx diagnostics + real(r8), dimension(pcols) :: variable_latent_heat_surface_cpice_term !xxx diagnostics + real(r8), dimension(pcols) :: variable_latent_heat_surface_ls_term !xxx diagnostics + real(r8), dimension(pcols) :: variable_latent_heat_surface_lf_term !xxx diagnostics + real(r8), dimension(pcols) :: enthalpy_flux_atm, enthalpy_flux_ocn !tht + real(r8), dimension(pcols,pver) :: tmp_t, pdel_rf, qinp, totliqinp, toticeinp + real(r8), dimension(pcols) :: zero, dsema, dcp_heat, iedme + real(r8), dimension(pcols) :: water_flux_bc, water_flux_ac, enthalpy_flux_bc, enthalpy_flux_ac + real(r8), dimension(pcols) :: eflx_out + real(r8), dimension(pcols) :: mflx_out + real(r8), dimension(pcols) :: hevap_atm, hevap_ocn + real(r8), dimension(pcols) :: tevp, tprc, nocnfrc + + real(r8), dimension(pcols,pver) :: rnsrc_pbc, snsrc_pbc + real(r8), dimension(pcols,pver) :: rnsrc_pac, snsrc_pac + real(r8), dimension(pcols,pver) :: rnsrc_tot, snsrc_tot + real(r8), dimension(pcols) :: watrerr,rainerr,snowerr + + integer nstep, ixq, m, m_cnst + real(r8), dimension(pcols,pver) :: fct_bc, fct_ac + real(r8), dimension(pcols,pver) :: scale_cpdry_cpdycore, ttend_hfix + + real(r8), parameter :: eps=1.E-10_r8 + + logical, parameter :: debug_enthalpy=.false. + logical, parameter :: use_nonlinear_evap_fraction=.false. + + integer :: i, k + real(r8):: tot, wgt_bc, wgt_ac + !----------------------------------------------------------------------------- + + nstep = get_nstep() + zero(:)=0._r8 + + ! scale temperature for consistency with dycore (tht: partial adj. after cp update done implicitly in dme) + do k = 1, pver + do i = 1, ncol + scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) + state%T (i,k) = state%temp_ini(i,k)+scale_cpdry_cpdycore(i,k)*(state%T(i,k)- state%temp_ini(i,k)) + tend%dtdt(i,k) = scale_cpdry_cpdycore(i,k)*tend%dtdt(i,k) + end do + end do + + !------------------------------------------------------------------------------------------- + ! from this point onwards computation consistent with variable latent heat total energy formula + ! Equation 78 in https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2022MS003117 + !------------------------------------------------------------------------------------------- + + !=== start computation of material enthalpy fluxes === + ! evaporation enthalpy flux + enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP' , errcode=i) + if (enthalpy_evop_idx==0) then + call endrun("pbufs for enthalpy evap flux not allocated") + end if + ! using merged quantities, for atmospheric mat.enthalpy flux (used in check_energy) + if (minval(cam_in%ts(:ncol)).gt.0._r8) then + hevap_atm(:ncol) = cam_in%cflx (:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm + !tht: add non-linear terms? using evap_ocn, sst + if (use_nonlinear_evap_fraction) then + nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) + where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large + hevap_atm(:ncol)= hevap_atm(:ncol) & + + cpwv & + *(1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & + *(cam_in%cflx(:ncol,1)-cam_in%evap_ocn(:ncol)) & + *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) + tevp (:ncol)= cam_in%ts(:ncol) & + + (1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & + *(1._r8-cam_in%evap_ocn(:ncol)/cam_in%cflx(:ncol,1))& + *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) + elsewhere + tevp (:ncol)= cam_in%ts(:ncol) + endwhere + else + tevp (:ncol)= cam_in%ts(:ncol) + endif + !tht: for ocean-only mat.enthalpy flux (passed to ocean) + hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) + else ! not great but better than zeros + hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm + tevp (:ncol)= state%t(:ncol,pver) + hevap_ocn (:ncol)= hevap_atm(:ncol) ! out of ocn + endif + call pbuf_set_field(pbuf, enthalpy_evop_idx, hevap_ocn) + + if (use_nonlinear_evap_fraction) then + if(maxval(tevp(:ncol)).gt.350._r8 .or. minval(tevp(:ncol)).lt.150._r8)then + i=maxloc(tevp(:ncol),1) + k=minloc(tevp(:ncol),1) + print*,'Bad Tevap' + print*,'min ts=',minval(cam_in%ts(:ncol)),maxval(cam_in%ts(:ncol)) + print*,'state%t',minval(state%t(:ncol,pver)),maxval(state%t(:ncol,pver)) + print*,'tevp =',tevp(k),tevp(i) + print*,'ts =',cam_in%ts (k),cam_in%ts (i) + print*,'sst =',cam_in%sst(k),cam_in%sst(i) + print*,'cflx =',cam_in%cflx(k,1),cam_in%cflx(i,1) + print*,'evop =',cam_in%evap_ocn(k),cam_in%evap_ocn(i) + print*,'corr =',(1._r8-nocnfrc(k))/nocnfrc(k) *(1._r8-cam_in%evap_ocn(k)/cam_in%cflx(k,1)) *(cam_in%ts(k)-cam_in%sst(k)) & + ,(1._r8-nocnfrc(i))/nocnfrc(i) *(1._r8-cam_in%evap_ocn(i)/cam_in%cflx(i,1)) *(cam_in%ts(i)-cam_in%sst(i)) + call endrun('stopping in enthalpy_adjustment') + endif + endif + + !------------------------------------------------------------------ + ! compute precipitation fluxes and set associated physics buffers + !------------------------------------------------------------------ + enthalpy_prec_bc_idx = pbuf_get_index('ENTHALPY_PREC_BC', errcode=i) + enthalpy_prec_ac_idx = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) + if (enthalpy_prec_bc_idx==0.or.enthalpy_prec_ac_idx==0) then + call endrun("pbufs for enthalpy precip flux not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) + call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot) + ! fliq_tot holds liquid precipitation from tphysbc and tphysac; idem for ice + enthalpy_prec_ac(:ncol,fice_idx) = fice_tot(:ncol)-enthalpy_prec_bc(:ncol,fice_idx) + enthalpy_prec_ac(:ncol,fliq_idx) = fliq_tot(:ncol)-enthalpy_prec_bc(:ncol,fliq_idx) + + ! compute precipitation enthalpy fluxes from tphysbc + tprc (:ncol) = cam_out%tbot(:ncol) + !tht: correct for reference T of latent heats (liquid reference state) + enthalpy_prec_ac(:ncol,hice_idx) = -enthalpy_prec_ac(:ncol,fice_idx)*(cpice*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) + enthalpy_prec_ac(:ncol,hliq_idx) = -enthalpy_prec_ac(:ncol,fliq_idx)*(cpliq*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) + call pbuf_set_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) + + ! compute total enthalpy flux + enthalpy_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) + enthalpy_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + +hevap_atm (:ncol) + water_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,fliq_idx)+enthalpy_prec_bc(:ncol,fice_idx) + water_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,fliq_idx)+enthalpy_prec_ac(:ncol,fice_idx) & + -cam_in%cflx(:ncol,1) + enthalpy_flux_atm(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & + +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + +hevap_atm (:ncol) + enthalpy_flux_ocn(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & + +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + +hevap_ocn (:ncol) + enthalpy_flux_ocn(:ncol) = cam_in%ocnfrac(:ncol)*enthalpy_flux_ocn(:ncol) + + if (debug_enthalpy) then + call outfld("enth_prec_ac_hice" , enthalpy_prec_ac(:,hice_idx) , pcols ,lchnk ) + call outfld("enth_prec_ac_hliq" , enthalpy_prec_ac(:,hliq_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_hice" , enthalpy_prec_bc(:,hice_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_hliq" , enthalpy_prec_bc(:,hliq_idx) , pcols ,lchnk ) + call outfld("enth_prec_ac_fice" , enthalpy_prec_ac(:,fice_idx) , pcols ,lchnk ) + call outfld("enth_prec_ac_fliq" , enthalpy_prec_ac(:,fliq_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_fice" , enthalpy_prec_bc(:,fice_idx) , pcols ,lchnk ) + call outfld("enth_prec_bc_fliq" , enthalpy_prec_bc(:,fliq_idx) , pcols ,lchnk ) + call outfld("enth_hevap_atm" , hevap_atm (:) , pcols ,lchnk ) + call outfld("enth_hevap_ocn" , hevap_ocn (:) , pcols ,lchnk ) + endif + !=== end computation of material enthalpy fluxes === + + !+++ diags + ! compute total energy after physics using equation 78 + call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & + state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & + state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& + vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & + te = te_endphys(:ncol), se=se_endphys(:ncol), po=po_endphys(:ncol), ke=ke_endphys(:ncol)) + ! the column integrated total energy change should match accumlated te_tnd: + ! dEdt_physics=te_tnd + call outfld ('te_tnd',tend%te_tnd , pcols, lchnk) + dEdt_physics(:ncol) = (te_endphys(:ncol)-te_init(:ncol,1,lchnk))/ztodt + call outfld ('dEdt_physics', dEdt_physics, pcols, lchnk) + !--- sgaid + + !+ get pbuf fields for precip + dp_ntprp_idx = pbuf_get_index('dp_ntprp',errcode=i) !prec production from ZM + dp_ntsnp_idx = pbuf_get_index('dp_ntsnp',errcode=i) !snow production from ZM + call pbuf_get_field(pbuf, dp_ntprp_idx , dp_ntprp) + call pbuf_get_field(pbuf, dp_ntsnp_idx , dp_ntsnp) + qrain_mg_idx = pbuf_get_index('qrain_mg',errcode=i) !rain production from MG + qsnow_mg_idx = pbuf_get_index('qsnow_mg',errcode=i) !snow production from MG + call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) + call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) + rnsrc_pbc(:ncol,:) = dp_ntprp(:ncol,:)-dp_ntsnp(:ncol,:) + snsrc_pbc(:ncol,:) = dp_ntsnp(:ncol,:) + rnsrc_pac(:ncol,:) = qrain_mg(:ncol,:) + snsrc_pac(:ncol,:) = qsnow_mg(:ncol,:) + rnsrc_tot(:ncol,:) = rnsrc_pbc(:ncol,:)+rnsrc_pac(:ncol,:) + snsrc_tot(:ncol,:) = snsrc_pbc(:ncol,:)+snsrc_pac(:ncol,:) + !- picerp rof sdleif fubp teg + + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt & + , dme_energy_adjust=.true.,step='bc+ac' & + , ntrnprd=rnsrc_tot*ztodt & + , ntsnprd=snsrc_tot*ztodt & + , tevap=tevp, tprec=tprc & + , mflx=water_flux_bc+water_flux_ac & + , eflx=enthalpy_flux_atm & + , mflx_out=mflx_out & + , eflx_out=eflx_out & + , ent_tnd=dsema & + , pdel_rf=pdel_rf ) + + call outfld('IETEND_DME', dsema , pcols, lchnk) + call outfld('EFLX' , enthalpy_flux_atm , pcols, lchnk) + call outfld('MFLX' , water_flux_bc+water_flux_ac , pcols, lchnk) + + ! compute and store new column-integrated enthalpy and associated tendency + call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & + state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & + state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& + vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & + te = te(:ncol), se=se(:ncol), po=po(:ncol), ke=ke(:ncol)) + + ! Save final energy for use with global fixer in next timestep -- note sign conventions, and coupling-dependent options + ! subtract from te the h flux (sign: into atm) that is *not* passed to surface components + ! and also remove enthalpy of run-off (if added to BLOM) + state%te_cur(:ncol,dyn_te_idx) = te(:ncol) & + - ztodt*(enthalpy_flux_atm(:ncol) - enthalpy_flux_ocn(:ncol) - cam_in%hrof(:ncol)) + tend%te_tnd(:ncol) = tend%te_tnd(:ncol) + (enthalpy_flux_ocn(:ncol) + cam_in%hrof(:ncol)) ! B. with run-off + + if (thermo_budget_history) then + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + endif + + call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) + ! the amount of total energy we need energy fixer to fix (associated with enthalpy flux) + dEdt_efix(:ncol) = (state%te_cur(:ncol,dyn_te_idx)-te (:ncol))/ztodt + call outfld("dEdt_efix_physics" , dEdt_efix , pcols ,lchnk ) + + end subroutine enthalpy_adjustment + end module check_energy diff --git a/src/physics/camnor_phys/physics/check_energy.F90 b/src/physics/camnor_phys/physics/check_energy.F90 deleted file mode 100644 index e25e54b00b..0000000000 --- a/src/physics/camnor_phys/physics/check_energy.F90 +++ /dev/null @@ -1,1178 +0,0 @@ - -module check_energy - -!--------------------------------------------------------------------------------- -! Purpose: -! -! Module to check -! 1. vertically integrated total energy and water conservation for each -! column within the physical parameterizations -! -! 2. global mean total energy conservation between the physics output state -! and the input state on the next time step. -! -! 3. add a globally uniform heating term to account for any change of total energy in 2. -! -! Author: Byron Boville Oct 31, 2002 -! -! Modifications: -! 03.03.29 Boville Add global energy check and fixer. -! -!--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, begchunk, endchunk - use spmd_utils, only: masterproc - - use gmean_mod, only: gmean - use physconst, only: gravit, rga, latvap, latice, cpair, rair - use air_composition, only: cpairv, cp_or_cv_dycore - use physics_types, only: physics_state, physics_tend, physics_ptend, physics_ptend_init - use constituents, only: cnst_get_ind, pcnst, cnst_name, cnst_get_type_byind - use time_manager, only: is_first_step - use cam_logfile, only: iulog - - implicit none - private - - ! Public types: - public check_tracers_data - - ! Public methods - public :: check_energy_readnl ! read namelist values - public :: check_energy_register ! register fields in physics buffer - public :: check_energy_get_integrals ! get energy integrals computed in check_energy_gmean - public :: check_energy_init ! initialization of module - public :: check_energy_timestep_init ! timestep initialization of energy integrals and cumulative boundary fluxes - public :: check_energy_cam_chng ! check changes in integrals against cumulative boundary fluxes - public :: check_energy_gmean ! global means of physics input and output total energy - public :: check_energy_cam_fix ! add heating rate required for global mean total energy conservation - public :: check_tracers_init ! initialize tracer integrals and cumulative boundary fluxes - public :: check_tracers_chng ! check changes in integrals against cumulative boundary fluxes - public :: tot_energy_phys ! calculate and output total energy and axial angular momentum diagnostics - - public :: enthalpy_adjustment !tht - - ! Private module data - logical :: print_energy_errors = .false. - - real(r8) :: teout_glob ! global mean energy of output state - real(r8) :: teinp_glob ! global mean energy of input state - real(r8) :: tedif_glob ! global mean energy difference - real(r8) :: psurf_glob ! global mean surface pressure - real(r8) :: ptopb_glob ! global mean top boundary pressure - real(r8) :: heat_glob ! global mean heating rate - - ! Physics buffer indices - - integer, public :: teout_idx = 0 ! teout index in physics buffer - integer, public :: dtcore_idx = 0 ! dtcore index in physics buffer - integer, public :: dqcore_idx = 0 ! dqcore index in physics buffer - integer, public :: ducore_idx = 0 ! ducore index in physics buffer - integer, public :: dvcore_idx = 0 ! dvcore index in physics buffer - - type check_tracers_data - real(r8) :: tracer(pcols,pcnst) ! initial vertically integrated total (kinetic + static) energy - real(r8) :: tracer_tnd(pcols,pcnst) ! cumulative boundary flux of total energy - integer :: count(pcnst) ! count of values with significant imbalances - end type check_tracers_data - - -!=============================================================================== -contains -!=============================================================================== - -subroutine check_energy_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_logical - use cam_abortutils, only: endrun - - ! update the CCPP-ized namelist option - use check_energy_chng, only: check_energy_chng_init - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: sub = 'check_energy_readnl' - - namelist /check_energy_nl/ print_energy_errors - !----------------------------------------------------------------------------- - - ! Read namelist - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'check_energy_nl', status=ierr) - if (ierr == 0) then - read(unitn, check_energy_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub//': FATAL: reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - call mpi_bcast(print_energy_errors, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: print_energy_errors") - - if (masterproc) then - write(iulog,*) 'check_energy options:' - write(iulog,*) ' print_energy_errors =', print_energy_errors - end if - - ! update the CCPP-ized namelist option - call check_energy_chng_init(print_energy_errors_in=print_energy_errors) - -end subroutine check_energy_readnl - -!=============================================================================== - - subroutine check_energy_register() -! -! Register fields in the physics buffer. -! -!----------------------------------------------------------------------- - - use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls - use physics_buffer, only : pbuf_register_subcol - use subcol_utils, only : is_subcol_on - -!----------------------------------------------------------------------- - -! Request physics buffer space for fields that persist across timesteps. - - call pbuf_add_field('TEOUT', 'global',dtype_r8 , (/pcols,dyn_time_lvls/), teout_idx) - call pbuf_add_field('DTCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),dtcore_idx) - ! DQCORE refers to dycore tendency of water vapor - call pbuf_add_field('DQCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),dqcore_idx) - call pbuf_add_field('DUCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),ducore_idx) - call pbuf_add_field('DVCORE','global',dtype_r8, (/pcols,pver,dyn_time_lvls/),dvcore_idx) - if(is_subcol_on()) then - call pbuf_register_subcol('TEOUT', 'phys_register', teout_idx) - call pbuf_register_subcol('DTCORE', 'phys_register', dtcore_idx) - call pbuf_register_subcol('DQCORE', 'phys_register', dqcore_idx) - call pbuf_register_subcol('DUCORE', 'phys_register', ducore_idx) - call pbuf_register_subcol('DVCORE', 'phys_register', dvcore_idx) - end if - - end subroutine check_energy_register - - - subroutine check_energy_get_integrals(tedif_glob_out, heat_glob_out) - -!----------------------------------------------------------------------- -! Purpose: Return energy integrals -!----------------------------------------------------------------------- - - real(r8), intent(out), optional :: tedif_glob_out - real(r8), intent(out), optional :: heat_glob_out - - if ( present(tedif_glob_out) ) then - tedif_glob_out = tedif_glob - endif - - if ( present(heat_glob_out) ) then - heat_glob_out = heat_glob - endif - - end subroutine check_energy_get_integrals -!================================================================================================ - - subroutine check_energy_init() -! -! Initialize the energy conservation module -! -!----------------------------------------------------------------------- - use cam_history, only: addfld, add_default, horiz_only - use phys_control, only: phys_getopts - - implicit none - - logical :: history_budget, history_waccm - integer :: history_budget_histfile_num ! output history file number for budget fields - -!----------------------------------------------------------------------- - - call phys_getopts( history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num, & - history_waccm_out = history_waccm ) - -! register history variables - call addfld('TEINP', horiz_only, 'A', 'J/m2', 'Total energy of physics input') - call addfld('TEOUT', horiz_only, 'A', 'J/m2', 'Total energy of physics output') - call addfld('TEFIX', horiz_only, 'A', 'J/m2', 'Total energy after fixer') - call addfld('EFIX', horiz_only, 'A', 'W/m2', 'Effective sensible heat flux due to energy fixer') - call addfld('DTCORE', (/ 'lev' /), 'A', 'K/s' , 'T tendency due to dynamical core') - call addfld('DQCORE', (/ 'lev' /), 'A', 'kg/kg/s' , 'Water vapor tendency due to dynamical core') - - if ( history_budget ) then - call add_default ('DTCORE', history_budget_histfile_num, ' ') - end if - if ( history_waccm ) then - call add_default ('DTCORE', 1, ' ') - end if - - end subroutine check_energy_init - -!=============================================================================== - subroutine check_energy_timestep_init(state, tend, pbuf, col_type) - use physics_buffer, only: physics_buffer_desc, pbuf_set_field - use cam_abortutils, only: endrun - use dyn_tests_utils, only: vc_physics, vc_dycore - use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS - use physics_types, only: phys_te_idx, dyn_te_idx - - ! CCPP-ized subroutine - use check_energy_chng, only: check_energy_chng_timestep_init - - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) - integer, optional :: col_type ! Flag indicating whether using grid or subcolumns - - real(r8) :: local_cp_phys(state%psetcols,pver) - real(r8) :: local_cp_or_cv_dycore(state%psetcols,pver) - real(r8) :: teout(state%ncol) ! dummy teout argument - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - character(len=512) :: errmsg - integer :: errflg - - lchnk = state%lchnk - ncol = state%ncol - - ! The code below is split into not-subcolumns and subcolumns code, as there is different handling of the - ! cp passed into the hydrostatic energy call. CAM-SIMA does not support subcolumns, so we keep this special - ! handling inside this CAM interface. (hplin, 9/9/24) - - if(state%psetcols == pcols) then - ! No subcolumns - local_cp_phys(:ncol,:) = cpairv(:ncol,:,lchnk) - local_cp_or_cv_dycore(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) - else if (state%psetcols > pcols) then - ! Subcolumns code - ! Subcolumns specific error handling - if(.not. all(cpairv(:,:,lchnk) == cpair)) then - call endrun('check_energy_timestep_init: cpairv is not allowed to vary when subcolumns are turned on') - endif - - local_cp_phys(1:ncol,:) = cpair - - if (vc_dycore == ENERGY_FORMULA_DYCORE_MPAS) then - ! MPAS specific hydrostatic energy computation (internal energy) - local_cp_or_cv_dycore(:ncol,:) = cpair-rair - else if(vc_dycore == ENERGY_FORMULA_DYCORE_SE) then - ! SE specific hydrostatic energy (enthalpy) - local_cp_or_cv_dycore(:ncol,:) = cpair - else - ! cp_or_cv is not used in the underlying subroutine, zero it out to be sure - local_cp_or_cv_dycore(:ncol,:) = 0.0_r8 - endif - end if - - ! Call CCPP-ized underlying subroutine. - call check_energy_chng_timestep_init( & - ncol = ncol, & - pver = pver, & - pcnst = pcnst, & - is_first_timestep = is_first_step(), & - q = state%q(1:ncol,1:pver,1:pcnst), & - pdel = state%pdel(1:ncol,1:pver), & - u = state%u(1:ncol,1:pver), & - v = state%v(1:ncol,1:pver), & - T = state%T(1:ncol,1:pver), & - pintdry = state%pintdry(1:ncol,1:pver), & - phis = state%phis(1:ncol), & - zm = state%zm(1:ncol,:), & - cp_phys = local_cp_phys(1:ncol,:), & - cp_or_cv_dycore = local_cp_or_cv_dycore(1:ncol,:), & - te_ini_phys = state%te_ini(1:ncol,phys_te_idx), & - te_ini_dyn = state%te_ini(1:ncol,dyn_te_idx), & - tw_ini = state%tw_ini(1:ncol), & - te_cur_phys = state%te_cur(1:ncol,phys_te_idx), & - te_cur_dyn = state%te_cur(1:ncol,dyn_te_idx), & - tw_cur = state%tw_cur(1:ncol), & - tend_te_tnd = tend%te_tnd(1:ncol), & - tend_tw_tnd = tend%tw_tnd(1:ncol), & - temp_ini = state%temp_ini(:ncol,:), & - z_ini = state%z_ini(:ncol,:), & - count = state%count, & - teout = teout(1:ncol), & ! dummy argument - actual teout written to pbuf directly below - energy_formula_physics = vc_physics, & - energy_formula_dycore = vc_dycore, & - errmsg = errmsg, & - errflg = errflg & - ) - - ! initialize physics buffer - if (is_first_step()) then - call pbuf_set_field(pbuf, teout_idx, state%te_ini(:,dyn_te_idx), col_type=col_type) - end if - - end subroutine check_energy_timestep_init - - - subroutine check_energy_cam_chng(state, tend, name, nstep, ztodt, & - flx_vap, flx_cnd, flx_ice, flx_sen) - use dyn_tests_utils, only: vc_physics, vc_dycore - use cam_abortutils, only: endrun - use physics_types, only: phys_te_idx, dyn_te_idx - use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS - use check_energy_chng, only: check_energy_chng_run - - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - character*(*),intent(in) :: name ! parameterization name for fluxes - integer , intent(in) :: nstep ! current timestep number - real(r8), intent(in) :: ztodt ! physics timestep (s) - real(r8), intent(in) :: flx_vap(:) ! (pcols) - boundary flux of vapor (kg/m2/s) - real(r8), intent(in) :: flx_cnd(:) ! (pcols) - boundary flux of lwe liquid+ice (m/s) - real(r8), intent(in) :: flx_ice(:) ! (pcols) - boundary flux of lwe ice (m/s) - real(r8), intent(in) :: flx_sen(:) ! (pcols) - boundary flux of sensible heat (W/m2) - - real(r8) :: local_cp_phys(state%psetcols,pver) - real(r8) :: local_cp_or_cv_dycore(state%psetcols,pver) - real(r8) :: scaling_dycore(state%ncol,pver) - character(len=512) :: errmsg - integer :: errflg - - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - lchnk = state%lchnk - ncol = state%ncol - - if(state%psetcols == pcols) then - ! No subcolumns - local_cp_phys(:ncol,:) = cpairv(:ncol,:,lchnk) - - ! Only if using MPAS or SE energy formula cp_or_cv_dycore is nonzero. - if(vc_dycore == ENERGY_FORMULA_DYCORE_MPAS .or. vc_dycore == ENERGY_FORMULA_DYCORE_SE) then - local_cp_or_cv_dycore(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) - - scaling_dycore(:ncol,:) = cpairv(:ncol,:,lchnk)/local_cp_or_cv_dycore(:ncol,:) ! cp/cv scaling - endif - else if(state%psetcols > pcols) then - ! Subcolumns - if(.not. all(cpairv(:,:,:) == cpair)) then - call endrun('check_energy_chng: cpairv is not allowed to vary when subcolumns are turned on') - endif - local_cp_phys(:,:) = cpair - ! Note: cp_or_cv set above for pressure coordinate - if (vc_dycore == ENERGY_FORMULA_DYCORE_MPAS) then - ! compute cv if vertical coordinate is height: cv = cp - R - local_cp_or_cv_dycore(:ncol,:) = cpair-rair - scaling_dycore(:ncol,:) = cpairv(:ncol,:,lchnk)/local_cp_or_cv_dycore(:ncol,:) ! cp/cv scaling - else if (vc_dycore == ENERGY_FORMULA_DYCORE_SE) then - ! SE specific hydrostatic energy - local_cp_or_cv_dycore(:ncol,:) = cpair - scaling_dycore(:ncol,:) = 1.0_r8 - else - ! Moist pressure... use phys formula, cp_or_cv_dycore is unused. Reset for safety - local_cp_or_cv_dycore(:ncol,:) = 0.0_r8 - scaling_dycore(:ncol,:) = 0.0_r8 - end if - endif - - ! Call CCPP-ized underlying subroutine. - call check_energy_chng_run(nstep,lchnk,masterproc, & - ncol = ncol, & - pver = pver, & - pcnst = pcnst, & - iulog = iulog, & - q = state%q(1:ncol,1:pver,1:pcnst), & - pdel = state%pdel(1:ncol,1:pver), & - u = state%u(1:ncol,1:pver), & - v = state%v(1:ncol,1:pver), & - T = state%T(1:ncol,1:pver), & - pintdry = state%pintdry(1:ncol,1:pver), & - phis = state%phis(1:ncol), & - zm = state%zm(1:ncol,:), & - cp_phys = local_cp_phys(1:ncol,:), & - cp_or_cv_dycore = local_cp_or_cv_dycore(1:ncol,:), & - scaling_dycore = scaling_dycore(1:ncol,:), & - te_cur_phys = state%te_cur(1:ncol,phys_te_idx), & - te_cur_dyn = state%te_cur(1:ncol,dyn_te_idx), & - tw_cur = state%tw_cur(1:ncol), & - tend_te_tnd = tend%te_tnd(1:ncol), & - tend_tw_tnd = tend%tw_tnd(1:ncol), & - temp_ini = state%temp_ini(:ncol,:), & - z_ini = state%z_ini(:ncol,:), & - count = state%count, & - ztodt = ztodt, & - latice = latice, & - latvap = latvap, & - energy_formula_physics = vc_physics, & - energy_formula_dycore = vc_dycore, & - name = name, & - flx_vap = flx_vap, & - flx_cnd = flx_cnd, & - flx_ice = flx_ice, & - flx_sen = flx_sen, & - errmsg = errmsg, & - errflg = errflg & - ) - - end subroutine check_energy_cam_chng - - subroutine check_energy_gmean(state, pbuf2d, dtime, nstep) - - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_chunk - use physics_types, only: dyn_te_idx - - type(physics_state), intent(in), dimension(begchunk:endchunk) :: state - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - real(r8), intent(in) :: dtime ! physics time step - integer , intent(in) :: nstep ! current timestep number - - integer :: ncol ! number of active columns - integer :: lchnk ! chunk index - - real(r8) :: te(pcols,begchunk:endchunk,4) - ! total energy of input/output states (copy) - real(r8) :: te_glob(4) ! global means of total energy - real(r8), pointer :: teout(:) - - ! Copy total energy out of input and output states - do lchnk = begchunk, endchunk - ncol = state(lchnk)%ncol - ! input energy using dynamical core energy formula - te(:ncol,lchnk,1) = state(lchnk)%te_ini(:ncol,dyn_te_idx) - ! output energy - call pbuf_get_field(pbuf_get_chunk(pbuf2d,lchnk),teout_idx, teout) - - te(:ncol,lchnk,2) = teout(1:ncol) - ! surface pressure for heating rate - te(:ncol,lchnk,3) = state(lchnk)%pint(:ncol,pver+1) - ! model top pressure for heating rate (not constant for z-based vertical coordinate!) - te(:ncol,lchnk,4) = state(lchnk)%pint(:ncol,1) - end do - - ! Compute global means of input and output energies and of - ! surface pressure for heating rate (assume uniform ptop) - call gmean(te, te_glob, 4) - - if (begchunk .le. endchunk) then - teinp_glob = te_glob(1) - teout_glob = te_glob(2) - psurf_glob = te_glob(3) - ptopb_glob = te_glob(4) - - ! Global mean total energy difference - tedif_glob = teinp_glob - teout_glob - heat_glob = -tedif_glob/dtime * gravit / (psurf_glob - ptopb_glob) - if (masterproc) then - write(iulog,'(1x,a9,1x,i8,5(1x,e25.17))') "nstep, te", nstep, teinp_glob, teout_glob, & - heat_glob, psurf_glob, ptopb_glob - end if - else - heat_glob = 0._r8 - end if ! (begchunk .le. endchunk) - - end subroutine check_energy_gmean - -!=============================================================================== - subroutine check_energy_cam_fix(state, ptend, nstep, eshflx) - ! Add heating rate required for global mean total energy conservation - - ! SCAM support - use scamMod, only: single_column, use_camiop, heat_glob_scm - use cam_history, only: write_camiop - use cam_history, only: outfld - - ! CCPP-ized subroutine - use check_energy_fix, only: check_energy_fix_run - - type(physics_state), intent(in) :: state - type(physics_ptend), intent(out) :: ptend - - integer , intent(in) :: nstep ! time step number - real(r8), intent(out) :: eshflx(pcols) ! effective sensible heat flux - - integer :: ncol ! number of atmospheric columns in chunk - integer :: lchnk ! chunk number - real(r8) :: heat_out(pcols) - character(len=64) :: dummy_scheme_name ! dummy scheme name for CCPP-ized scheme - - integer :: errflg - character(len=512) :: errmsg - - lchnk = state%lchnk - ncol = state%ncol - - call physics_ptend_init(ptend, state%psetcols, 'chkenergyfix', ls=.true.) - -#if ( defined OFFLINE_DYN ) - ! disable the energy fix for offline driver - heat_glob = 0._r8 -#endif - - ! Special handling of energy fix for SCAM - supplied via CAMIOP - zero's for normal IOPs - if (single_column) then - if (use_camiop) then - heat_glob = heat_glob_scm(1) - else - heat_glob = 0._r8 - endif - endif - - if (nstep > 0 .and. write_camiop) then - heat_out(:ncol) = heat_glob - call outfld('heat_glob', heat_out(:ncol), pcols, lchnk) - endif - - ! Call the CCPP-ized subroutine (for non-SCAM) - ! to compute the effective sensible heat flux and save to ptend%s - call check_energy_fix_run( & - ncol = ncol, & - pver = pver, & - pint = state%pint(:ncol,:), & - gravit = gravit, & - heat_glob = heat_glob, & - ptend_s = ptend%s(:ncol,:), & - eshflx = eshflx(:ncol), & - scheme_name = dummy_scheme_name, & - errmsg = errmsg, & - errflg = errflg & - ) - - end subroutine check_energy_cam_fix - subroutine check_tracers_init(state, tracerint) - -!----------------------------------------------------------------------- -! Compute initial values of tracers integrals, -! zero cumulative tendencies -!----------------------------------------------------------------------- - -!------------------------------Arguments-------------------------------- - - type(physics_state), intent(in) :: state - type(check_tracers_data), intent(out) :: tracerint - -!---------------------------Local storage------------------------------- - - real(r8) :: tr(pcols) ! vertical integral of tracer - real(r8) :: trpdel(pcols, pver) ! pdel for tracer - - integer ncol ! number of atmospheric columns - integer i,k,m ! column, level,constituent indices - integer :: ixcldice, ixcldliq ! CLDICE and CLDLIQ indices - integer :: ixrain, ixsnow ! RAINQM and SNOWQM indices - integer :: ixgrau ! GRAUQM index -!----------------------------------------------------------------------- - - ncol = state%ncol - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('RAINQM', ixrain, abort=.false.) - call cnst_get_ind('SNOWQM', ixsnow, abort=.false.) - call cnst_get_ind('GRAUQM', ixgrau, abort=.false.) - - - do m = 1,pcnst - - if ( any(m == (/ 1, ixcldliq, ixcldice, & - ixrain, ixsnow, ixgrau /)) ) exit ! dont process water substances - ! they are checked in check_energy - - if (cnst_get_type_byind(m).eq.'dry') then - trpdel(:ncol,:) = state%pdeldry(:ncol,:) - else - trpdel(:ncol,:) = state%pdel(:ncol,:) - endif - - ! Compute vertical integrals of tracer - tr = 0._r8 - do k = 1, pver - do i = 1, ncol - tr(i) = tr(i) + state%q(i,k,m)*trpdel(i,k)*rga - end do - end do - - ! Compute vertical integrals of frozen static tracers and total water. - do i = 1, ncol - tracerint%tracer(i,m) = tr(i) - end do - - ! zero cummulative boundary fluxes - tracerint%tracer_tnd(:ncol,m) = 0._r8 - - tracerint%count(m) = 0 - - end do - - return - end subroutine check_tracers_init - -!=============================================================================== - subroutine check_tracers_chng(state, tracerint, name, nstep, ztodt, cflx) - -!----------------------------------------------------------------------- -! Check that the tracers and water change matches the boundary fluxes -! these checks are not save when there are tracers transformations, as -! they only check to see whether a mass change in the column is -! associated with a flux -!----------------------------------------------------------------------- - - use cam_abortutils, only: endrun - - - implicit none - -!------------------------------Arguments-------------------------------- - - type(physics_state) , intent(in ) :: state - type(check_tracers_data), intent(inout) :: tracerint! tracers integrals and boundary fluxes - character*(*),intent(in) :: name ! parameterization name for fluxes - integer , intent(in ) :: nstep ! current timestep number - real(r8), intent(in ) :: ztodt ! 2 delta t (model time increment) - real(r8), intent(in ) :: cflx(pcols,pcnst) ! boundary flux of tracers (kg/m2/s) - -!---------------------------Local storage------------------------------- - - real(r8) :: tracer_inp(pcols,pcnst) ! total tracer of new (input) state - real(r8) :: tracer_xpd(pcols,pcnst) ! expected value (w0 + dt*boundary_flux) - real(r8) :: tracer_dif(pcols,pcnst) ! tracer_inp - original tracer - real(r8) :: tracer_tnd(pcols,pcnst) ! tendency from last process - real(r8) :: tracer_rer(pcols,pcnst) ! relative error in tracer column - - real(r8) :: tr(pcols) ! vertical integral of tracer - real(r8) :: trpdel(pcols, pver) ! pdel for tracer - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - integer i,k ! column, level indices - integer :: ixcldice, ixcldliq ! CLDICE and CLDLIQ indices - integer :: ixrain, ixsnow ! RAINQM and SNOWQM indices - integer :: ixgrau ! GRAUQM index - integer :: m ! tracer index - character(len=8) :: tracname ! tracername -!----------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('RAINQM', ixrain, abort=.false.) - call cnst_get_ind('SNOWQM', ixsnow, abort=.false.) - call cnst_get_ind('GRAUQM', ixgrau, abort=.false.) - - do m = 1,pcnst - - if ( any(m == (/ 1, ixcldliq, ixcldice, & - ixrain, ixsnow, ixgrau /)) ) exit ! dont process water substances - ! they are checked in check_energy - tracname = cnst_name(m) - if (cnst_get_type_byind(m).eq.'dry') then - trpdel(:ncol,:) = state%pdeldry(:ncol,:) - else - trpdel(:ncol,:) = state%pdel(:ncol,:) - endif - - ! Compute vertical integrals tracers - tr = 0._r8 - do k = 1, pver - do i = 1, ncol - tr(i) = tr(i) + state%q(i,k,m)*trpdel(i,k)*rga - end do - end do - - ! Compute vertical integrals of tracer - do i = 1, ncol - tracer_inp(i,m) = tr(i) - end do - - ! compute expected values and tendencies - do i = 1, ncol - ! change in tracers - tracer_dif(i,m) = tracer_inp(i,m) - tracerint%tracer(i,m) - - ! expected tendencies from boundary fluxes for last process - tracer_tnd(i,m) = cflx(i,m) - - ! cummulative tendencies from boundary fluxes - tracerint%tracer_tnd(i,m) = tracerint%tracer_tnd(i,m) + tracer_tnd(i,m) - - ! expected new values from original values plus boundary fluxes - tracer_xpd(i,m) = tracerint%tracer(i,m) + tracerint%tracer_tnd(i,m)*ztodt - - ! relative error, expected value - input value / original - tracer_rer(i,m) = (tracer_xpd(i,m) - tracer_inp(i,m)) / tracerint%tracer(i,m) - end do - -!! final loop for error checking -! do i = 1, ncol - -!! error messages -! if (abs(enrgy_rer(i)) > 1.E-14 .or. abs(water_rer(i)) > 1.E-14) then -! tracerint%count = tracerint%count + 1 -! write(iulog,*) "significant conservations error after ", name, & -! " count", tracerint%count, " nstep", nstep, "chunk", lchnk, "col", i -! write(iulog,*) enrgy_inp(i),enrgy_xpd(i),enrgy_dif(i),tracerint%enrgy_tnd(i)*ztodt, & -! enrgy_tnd(i)*ztodt,enrgy_rer(i) -! write(iulog,*) water_inp(i),water_xpd(i),water_dif(i),tracerint%water_tnd(i)*ztodt, & -! water_tnd(i)*ztodt,water_rer(i) -! end if -! end do - - - ! final loop for error checking - if ( maxval(tracer_rer) > 1.E-14_r8 ) then - write(iulog,*) "CHECK_TRACERS TRACER large rel error" - write(iulog,*) tracer_rer - endif - - do i = 1, ncol - ! error messages - if (abs(tracer_rer(i,m)) > 1.E-14_r8 ) then - tracerint%count = tracerint%count + 1 - write(iulog,*) "CHECK_TRACERS TRACER significant conservation error after ", name, & - " count", tracerint%count, " nstep", nstep, "chunk", lchnk, "col",i - write(iulog,*)' process name, tracname, index ', name, tracname, m - write(iulog,*)" input integral ",tracer_inp(i,m) - write(iulog,*)" expected integral ", tracer_xpd(i,m) - write(iulog,*)" input - inital integral ",tracer_dif(i,m) - write(iulog,*)" cumulative tend ",tracerint%tracer_tnd(i,m)*ztodt - write(iulog,*)" process tend ",tracer_tnd(i,m)*ztodt - write(iulog,*)" relative error ",tracer_rer(i,m) - call endrun() - end if - end do - end do - - return - end subroutine check_tracers_chng - -!####################################################################### - - subroutine tot_energy_phys(state, outfld_name_suffix,vc) - use physconst, only: rga,rearth,omega - use cam_thermo, only: get_hydrostatic_energy,thermo_budget_num_vars,thermo_budget_vars, & - wvidx,wlidx,wiidx,seidx,poidx,keidx,moidx,mridx,ttidx,teidx - use cam_history, only: outfld - use dyn_tests_utils, only: vc_physics - use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS - - use cam_abortutils, only: endrun - use cam_history_support, only: max_fieldname_len - use cam_budget, only: thermo_budget_history -!------------------------------Arguments-------------------------------- - - type(physics_state), intent(inout) :: state - character(len=*), intent(in) :: outfld_name_suffix ! suffix for "outfld" - integer, optional, intent(in) :: vc ! vertical coordinate (controls energy formula to use) - -!---------------------------Local storage------------------------------- - real(r8) :: se(pcols) ! Dry Static energy (J/m2) - real(r8) :: po(pcols) ! surface potential or potential energy (J/m2) - real(r8) :: ke(pcols) ! kinetic energy (J/m2) - real(r8) :: wv(pcols) ! column integrated vapor (kg/m2) - real(r8) :: liq(pcols) ! column integrated liquid (kg/m2) - real(r8) :: ice(pcols) ! column integrated ice (kg/m2) - real(r8) :: tt(pcols) ! column integrated test tracer (kg/m2) - real(r8) :: mr(pcols) ! column integrated wind axial angular momentum (kg*m2/s) - real(r8) :: mo(pcols) ! column integrated mass axial angular momentum (kg*m2/s) - real(r8) :: tt_tmp,mr_tmp,mo_tmp,cos_lat - real(r8) :: mr_cnst, mo_cnst - real(r8) :: cp_or_cv(pcols,pver) ! cp for pressure-based vcoord and cv for height vcoord - real(r8) :: temp(pcols,pver) ! temperature - real(r8) :: scaling(pcols,pver) ! scaling for conversion of temperature increment - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i,k ! column, level indices - integer :: vc_loc ! local vertical coordinate variable - integer :: ixtt ! test tracer index - character(len=max_fieldname_len) :: name_out(thermo_budget_num_vars) - -!----------------------------------------------------------------------- - - if (.not.thermo_budget_history) return - - do i=1,thermo_budget_num_vars - name_out(i)=trim(thermo_budget_vars(i))//'_'//trim(outfld_name_suffix) - end do - - lchnk = state%lchnk - ncol = state%ncol - - ! The "vertical coordinate" parameter is equivalent to the dynamical core - ! energy formula parameter, which controls the dycore energy formula used - ! by get_hydrostatic_energy. - if (present(vc)) then - vc_loc = vc - else - vc_loc = vc_physics - end if - - if (state%psetcols == pcols) then - if (vc_loc == ENERGY_FORMULA_DYCORE_MPAS .or. vc_loc == ENERGY_FORMULA_DYCORE_SE) then - cp_or_cv(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) - else - cp_or_cv(:ncol,:) = cpairv(:ncol,:,lchnk) - end if - else - call endrun('tot_energy_phys: energy diagnostics not implemented/tested for subcolumns') - end if - - if (vc_loc == ENERGY_FORMULA_DYCORE_MPAS .or. vc_loc == ENERGY_FORMULA_DYCORE_SE) then - scaling(:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv(:ncol,:)!scaling for energy consistency - else - scaling(:ncol,:) = 1.0_r8 !internal energy / enthalpy same as CAM physics - end if - ! scale accumulated temperature increment for internal energy / enthalpy consistency - temp(1:ncol,:) = state%temp_ini(1:ncol,:)+scaling(1:ncol,:)*(state%T(1:ncol,:)- state%temp_ini(1:ncol,:)) - call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & - state%pdel(1:ncol,1:pver), cp_or_cv(1:ncol,1:pver), & - state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), temp(1:ncol,1:pver), & - vc_loc, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & - z_mid = state%z_ini(1:ncol,:), se = se(1:ncol), & - po = po(1:ncol), ke = ke(1:ncol), wv = wv(1:ncol), liq = liq(1:ncol), & - ice = ice(1:ncol)) - - call cnst_get_ind('TT_LW' , ixtt , abort=.false.) - tt = 0._r8 - if (ixtt > 1) then - if (name_out(ttidx) == 'TT_pAM'.or.name_out(ttidx) == 'TT_zAM') then - ! - ! after dme_adjust mixing ratios are all wet - ! - do k = 1, pver - do i = 1, ncol - tt_tmp = state%q(i,k,ixtt)*state%pdel(i,k)*rga - tt (i) = tt(i) + tt_tmp - end do - end do - else - do k = 1, pver - do i = 1, ncol - tt_tmp = state%q(i,k,ixtt)*state%pdeldry(i,k)*rga - tt (i) = tt(i) + tt_tmp - end do - end do - end if - end if - - call outfld(name_out(seidx) ,se , pcols ,lchnk ) - call outfld(name_out(poidx) ,po , pcols ,lchnk ) - call outfld(name_out(keidx) ,ke , pcols ,lchnk ) - call outfld(name_out(wvidx) ,wv , pcols ,lchnk ) - call outfld(name_out(wlidx) ,liq , pcols ,lchnk ) - call outfld(name_out(wiidx) ,ice , pcols ,lchnk ) - call outfld(name_out(ttidx) ,tt , pcols ,lchnk ) - call outfld(name_out(teidx) ,se+ke+po, pcols ,lchnk ) - ! - ! Axial angular momentum diagnostics - ! - ! Code follows - ! - ! Lauritzen et al., (2014): Held-Suarez simulations with the Community Atmosphere Model - ! Spectral Element (CAM-SE) dynamical core: A global axial angularmomentum analysis using Eulerian - ! and floating Lagrangian vertical coordinates. J. Adv. Model. Earth Syst. 6,129-140, - ! doi:10.1002/2013MS000268 - ! - ! MR is equation (6) without \Delta A and sum over areas (areas are in units of radians**2) - ! MO is equation (7) without \Delta A and sum over areas (areas are in units of radians**2) - ! - - mr_cnst = rga*rearth**3 - mo_cnst = rga*omega*rearth**4 - - mr = 0.0_r8 - mo = 0.0_r8 - do k = 1, pver - do i = 1, ncol - cos_lat = cos(state%lat(i)) - mr_tmp = mr_cnst*state%u(i,k)*state%pdel(i,k)*cos_lat - mo_tmp = mo_cnst*state%pdel(i,k)*cos_lat**2 - - mr(i) = mr(i) + mr_tmp - mo(i) = mo(i) + mo_tmp - end do - end do - - call outfld(name_out(mridx) ,mr, pcols,lchnk ) - call outfld(name_out(moidx) ,mo, pcols,lchnk ) - - end subroutine tot_energy_phys - - subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, itim_old,& - qini,totliqini,toticeini,tend) - use camsrfexch, only: cam_in_t, cam_out_t, get_prec_vars - use physics_buffer, only: pbuf_get_index, physics_buffer_desc, pbuf_set_field, pbuf_get_field - use cam_abortutils, only: endrun - use air_composition, only: hliq_idx, hice_idx, fliq_idx, fice_idx, num_enthalpy_vars - use air_composition, only: cpairv, cp_or_cv_dycore, te_init - use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx - use physconst, only: cpliq, cpice, cpwv, tmelt - use air_composition, only: t00a, h00a !+tht - use physconst, only: rga, latvap, latice - use dyn_tests_utils, only: vc_dycore - use cam_thermo, only: get_hydrostatic_energy - use physics_types, only: physics_dme_adjust, dyn_te_idx - use cam_thermo, only: cam_thermo_water_update - use cam_history, only: outfld - use cam_budget, only: thermo_budget_history - use time_manager, only: get_nstep - integer, intent(in) :: ncol, lchnk - type(physics_state), intent(inout) :: state - type(cam_in_t), intent(in ) :: cam_in - type(cam_out_t), intent(inout) :: cam_out - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: ztodt - integer, intent(in) :: itim_old - real(r8), dimension(pcols,pver), intent(in) :: qini, totliqini, toticeini - type(physics_tend ) , intent(inout) :: tend - - integer:: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx - real(r8), dimension(:,:), pointer :: enthalpy_prec_bc - real(r8), dimension(pcols,num_enthalpy_vars) :: enthalpy_prec_ac - real(r8), dimension(pcols) :: fliq_tot, fice_tot - - integer:: dp_ntprp_idx, dp_ntsnp_idx - real(r8), dimension(:,:), pointer :: dp_ntprp, dp_ntsnp - integer:: qrain_mg_idx,qsnow_mg_idx - real(r8), dimension(:,:), pointer :: qrain_mg, qsnow_mg - - real(r8), dimension(pcols) :: te , se , po , ke - real(r8), dimension(pcols) :: te_endphys, se_endphys, po_endphys, ke_endphys - real(r8), dimension(pcols) :: te_dme , se_dme , po_dme , ke_dme - real(r8), dimension(pcols) :: te_enth_fix , se_enth_fix , po_enth_fix , ke_enth_fix - real(r8), dimension(pcols) :: fct_bc_tot, fct_ac_tot - real(r8), dimension(pcols) :: enthalpy_heating_fix_bc, enthalpy_heating_fix_ac - - real(r8), dimension(pcols) :: dEdt_physics - real(r8), dimension(pcols) :: dEdt_dme - real(r8), dimension(pcols) :: dEdt_cpdycore - real(r8), dimension(pcols) :: dEdt_enth_fix, dEdt_efix - real(r8), dimension(pcols) :: constant_latent_heat_surface !xxx diagnostics - real(r8), dimension(pcols) :: variable_latent_heat_surface_cpice_term !xxx diagnostics - real(r8), dimension(pcols) :: variable_latent_heat_surface_ls_term !xxx diagnostics - real(r8), dimension(pcols) :: variable_latent_heat_surface_lf_term !xxx diagnostics - real(r8), dimension(pcols) :: enthalpy_flux_atm, enthalpy_flux_ocn !tht - real(r8), dimension(pcols,pver) :: tmp_t, pdel_rf, qinp, totliqinp, toticeinp - real(r8), dimension(pcols) :: zero, dsema, dcp_heat, iedme - real(r8), dimension(pcols) :: water_flux_bc, water_flux_ac, enthalpy_flux_bc, enthalpy_flux_ac - real(r8), dimension(pcols) :: eflx_out - real(r8), dimension(pcols) :: mflx_out - real(r8), dimension(pcols) :: hevap_atm, hevap_ocn - real(r8), dimension(pcols) :: tevp, tprc, nocnfrc - - real(r8), dimension(pcols,pver) :: rnsrc_pbc, snsrc_pbc - real(r8), dimension(pcols,pver) :: rnsrc_pac, snsrc_pac - real(r8), dimension(pcols,pver) :: rnsrc_tot, snsrc_tot - real(r8), dimension(pcols) :: watrerr,rainerr,snowerr - - integer nstep, ixq, m, m_cnst - real(r8), dimension(pcols,pver) :: fct_bc, fct_ac - real(r8), dimension(pcols,pver) :: scale_cpdry_cpdycore, ttend_hfix - - real(r8), parameter :: eps=1.E-10_r8 - - logical, parameter :: debug_enthalpy=.false. - logical, parameter :: use_nonlinear_evap_fraction=.false. - - integer :: i, k - real(r8):: tot, wgt_bc, wgt_ac -!---- - - nstep = get_nstep() - zero(:)=0._r8 - - ! scale temperature for consistency with dycore (tht: partial adj. after cp update done implicitly in dme) - do k = 1, pver - do i = 1, ncol - scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) - state%T (i,k) = state%temp_ini(i,k)+scale_cpdry_cpdycore(i,k)*(state%T(i,k)- state%temp_ini(i,k)) - tend%dtdt(i,k) = scale_cpdry_cpdycore(i,k)*tend%dtdt(i,k) - end do - end do - - !------------------------------------------------------------------------------------------- - ! from this point onwards computation consistent with variable latent heat total energy formula - ! Equation 78 in https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2022MS003117 - !------------------------------------------------------------------------------------------- - - !=== start computation of material enthalpy fluxes === - ! evaporation enthalpy flux - enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP' , errcode=i) - if (enthalpy_evop_idx==0) then - call endrun("pbufs for enthalpy evap flux not allocated") - end if - ! using merged quantities, for atmospheric mat.enthalpy flux (used in check_energy) - if (minval(cam_in%ts(:ncol)).gt.0._r8) then - hevap_atm(:ncol) = cam_in%cflx (:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm - !tht: add non-linear terms? using evap_ocn, sst - if (use_nonlinear_evap_fraction) then - nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) - where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large - hevap_atm(:ncol)= hevap_atm(:ncol) & - + cpwv & - *(1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & - *(cam_in%cflx(:ncol,1)-cam_in%evap_ocn(:ncol)) & - *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) - tevp (:ncol)= cam_in%ts(:ncol) & - + (1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & - *(1._r8-cam_in%evap_ocn(:ncol)/cam_in%cflx(:ncol,1))& - *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) - elsewhere - tevp (:ncol)= cam_in%ts(:ncol) - endwhere - else - tevp (:ncol)= cam_in%ts(:ncol) - endif - !tht: for ocean-only mat.enthalpy flux (passed to ocean) - hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) - else ! not great but better than zeros - hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm - tevp (:ncol)= state%t(:ncol,pver) - hevap_ocn (:ncol)= hevap_atm(:ncol) ! out of ocn - endif - call pbuf_set_field(pbuf, enthalpy_evop_idx, hevap_ocn) - - if (use_nonlinear_evap_fraction) then - if(maxval(tevp(:ncol)).gt.350._r8 .or. minval(tevp(:ncol)).lt.150._r8)then - i=maxloc(tevp(:ncol),1) - k=minloc(tevp(:ncol),1) - print*,'Bad Tevap' - print*,'min ts=',minval(cam_in%ts(:ncol)),maxval(cam_in%ts(:ncol)) - print*,'state%t',minval(state%t(:ncol,pver)),maxval(state%t(:ncol,pver)) - print*,'tevp =',tevp(k),tevp(i) - print*,'ts =',cam_in%ts (k),cam_in%ts (i) - print*,'sst =',cam_in%sst(k),cam_in%sst(i) - print*,'cflx =',cam_in%cflx(k,1),cam_in%cflx(i,1) - print*,'evop =',cam_in%evap_ocn(k),cam_in%evap_ocn(i) - print*,'corr =',(1._r8-nocnfrc(k))/nocnfrc(k) *(1._r8-cam_in%evap_ocn(k)/cam_in%cflx(k,1)) *(cam_in%ts(k)-cam_in%sst(k)) & - ,(1._r8-nocnfrc(i))/nocnfrc(i) *(1._r8-cam_in%evap_ocn(i)/cam_in%cflx(i,1)) *(cam_in%ts(i)-cam_in%sst(i)) - call endrun('stopping in enthalpy_adjustment') - endif - endif - - !------------------------------------------------------------------ - ! compute precipitation fluxes and set associated physics buffers - !------------------------------------------------------------------ - enthalpy_prec_bc_idx = pbuf_get_index('ENTHALPY_PREC_BC', errcode=i) - enthalpy_prec_ac_idx = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) - if (enthalpy_prec_bc_idx==0.or.enthalpy_prec_ac_idx==0) then - call endrun("pbufs for enthalpy precip flux not allocated") - end if - call pbuf_get_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) - call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot) - ! fliq_tot holds liquid precipitation from tphysbc and tphysac; idem for ice - enthalpy_prec_ac(:ncol,fice_idx) = fice_tot(:ncol)-enthalpy_prec_bc(:ncol,fice_idx) - enthalpy_prec_ac(:ncol,fliq_idx) = fliq_tot(:ncol)-enthalpy_prec_bc(:ncol,fliq_idx) - - ! compute precipitation enthalpy fluxes from tphysbc - tprc (:ncol) = cam_out%tbot(:ncol) - !tht: correct for reference T of latent heats (liquid reference state) - enthalpy_prec_ac(:ncol,hice_idx) = -enthalpy_prec_ac(:ncol,fice_idx)*(cpice*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) - enthalpy_prec_ac(:ncol,hliq_idx) = -enthalpy_prec_ac(:ncol,fliq_idx)*(cpliq*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) - call pbuf_set_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) - - ! compute total enthalpy flux - enthalpy_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) - enthalpy_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & - +hevap_atm (:ncol) - water_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,fliq_idx)+enthalpy_prec_bc(:ncol,fice_idx) - water_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,fliq_idx)+enthalpy_prec_ac(:ncol,fice_idx) & - -cam_in%cflx(:ncol,1) - enthalpy_flux_atm(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & - +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & - +hevap_atm (:ncol) - enthalpy_flux_ocn(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & - +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & - +hevap_ocn (:ncol) - enthalpy_flux_ocn(:ncol) = cam_in%ocnfrac(:ncol)*enthalpy_flux_ocn(:ncol) - - if (debug_enthalpy) then - call outfld("enth_prec_ac_hice" , enthalpy_prec_ac(:,hice_idx) , pcols ,lchnk ) - call outfld("enth_prec_ac_hliq" , enthalpy_prec_ac(:,hliq_idx) , pcols ,lchnk ) - call outfld("enth_prec_bc_hice" , enthalpy_prec_bc(:,hice_idx) , pcols ,lchnk ) - call outfld("enth_prec_bc_hliq" , enthalpy_prec_bc(:,hliq_idx) , pcols ,lchnk ) - call outfld("enth_prec_ac_fice" , enthalpy_prec_ac(:,fice_idx) , pcols ,lchnk ) - call outfld("enth_prec_ac_fliq" , enthalpy_prec_ac(:,fliq_idx) , pcols ,lchnk ) - call outfld("enth_prec_bc_fice" , enthalpy_prec_bc(:,fice_idx) , pcols ,lchnk ) - call outfld("enth_prec_bc_fliq" , enthalpy_prec_bc(:,fliq_idx) , pcols ,lchnk ) - call outfld("enth_hevap_atm" , hevap_atm (:) , pcols ,lchnk ) - call outfld("enth_hevap_ocn" , hevap_ocn (:) , pcols ,lchnk ) - endif - !=== end computation of material enthalpy fluxes === - - !+++ diags - ! compute total energy after physics using equation 78 - call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & - state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & - state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& - vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & - te = te_endphys(:ncol), se=se_endphys(:ncol), po=po_endphys(:ncol), ke=ke_endphys(:ncol)) - ! the column integrated total energy change should match accumlated te_tnd: - ! dEdt_physics=te_tnd - call outfld ('te_tnd',tend%te_tnd , pcols, lchnk) - dEdt_physics(:ncol) = (te_endphys(:ncol)-te_init(:ncol,1,lchnk))/ztodt - call outfld ('dEdt_physics', dEdt_physics, pcols, lchnk) - !--- sgaid - - !+ get pbuf fields for precip - dp_ntprp_idx = pbuf_get_index('dp_ntprp',errcode=i) !prec production from ZM - dp_ntsnp_idx = pbuf_get_index('dp_ntsnp',errcode=i) !snow production from ZM - call pbuf_get_field(pbuf, dp_ntprp_idx , dp_ntprp) - call pbuf_get_field(pbuf, dp_ntsnp_idx , dp_ntsnp) - qrain_mg_idx = pbuf_get_index('qrain_mg',errcode=i) !rain production from MG - qsnow_mg_idx = pbuf_get_index('qsnow_mg',errcode=i) !snow production from MG - call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) - call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) - rnsrc_pbc(:ncol,:) = dp_ntprp(:ncol,:)-dp_ntsnp(:ncol,:) - snsrc_pbc(:ncol,:) = dp_ntsnp(:ncol,:) - rnsrc_pac(:ncol,:) = qrain_mg(:ncol,:) - snsrc_pac(:ncol,:) = qsnow_mg(:ncol,:) - rnsrc_tot(:ncol,:) = rnsrc_pbc(:ncol,:)+rnsrc_pac(:ncol,:) - snsrc_tot(:ncol,:) = snsrc_pbc(:ncol,:)+snsrc_pac(:ncol,:) - !- picerp rof sdleif fubp teg - - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt & - , dme_energy_adjust=.true.,step='bc+ac' & - , ntrnprd=rnsrc_tot*ztodt & - , ntsnprd=snsrc_tot*ztodt & - , tevap=tevp, tprec=tprc & - , mflx=water_flux_bc+water_flux_ac & - , eflx=enthalpy_flux_atm & - , mflx_out=mflx_out & - , eflx_out=eflx_out & - , ent_tnd=dsema & - , pdel_rf=pdel_rf ) - - call outfld('IETEND_DME', dsema , pcols, lchnk) - call outfld('EFLX' , enthalpy_flux_atm , pcols, lchnk) - call outfld('MFLX' , water_flux_bc+water_flux_ac , pcols, lchnk) - - ! compute and store new column-integrated enthalpy and associated tendency - call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & - state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & - state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& - vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & - te = te(:ncol), se=se(:ncol), po=po(:ncol), ke=ke(:ncol)) - ! Save final energy for use with global fixer in next timestep -- note sign conventions, and coupling-dependent options - state%te_cur(:ncol,dyn_te_idx) = te(:ncol) & ! *subtract* from this the h flux (sign: into atm) that is *not* passed to surface components - -ztodt*(enthalpy_flux_atm(:ncol)-enthalpy_flux_ocn(:ncol)-cam_in%hrof(:ncol)) ! also remove enthalpy of run-off (if added to BLOM) - tend%te_tnd(:ncol)=tend%te_tnd(:ncol) +(enthalpy_flux_ocn(:ncol)+cam_in%hrof(:ncol)) ! B. with run-off - - if (thermo_budget_history) then - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - endif - - call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) - ! the amount of total energy we need energy fixer to fix (associated with enthalpy flux) - dEdt_efix(:ncol) = (state%te_cur(:ncol,dyn_te_idx)-te (:ncol))/ztodt - call outfld("dEdt_efix_physics" , dEdt_efix , pcols ,lchnk ) - - end subroutine enthalpy_adjustment - -end module check_energy diff --git a/src/physics/camnor_phys/physics/check_energy_chng.F90 b/src/physics/camnor_phys/physics/check_energy_chng.F90 deleted file mode 100644 index 8974ad9b8b..0000000000 --- a/src/physics/camnor_phys/physics/check_energy_chng.F90 +++ /dev/null @@ -1,426 +0,0 @@ -module check_energy_chng - use ccpp_kinds, only: kind_phys - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: check_energy_chng_init - public :: check_energy_chng_timestep_init - public :: check_energy_chng_run - - ! Private module options. - logical :: print_energy_errors = .false. ! Turn on verbose output identifying columns that fail - ! energy/water checks? - -contains - -!> \section arg_table_check_energy_chng_init Argument Table -!! \htmlinclude arg_table_check_energy_chng_init.html - subroutine check_energy_chng_init(print_energy_errors_in) - ! Input arguments - logical, intent(in) :: print_energy_errors_in - - print_energy_errors = print_energy_errors_in - end subroutine check_energy_chng_init - - ! Compute initial values of energy and water integrals, - ! and zero out cumulative boundary tendencies. -!> \section arg_table_check_energy_chng_timestep_init Argument Table -!! \htmlinclude arg_table_check_energy_chng_timestep_init.html - subroutine check_energy_chng_timestep_init( & - ncol, pver, pcnst, & - is_first_timestep, & - q, pdel, & - u, v, T, & - pintdry, phis, zm, & - cp_phys, & ! cpairv generally, cpair fixed size for subcolumns code - cp_or_cv_dycore, & - te_ini_phys, te_ini_dyn, & - tw_ini, & - te_cur_phys, te_cur_dyn, & - tw_cur, & - tend_te_tnd, tend_tw_tnd, & - temp_ini, z_ini, & - count, & - teout, & - energy_formula_physics, energy_formula_dycore, & - errmsg, errflg) - - ! This scheme is non-portable due to dependencies on cam_thermo - ! for hydrostatic energy calculation (physics and dycore formulas) - use cam_thermo, only: get_hydrostatic_energy - use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS - - ! Input arguments - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: pcnst ! number of ccpp constituents - logical, intent(in) :: is_first_timestep ! is first step of initial run? - real(kind_phys), intent(in) :: q(:,:,:) ! constituent mass mixing ratios [kg kg-1] - real(kind_phys), intent(in) :: pdel(:,:) ! layer thickness [Pa] - real(kind_phys), intent(in) :: u(:,:) ! zonal wind [m s-1] - real(kind_phys), intent(in) :: v(:,:) ! meridional wind [m s-1] - real(kind_phys), intent(in) :: T(:,:) ! temperature [K] - real(kind_phys), intent(in) :: pintdry(:,:) ! interface pressure dry [Pa] - real(kind_phys), intent(in) :: phis(:) ! surface geopotential [m2 s-2] - real(kind_phys), intent(in) :: zm(:,:) ! geopotential height at layer midpoints [m] - real(kind_phys), intent(in) :: cp_phys(:,:) ! enthalpy (cpairv generally) [J kg-1 K-1] - real(kind_phys), intent(in) :: cp_or_cv_dycore(:,:) ! enthalpy or heat capacity, dycore dependent [J K-1 kg-1] - integer, intent(in) :: energy_formula_physics! total energy formulation physics - integer, intent(in) :: energy_formula_dycore ! total energy formulation dycore - - ! Output arguments - real(kind_phys), intent(out) :: temp_ini(:,:) ! initial temperature [K] - real(kind_phys), intent(out) :: z_ini(:,:) ! initial geopotential height [m] - integer, intent(out) :: count ! count of values with significant energy or water imbalances [1] - real(kind_phys), intent(out) :: teout(:) ! total energy for global fixer in next timestep [J m-2] - real(kind_phys), intent(out) :: tend_te_tnd(:) ! total energy tendency [J m-2 s-1] - real(kind_phys), intent(out) :: tend_tw_tnd(:) ! total water tendency [kg m-2 s-1] - - ! Input/Output arguments - real(kind_phys), intent(inout) :: te_ini_phys(:) ! physics formula: initial total energy [J m-2] - real(kind_phys), intent(inout) :: te_ini_dyn (:) ! dycore formula: initial total energy [J m-2] - real(kind_phys), intent(inout) :: tw_ini (:) ! initial total water [kg m-2] - real(kind_phys), intent(inout) :: te_cur_phys(:) ! physics formula: current total energy [J m-2] - real(kind_phys), intent(inout) :: te_cur_dyn (:) ! dycore formula: current total energy [J m-2] - real(kind_phys), intent(inout) :: tw_cur (:) ! current total water [kg m-2] - - ! Output arguments - character(len=512), intent(out) :: errmsg ! error message - integer, intent(out) :: errflg ! error flag - - errmsg = '' - errflg = 0 - - !------------------------------------------------ - ! Physics total energy. - !------------------------------------------------ - call get_hydrostatic_energy( & - tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios - moist_mixing_ratio = .true., & - pdel_in = pdel (1:ncol,1:pver), & - cp_or_cv = cp_phys (1:ncol,1:pver), & - U = u (1:ncol,1:pver), & - V = v (1:ncol,1:pver), & - T = T (1:ncol,1:pver), & - vcoord = energy_formula_physics, & ! energy formula for physics - ptop = pintdry (1:ncol,1), & - phis = phis (1:ncol), & - te = te_ini_phys(1:ncol), & ! vertically integrated total energy - H2O = tw_ini (1:ncol) & ! v.i. total water - ) - - ! Save initial state temperature and geopotential height for use in run phase - temp_ini(:ncol,:) = T (:ncol, :) - z_ini (:ncol,:) = zm(:ncol, :) - - !------------------------------------------------ - ! Dynamical core total energy. - !------------------------------------------------ - if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_SE) then - ! SE dycore specific hydrostatic energy (enthalpy) - call get_hydrostatic_energy( & - tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios - moist_mixing_ratio = .true., & - pdel_in = pdel (1:ncol,1:pver), & - cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & - U = u (1:ncol,1:pver), & - V = v (1:ncol,1:pver), & - T = T (1:ncol,1:pver), & - vcoord = energy_formula_dycore, & ! energy formula for dycore - ptop = pintdry (1:ncol,1), & - phis = phis (1:ncol), & - te = te_ini_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy - ) - - else if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_MPAS) then - ! MPAS dycore: compute cv if vertical coordinate is height: cv = cp - R (internal energy) - call get_hydrostatic_energy( & - tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios - moist_mixing_ratio = .true., & - pdel_in = pdel (1:ncol,1:pver), & - cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & - U = u (1:ncol,1:pver), & - V = v (1:ncol,1:pver), & - T = T (1:ncol,1:pver), & ! enthalpy-scaled temperature for energy consistency - vcoord = energy_formula_dycore, & ! energy formula for dycore - ptop = pintdry (1:ncol,1), & - phis = phis (1:ncol), & - z_mid = z_ini (1:ncol,:), & ! unique for MPAS - te = te_ini_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy - ) - else - ! FV dycore: dycore energy is the same as physics - te_ini_dyn(:ncol) = te_ini_phys(:ncol) - endif - - ! Set current state to be the same as initial - te_cur_phys(:ncol) = te_ini_phys(:ncol) - te_cur_dyn (:ncol) = te_ini_dyn (:ncol) - tw_cur (:ncol) = tw_ini (:ncol) - - ! Zero out current energy unbalances count - count = 0 - - ! Zero out cumulative boundary fluxes - tend_te_tnd(:ncol) = 0._kind_phys - tend_tw_tnd(:ncol) = 0._kind_phys - - ! If first timestep, initialize value of teout - if(is_first_timestep) then - teout(:ncol) = te_ini_dyn(:ncol) - endif - - end subroutine check_energy_chng_timestep_init - - - ! Check that energy and water change matches the boundary fluxes. -!> \section arg_table_check_energy_chng_run Argument Table -!! \htmlinclude arg_table_check_energy_chng_run.html - subroutine check_energy_chng_run(nstep,lchnk,masterproc, & - ncol, pver, pcnst, & - iulog, & - q, pdel, & - u, v, T, & - pintdry, phis, zm, & - cp_phys, & ! cpairv generally, cpair fixed size for subcolumns code - cp_or_cv_dycore, & - scaling_dycore, & ! From check_energy_scaling to work around subcolumns code - te_cur_phys, te_cur_dyn, & - tw_cur, & - tend_te_tnd, tend_tw_tnd, & - temp_ini, z_ini, & - count, ztodt, & - latice, latvap, & - energy_formula_physics, energy_formula_dycore, & - name, flx_vap, flx_cnd, flx_ice, flx_sen, & - errmsg, errflg) - - ! This scheme is non-portable due to dependencies on cam_thermo - ! for hydrostatic energy calculation (physics and dycore formulas) - use cam_thermo, only: get_hydrostatic_energy - - ! Dependency for energy formula used by physics and dynamical cores - use cam_thermo_formula, only: ENERGY_FORMULA_DYCORE_FV, ENERGY_FORMULA_DYCORE_SE, ENERGY_FORMULA_DYCORE_MPAS - - ! Input arguments - integer, intent(in) :: nstep - integer, intent(in) :: lchnk - logical, intent(in) :: masterproc - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: pcnst ! number of ccpp constituents - integer, intent(in) :: iulog ! log output unit - real(kind_phys), intent(in) :: q(:,:,:) ! constituent mass mixing ratios [kg kg-1] - real(kind_phys), intent(in) :: pdel(:,:) ! layer thickness [Pa] - real(kind_phys), intent(in) :: u(:,:) ! zonal wind [m s-1] - real(kind_phys), intent(in) :: v(:,:) ! meridional wind [m s-1] - real(kind_phys), intent(in) :: T(:,:) ! temperature [K] - real(kind_phys), intent(in) :: pintdry(:,:) ! interface pressure dry [Pa] - real(kind_phys), intent(in) :: phis(:) ! surface geopotential [m2 s-2] - real(kind_phys), intent(in) :: zm(:,:) ! geopotential height at layer midpoints [m] - real(kind_phys), intent(in) :: temp_ini(:,:) ! initial temperature [K] - real(kind_phys), intent(in) :: z_ini(:,:) ! initial geopotential height [m] - real(kind_phys), intent(in) :: cp_phys(:,:) ! enthalpy (cpairv generally) [J kg-1 K-1] - real(kind_phys), intent(in) :: cp_or_cv_dycore(:,:) ! enthalpy or heat capacity, dycore dependent [J K-1 kg-1] - real(kind_phys), intent(in) :: scaling_dycore(:,:) ! scaling for conversion of temperature increment [1] - real(kind_phys), intent(in) :: ztodt ! physics timestep [s] - real(kind_phys), intent(in) :: latice ! constant, latent heat of fusion of water at 0 C [J kg-1] - real(kind_phys), intent(in) :: latvap ! constant, latent heat of vaporization of water at 0 C [J kg-1] - integer, intent(in) :: energy_formula_physics! total energy formulation physics - integer, intent(in) :: energy_formula_dycore ! total energy formulation dycore - - ! Input from CCPP-scheme being checked: - ! parameterization name; surface fluxes of (1) vapor, (2) liquid+ice, (3) ice, (4) sensible heat - ! to pass in the values to be checked, call check_energy_zero_input_fluxes to reset these values - ! before a parameterization that is checked, then update these values as-needed - ! (can be all zero; in fact, most parameterizations calling _chng call with zero arguments) - ! - ! Original comment from BAB: - ! Note that the precip and ice fluxes are in precip units (m/s). - ! I would prefer to have kg/m2/s. - ! I would also prefer liquid (not total) and ice fluxes - character(len=*), intent(in) :: name ! parameterization name for fluxes - real(kind_phys), intent(in) :: flx_vap(:) ! boundary flux of vapor [kg m-2 s-1] - real(kind_phys), intent(in) :: flx_cnd(:) ! boundary flux of liquid+ice (precip?) [m s-1] - real(kind_phys), intent(in) :: flx_ice(:) ! boundary flux of ice [m s-1] - real(kind_phys), intent(in) :: flx_sen(:) ! boundary flux of sensible heat [W m-2] - - ! Input/Output arguments - real(kind_phys), intent(inout) :: te_cur_phys(:) ! physics formula: current total energy [J m-2] - real(kind_phys), intent(inout) :: te_cur_dyn (:) ! dycore formula: current total energy [J m-2] - real(kind_phys), intent(inout) :: tw_cur (:) ! current total water [kg m-2] - integer, intent(inout) :: count ! count of columns with significant energy or water imbalances [1] - real(kind_phys), intent(inout) :: tend_te_tnd(:) ! total energy tendency [J m-2 s-1] - real(kind_phys), intent(inout) :: tend_tw_tnd(:) ! total water tendency [kg m-2 s-1] - - ! Output arguments - character(len=512), intent(out) :: errmsg ! error message - integer, intent(out) :: errflg ! error flag - - ! Local variables - real(kind_phys) :: te_xpd(ncol) ! expected value (f0 + dt*boundary_flux) - real(kind_phys) :: te_dif(ncol) ! energy of input state - original energy - real(kind_phys) :: te_tnd(ncol) ! tendency from last process - real(kind_phys) :: te_rer(ncol) ! relative error in energy column - - real(kind_phys) :: tw_xpd(ncol) ! expected value (w0 + dt*boundary_flux) - real(kind_phys) :: tw_dif(ncol) ! tw_inp - original water - real(kind_phys) :: tw_tnd(ncol) ! tendency from last process - real(kind_phys) :: tw_rer(ncol) ! relative error in water column - - real(kind_phys) :: te(ncol) ! vertical integral of total energy - real(kind_phys) :: tw(ncol) ! vertical integral of total water - real(kind_phys) :: temp(ncol,pver) ! temperature - - real(kind_phys) :: se(ncol) ! enthalpy or internal energy (J/m2) - real(kind_phys) :: po(ncol) ! surface potential or potential energy (J/m2) - real(kind_phys) :: ke(ncol) ! kinetic energy (J/m2) - real(kind_phys) :: wv(ncol) ! column integrated vapor (kg/m2) - real(kind_phys) :: liq(ncol) ! column integrated liquid (kg/m2) - real(kind_phys) :: ice(ncol) ! column integrated ice (kg/m2) - - integer :: i - - errmsg = '' - errflg = 0 - - !------------------------------------------------ - ! Physics total energy. - !------------------------------------------------ - call get_hydrostatic_energy( & - tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios - moist_mixing_ratio = .true., & - pdel_in = pdel (1:ncol,1:pver), & - cp_or_cv = cp_phys(1:ncol,1:pver), & - U = u (1:ncol,1:pver), & - V = v (1:ncol,1:pver), & - T = T (1:ncol,1:pver), & - vcoord = energy_formula_physics, & ! energy formula for physics - ptop = pintdry(1:ncol,1), & - phis = phis (1:ncol), & - te = te (1:ncol), & ! vertically integrated total energy - H2O = tw (1:ncol), & ! v.i. total water - se = se (1:ncol), & ! v.i. enthalpy - po = po (1:ncol), & ! v.i. PHIS term - ke = ke (1:ncol), & ! v.i. kinetic energy - wv = wv (1:ncol), & ! v.i. water vapor - liq = liq (1:ncol), & ! v.i. liquid - ice = ice (1:ncol) & ! v.i. ice - ) - - ! compute expected values and tendencies - do i = 1, ncol - ! change in static energy and total water - te_dif(i) = te(i) - te_cur_phys(i) - tw_dif(i) = tw(i) - tw_cur (i) - - ! expected tendencies from boundary fluxes for last process - te_tnd(i) = flx_vap(i)*(latvap+latice) - (flx_cnd(i) - flx_ice(i))*1000._kind_phys*latice + flx_sen(i) - tw_tnd(i) = flx_vap(i) - flx_cnd(i) *1000._kind_phys - - ! cummulative tendencies from boundary fluxes - tend_te_tnd(i) = tend_te_tnd(i) + te_tnd(i) - tend_tw_tnd(i) = tend_tw_tnd(i) + tw_tnd(i) - - ! expected new values from previous state plus boundary fluxes - te_xpd(i) = te_cur_phys(i) + te_tnd(i)*ztodt - tw_xpd(i) = tw_cur (i) + tw_tnd(i)*ztodt - - ! relative error, expected value - input state / previous state - te_rer(i) = (te_xpd(i) - te(i)) / te_cur_phys(i) - end do - - ! relative error for total water (allow for dry atmosphere) - tw_rer = 0._kind_phys - where (tw_cur(:ncol) > 0._kind_phys) - tw_rer(:ncol) = (tw_xpd(:ncol) - tw(:ncol)) / tw_cur(:ncol) - end where - - if (masterproc) then ! for testing - if (print_energy_errors) then - if (any(abs(te_rer(1:ncol)) > 1.E-14_r8 .or. abs(tw_rer(1:ncol)) > 1.E-10_r8)) then - do i = 1, ncol - ! the relative error threshold for the water budget has been reduced to 1.e-10 - ! to avoid messages generated by QNEG3 calls - if ( abs(tw_rer(i)) > 1.E-10_r8) then - count = count + 1 - write(iulog,*) "significant WATER conservation error after ", trim(name) - write(iulog,'(a8,i5,a9,i5 ,a7,i4)') & - " count: ", count, ", nstep: ", nstep , ", col: ", i - write(iulog,*) tw(i) , tw_xpd(i) , tw_tnd(i)*ztodt & - , tw_dif(i), tw_tnd(i)*ztodt - write(iulog,*) " relative mass deficit: ",tw_rer(i) - end if - if (abs(te_rer(i)) > 1.E-14_r8 ) then - count = count + 1 - write(iulog,*) "significant ENERGY conservation error after ", trim(name) - write(iulog,'(a8,i5,a9,i5 ,a7,i4)') & - " count: ", count, ", nstep: ", nstep , ", col: ", i - write(iulog,'(3e17.7)') te_dif(i), te_tnd(i)*ztodt, te_dif(i)-(te_tnd(i)*ztodt) - endif - end do - end if - end if - end if - - ! WRITE OPERATION - copy new value to state, including total water. - ! the total water operations are consistent regardless of energy formula, - ! so it only has to be written once. - do i = 1, ncol - te_cur_phys(i) = te(i) - tw_cur(i) = tw(i) - end do - - !------------------------------------------------ - ! Dynamical core total energy. - !------------------------------------------------ - if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_SE) then - ! SE dycore specific hydrostatic energy - - ! enthalpy scaling for energy consistency - temp(1:ncol,:) = temp_ini(1:ncol,:)+scaling_dycore(1:ncol,:)*(T(1:ncol,:)-temp_ini(1:ncol,:)) - - call get_hydrostatic_energy( & - tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios - moist_mixing_ratio = .true., & - pdel_in = pdel (1:ncol,1:pver), & - cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & - U = u (1:ncol,1:pver), & - V = v (1:ncol,1:pver), & - T = temp (1:ncol,1:pver), & ! enthalpy-scaled temperature for energy consistency - vcoord = energy_formula_dycore, & ! energy formula for dycore - ptop = pintdry (1:ncol,1), & - phis = phis (1:ncol), & - te = te_cur_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy - ) - - else if (energy_formula_dycore == ENERGY_FORMULA_DYCORE_MPAS) then - ! MPAS dycore: compute cv if vertical coordinate is height: cv = cp - R - - ! REMOVECAM: note this scaling is different with subcols off/on which is why it was put into separate scheme (hplin, 9/5/24) - temp(1:ncol,:) = temp_ini(1:ncol,:)+scaling_dycore(1:ncol,:)*(T(1:ncol,:)-temp_ini(1:ncol,:)) - - call get_hydrostatic_energy( & - tracer = q(1:ncol,1:pver,1:pcnst), & ! moist mixing ratios - moist_mixing_ratio = .true., & - pdel_in = pdel (1:ncol,1:pver), & - cp_or_cv = cp_or_cv_dycore(1:ncol,1:pver), & - U = u (1:ncol,1:pver), & - V = v (1:ncol,1:pver), & - T = temp (1:ncol,1:pver), & ! enthalpy-scaled temperature for energy consistency - vcoord = energy_formula_dycore, & ! energy formula for dycore - ptop = pintdry (1:ncol,1), & - phis = phis (1:ncol), & - z_mid = z_ini (1:ncol,:), & ! unique for MPAS - te = te_cur_dyn (1:ncol) & ! WRITE OPERATION - vertically integrated total energy - ) - - else - ! FV dycore - te_cur_dyn(1:ncol) = te(1:ncol) - end if - end subroutine check_energy_chng_run - -end module check_energy_chng From 004c3a617f7bb0cc8b8c7c011e1ef468e923dd6f Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 30 Sep 2025 16:00:54 +0200 Subject: [PATCH 20/78] removed state%hflx_ac and state%hflx_bc for now - since they were resulting in errors in DEBUG mode and they actually don't do anything at this point --- .../camnor_phys/physics/physics_types.F90 | 1063 +++--- src/physics/camnor_phys/physics/physpkg.F90 | 3177 ----------------- src/utils/air_composition.F90 | 24 +- 3 files changed, 557 insertions(+), 3707 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/physpkg.F90 diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index c9642f145c..72bbf49add 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -7,7 +7,7 @@ module physics_types use ppgrid, only: pcols, pver use constituents, only: pcnst, qmin, cnst_name, cnst_get_ind use geopotential, only: geopotential_t - use physconst, only: cpliq, cpwv !+tht + use physconst, only: cpliq, cpwv use physconst, only: zvir, gravit, cpair, rair use air_composition, only: cpairv, rairv use phys_grid, only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p @@ -15,7 +15,7 @@ module physics_types use cam_abortutils, only: endrun use phys_control, only: waccmx_is use shr_const_mod, only: shr_const_rwv - use spmd_utils, only: masterproc !+tht + use spmd_utils, only: masterproc implicit none private ! Make default type private to the module @@ -138,12 +138,12 @@ module physics_types integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols - real(r8), dimension(:,:),allocatable :: dtdt, dudt, dvdt ,s_dme, qt_dme !+tht s_dme, qt_dme + real(r8), dimension(:,:),allocatable :: dtdt, dudt, dvdt + real(r8), dimension(:,:),allocatable :: s_dme, qt_dme real(r8), dimension(:), allocatable :: flx_net real(r8), dimension(:), allocatable :: & te_tnd, &! cumulative boundary flux of total energy te_sen, &! cumulative sensible heat flux - ! te_lat, &! cumulative latent heat flux tw_tnd ! cumulative boundary flux of total water end type physics_tend @@ -187,22 +187,21 @@ module physics_types end type physics_ptend -!+tht (should perhaps be put in namelist) - logical :: levels_are_moist=.true. - ! 5 possibilities (-> = currently reccommended): - ! 1) conserve_dycore=.false., conserve_physics=.false. (no conservation = current CAM) - ! 2) conserve_dycore=.true., bndry_flx_surface=.true. (full conservation, bad climatology) - ! -> 3) conserve_dycore=.true., bndry_flx_local=.true. (requires fixer to match correct surface fluxes) - ! 4) conserve_physics=.true., bndry_flx_local=.true. (as 3., plus fixer for atmo energy) - ! 5) conserve_physics=.true., bndry_flx_surface=.true. (no advantage wrt option 2) - ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its - ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. - logical, parameter :: conserve_dycore =.true. & - ,bndry_flx_surface=.true. - !,bndry_flx_surface=.true. - logical, parameter :: conserve_physics =(.not.conserve_dycore).and..true. & - ,bndry_flx_local = .not.bndry_flx_surface -!-tht + logical :: levels_are_moist=.true. ! TODO: put in namelist? + ! 5 possibilities (-> = currently reccommended): + ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) + ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) + ! -> 3) conserve_dycore=.true. , bndry_flx_local=.true. (requires fixer to match correct surface fluxes) + ! 4) conserve_physics=.true. , bndry_flx_local=.true. (as 3., plus fixer for atmo energy) + ! 5) conserve_physics=.true. , bndry_flx_surface=.true. (no advantage wrt option 2) + + ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its + ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. + + logical, parameter :: conserve_dycore = .true. + logical, parameter :: bndry_flx_surface = .true. + logical, parameter :: conserve_physics = .not. conserve_dycore + logical, parameter :: bndry_flx_local = .not. bndry_flx_surface !=============================================================================== contains @@ -238,7 +237,7 @@ subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcol end subroutine physics_type_alloc !=============================================================================== - subroutine physics_update(state, ptend, dt, tend ) ! tht + subroutine physics_update(state, ptend, dt, tend ) !----------------------------------------------------------------------- ! Update the state and or tendency structure with the parameterization tendencies !----------------------------------------------------------------------- @@ -270,7 +269,7 @@ subroutine physics_update(state, ptend, dt, tend ) ! tht integer :: ixh, ixh2 ! constituent indices for H, H2 logical :: derive_new_geopotential ! derive new geopotential fields? - real(r8) :: te(state%psetcols,pver),t_tmp(state%psetcols,pver),pdel(state%psetcols,pver) !+tht + real(r8) :: te(state%psetcols,pver),t_tmp(state%psetcols,pver),pdel(state%psetcols,pver) real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer @@ -451,30 +450,49 @@ subroutine physics_update(state, ptend, dt, tend ) ! tht ! Update temperature from dry static energy (moved from above for WACCM-X so updating after cpairv_loc update) !------------------------------------------------------------------------------------------------------------- if(ptend%ls) then -!+tht - if(compute_enthalpy_flux) then - !use conserved energy - call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & - , cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & - , pdel(:ncol,:), te(:ncol,:)) - te(:ncol,ptend%top_level:ptend%bot_level)=te(:ncol,ptend%top_level:ptend%bot_level) & - +ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt - call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & - , te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & - , pdel(:ncol,:), t_tmp(:ncol,:)) + + if(compute_enthalpy_flux) then + !use conserved energy + call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & + , cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & + , pdel(:ncol,:), te(:ncol,:)) + te(:ncol,ptend%top_level:ptend%bot_level)=te(:ncol,ptend%top_level:ptend%bot_level) & + +ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt + call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & + , te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & + , pdel(:ncol,:), t_tmp(:ncol,:)) if (present(tend)) & - tend%dtdt(:ncol,ptend%top_level:ptend%bot_level)=tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & - (T_tmp(:ncol,ptend%top_level:ptend%bot_level) & - -state%t(:ncol,ptend%top_level:ptend%bot_level))/dt - state%T(:ncol,ptend%top_level:ptend%bot_level)=T_tmp(:ncol,ptend%top_level:ptend%bot_level) - else - do k = ptend%top_level, ptend%bot_level - state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) - if (present(tend)) & - tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) - end do - endif -!-tht + tend%dtdt(:ncol,ptend%top_level:ptend%bot_level)=tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & + (T_tmp(:ncol,ptend%top_level:ptend%bot_level) & + -state%t(:ncol,ptend%top_level:ptend%bot_level))/dt + state%T(:ncol,ptend%top_level:ptend%bot_level)=T_tmp(:ncol,ptend%top_level:ptend%bot_level) + end if + + ! if(compute_enthalpy_flux) then + ! !use conserved energy + ! call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & + ! cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & + ! pdel(:ncol,:), te(:ncol,:)) + ! te(:ncol,ptend%top_level:ptend%bot_level) = te(:ncol,ptend%top_level:ptend%bot_level) + & + ! ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt + ! call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & + ! te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & + ! pdel(:ncol,:), t_tmp(:ncol,:)) + ! if (present(tend)) then + ! tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) = tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & + ! (T_tmp(:ncol,ptend%top_level:ptend%bot_level) - & + ! state%t(:ncol,ptend%top_level:ptend%bot_level))/dt + ! end if + ! state%T(:ncol,ptend%top_level:ptend%bot_level) = T_tmp(:ncol,ptend%top_level:ptend%bot_level) + ! else + ! do k = ptend%top_level, ptend%bot_level + ! state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) + ! if (present(tend)) then + ! tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) + ! end if + ! end do + ! endif + end if ! Derive new geopotential fields if heating or water tendency not 0. @@ -609,11 +627,13 @@ subroutine physics_state_check(state, name) varname="state%te_ini", msg=msg) call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., & varname="state%te_cur", msg=msg) + !xxx make allocation dependent on if energy budget history is turned on - call shr_assert_in_domain(state%hflx_ac(:ncol,num_hflx), is_nan=.false., & - varname="state%hflx_ac", msg=msg) - call shr_assert_in_domain(state%hflx_bc(:ncol,num_hflx), is_nan=.false., & - varname="state%hflx_bc", msg=msg) + ! call shr_assert_in_domain(state%hflx_ac(:ncol,num_hflx), is_nan=.false., & + ! varname="state%hflx_ac", msg=msg) + ! call shr_assert_in_domain(state%hflx_bc(:ncol,num_hflx), is_nan=.false., & + ! varname="state%hflx_bc", msg=msg) + call shr_assert_in_domain(state%tw_ini(:ncol ), is_nan=.false., & varname="state%tw_ini", msg=msg) call shr_assert_in_domain(state%tw_cur(:ncol ), is_nan=.false., & @@ -692,10 +712,14 @@ subroutine physics_state_check(state, name) varname="state%te_ini", msg=msg) call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, & varname="state%te_cur", msg=msg) - call shr_assert_in_domain(state%hflx_ac(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & - varname="state%hflx_ac", msg=msg) - call shr_assert_in_domain(state%hflx_bc(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & - varname="state%hflx_bc", msg=msg) + + ! The following two calls result in crashes with inf when running in DEBUG mode - why + ! do these even exist since they are never used elsewhere + ! call shr_assert_in_domain(state%hflx_bc(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & + ! varname="state%hflx_bc", msg=msg) + ! call shr_assert_in_domain(state%hflx_ac(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & + ! varname="state%hflx_ac", msg=msg) + call shr_assert_in_domain(state%tw_ini(:ncol ), lt=posinf_r8, gt=neginf_r8, & varname="state%tw_ini", msg=msg) call shr_assert_in_domain(state%tw_cur(:ncol ), lt=posinf_r8, gt=neginf_r8, & @@ -1271,492 +1295,498 @@ subroutine physics_cnst_limit(state) end subroutine physics_cnst_limit !=============================================================================== -!+tht: gatekeeper module to control options for dme adjustment + + ! gatekeeper module to control options for dme adjustment subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt & - , dme_energy_adjust , step & - , ntrnprd, ntsnprd & - , tevap, tprec & - , mflx, eflx & - , eflx_out & - , mflx_out & - , ent_tnd, pdel_rf & - , dycore_is_hydrostatic) - -!use phys_control, only: phys_getopts -! 25.06.14 Added new formulation of Thomas Toniazzo (Bjerknes Centre / NORCE) -! obligate args - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in ) :: dt -! optional args - logical , optional, intent(in ) :: dme_energy_adjust - character(len=*),optional,intent(in)::step !which call in physpkg - real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer - real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer - real(r8), intent(in) , optional :: tevap (pcols) ! temperature of surface evaporation - real(r8), intent(in) , optional :: tprec (pcols) ! temperature of surface precipitation - real(r8), intent(in) , optional :: mflx (pcols) ! mass flux for use in check_energy - real(r8), intent(in) , optional :: eflx (pcols) ! energy flux for use in check_energy - real(r8), intent(out), optional :: ent_tnd (pcols) ! column-integrated enthalpy tendency - real(r8), intent(out), optional :: pdel_rf (pcols,pver)! ratio old pdel / new pdel - logical , intent(in) , optional :: dycore_is_hydrostatic - - real(r8), intent(out), optional :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out), optional :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) -! local work space - integer :: ncol,icol + , dme_energy_adjust , step & + , ntrnprd, ntsnprd & + , tevap, tprec & + , mflx, eflx & + , eflx_out & + , mflx_out & + , ent_tnd, pdel_rf & + , dycore_is_hydrostatic) + + !use phys_control, only: phys_getopts + ! 25.06.14 Added new formulation of Thomas Toniazzo (Bjerknes Centre / NORCE) + ! obligate args + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in ) :: dt + ! optional args + logical , optional, intent(in ) :: dme_energy_adjust + character(len=*),optional,intent(in)::step !which call in physpkg + real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer + real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer + real(r8), intent(in) , optional :: tevap (pcols) ! temperature of surface evaporation + real(r8), intent(in) , optional :: tprec (pcols) ! temperature of surface precipitation + real(r8), intent(in) , optional :: mflx (pcols) ! mass flux for use in check_energy + real(r8), intent(in) , optional :: eflx (pcols) ! energy flux for use in check_energy + real(r8), intent(out), optional :: ent_tnd (pcols) ! column-integrated enthalpy tendency + real(r8), intent(out), optional :: pdel_rf (pcols,pver)! ratio old pdel / new pdel + logical , intent(in) , optional :: dycore_is_hydrostatic + + real(r8), intent(out), optional :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out), optional :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + ! local work space + integer :: ncol,icol !real(r8) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8) :: tevp (pcols) ! temperature for surface evaporation - real(r8) :: tprc (pcols) ! temperature for precipitation at surface - real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" - real(r8) :: mdq (pcols,pver) ! total water tendency - logical :: hydrostatic =.true. - real(r8), parameter :: rtiny = 1e-04_r8 ! a small number (relative to total q change) - - - if(present(dycore_is_hydrostatic)) hydrostatic =dycore_is_hydrostatic - - if (present(dme_energy_adjust)) then - if (dme_energy_adjust) then - - if(present(tevap))then - tevp=tevap - else - tevp(:ncol)=state%t(:ncol,pver) - endif - if(present(tprec))then - tprc=tprec - else - tprc(:ncol)=state%t(:ncol,pver) - endif - - if (present(ntrnprd).and.present(ntsnprd)) then ! use physics (ZM+MG) precip production rates - if (present(eflx).and.present(mflx)) then ! also correct to match prescribed surface enthalpy flux - call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & - , htx_cond, mdq, step & - , ntrnprd=ntrnprd, ntsnprd=ntsnprd & - , mflx=mflx, eflx=eflx & - , eflx_out=eflx_out, mflx_out=mflx_out) - else - call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & - , htx_cond, mdq, step & - , ntrnprd=ntrnprd, ntsnprd=ntsnprd & - , eflx_out=eflx_out , mflx_out=mflx_out) - endif - else - call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & - , htx_cond, mdq, step & - , eflx_out=eflx_out, mflx_out=mflx_out) - endif - call physics_dme_adjust_THT(state, tend, dt & - , qini, liqini, iceini, htx_cond, mdq, step & - , ent_tnd=ent_tnd , pdel_rf=pdel_rf & - , hydrostatic=hydrostatic) - else + real(r8) :: tevp (pcols) ! temperature for surface evaporation + real(r8) :: tprc (pcols) ! temperature for precipitation at surface + real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" + real(r8) :: mdq (pcols,pver) ! total water tendency + logical :: hydrostatic =.true. + real(r8), parameter :: rtiny = 1e-04_r8 ! a small number (relative to total q change) + + + if(present(dycore_is_hydrostatic)) then + hydrostatic = dycore_is_hydrostatic + end if + + if (present(dme_energy_adjust)) then + if (dme_energy_adjust) then + + if(present(tevap))then + tevp=tevap + else + tevp(:ncol)=state%t(:ncol,pver) + endif + if(present(tprec))then + tprc=tprec + else + tprc(:ncol)=state%t(:ncol,pver) + endif + + if (present(ntrnprd).and.present(ntsnprd)) then ! use physics (ZM+MG) precip production rates + if (present(eflx).and.present(mflx)) then ! also correct to match prescribed surface enthalpy flux + call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & + , htx_cond, mdq, step & + , ntrnprd=ntrnprd, ntsnprd=ntsnprd & + , mflx=mflx, eflx=eflx & + , eflx_out=eflx_out, mflx_out=mflx_out) + else + call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & + , htx_cond, mdq, step & + , ntrnprd=ntrnprd, ntsnprd=ntsnprd & + , eflx_out=eflx_out , mflx_out=mflx_out) + endif + else + call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & + , htx_cond, mdq, step & + , eflx_out=eflx_out, mflx_out=mflx_out) + endif + call physics_dme_adjust_THT(state, tend, dt & + , qini, liqini, iceini, htx_cond, mdq, step & + , ent_tnd=ent_tnd , pdel_rf=pdel_rf & + , hydrostatic=hydrostatic) + else ! not present dme_energy_adjust if (present(ent_tnd)) ent_tnd (:)=0._r8 call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) - end if + end if - else - if (present(ent_tnd)) ent_tnd (:)=0._r8 - call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) - end if + else ! not present dme_energy_adjust - end subroutine physics_dme_adjust -!-tht -!+tht dme_energy_adjust code: -!----------------------------------------------------------------------- - subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq & - , step , eflx_out , mflx_out & - , ntrnprd, ntsnprd & - , mflx, eflx) - - use air_composition, only: dry_air_species_num & - ,thermodynamic_active_species_idx & - ,thermodynamic_active_species_liq_idx & - ,thermodynamic_active_species_ice_idx & - ,thermodynamic_active_species_num & - ,thermodynamic_active_species_liq_num & - ,thermodynamic_active_species_ice_num & - ,cpairv, cp_or_cv_dycore - use constituents, only: cnst_get_type_byind, cnst_get_ind - use physconst, only: cpair, cpwv, cpliq, cpice, tmelt - use air_composition, only: t00a, h00a - use hycoef, only: hyai, hybi, ps0, hyam, hybm - use cam_thermo, only: inv_conserved_energy, get_conserved_energy & - ,cam_thermo_water_update - use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure + if (present(ent_tnd)) ent_tnd (:)=0._r8 + call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) - !----------------------------------------------------------------------- - ! - ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to - ! atmospheric moisture change - ! - ! Method - ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) - ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, - ! CONDEPS, and a matching heat exchange betweeen air and condensated - ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). - ! Choice 2. is taken with dme_ ohf_adjust=.true. For CONDEPS then the following - ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS - ! cpcond is a parameter representing the heat capacity of the condensate phase. - ! The heating rates and enthalpy boundary fluxes are not applied here, - ! they are intended to be passed to dme_adjust. - ! - ! Author: Thomas Toniazzo (17.07.21) - ! - !----------------------------------------------------------------------- - - implicit none - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in ) :: tevp (pcols) ! temperature of evaporation at bottom of atmo - real(r8), intent(in ) :: tprc (pcols) ! temperature of precipitation at bottom of atmo - real(r8), intent(in ) :: dt ! model physics timestep - real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust - real(r8), intent(out ) :: mdq (pcols,pver) ! total water increment for dme_adjust - character(len=*),optional,intent(in)::step !which call in physpkg - real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer - real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer - real(r8), intent(in) , optional :: eflx (pcols) ! input : boundary enthalpy flux - real(r8), intent(in) , optional :: mflx (pcols) ! input : boundary mass flux - - !---------------------------Local workspace----------------------------- - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i,k,m, ixq ! Longitude, level indices - integer :: ierr ! error flag - - real(r8) :: fdq (pcols) ! mass adjustment factor - - real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values - - real(r8) :: dcvap(pcols) ! total column vapour change - real(r8) :: dcliq(pcols) ! total column liquid change - real(r8) :: dcice(pcols) ! total column ice change - real(r8) :: dcwat(pcols) ! total column water change - real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) - - real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - - real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) - real(r8) :: tot_water_chg(pcols) ! work array: total water change - integer :: m_cnst - - real(r8) :: ps_old(pcols) ! old surface pressure - - real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - real(r8) :: dvap (pcols,pver) ! wv mass adjustment - real(r8) :: dliq (pcols,pver) ! liq mass adjustment - real(r8) :: dice (pcols,pver) ! ice mass adjustment - real(r8) :: dprat (pcols) ! Dp'/Dp'' (=1 in lagrangean adj) - - real(r8) :: mdqr (pcols,pver) ! residual mass change (work array) - real(r8) :: dcqm (pcols) ! fraction of total/absolute mass change - - real(r8) :: te (pcols,pver) ! conserved energy in layer - real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm (pcols,pver) ! (phi-phis)/g - real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) - real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes - real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes - real(r8) :: condmox_ref(pcols,pver) ! local specific x-momentum of "condensates" (mass source) - real(r8) :: condmox (pcols,pver) ! specific x-momentum of moist reservoir with which q is exchanged - real(r8) :: condmoy_ref(pcols,pver) ! local specific y-momentum of "condensates" (mass source) - real(r8) :: condmoy (pcols,pver) ! specific y-momentum of moist reservoir with which q is exchanged - - real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp - - real(r8) :: uf(pcols), vf(pcols) ! work arrays - - real(r8) :: pint_old(pcols,pver+1)! work array - !real(r8) :: tbot(pcols) ! work array - real(r8) :: dummy(pcols,pver) ! work array - - integer :: is_invalid(pcols) - logical , parameter :: conserve = conserve_dycore .or. conserve_physics - real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) - -! set to T to use distribute implied heating over column section to the surface - logical, parameter :: l_nolocdcpttend=.true. - - logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot - - if (state%psetcols .ne. pcols) then - call endrun('physics_dme_bflx: cannot pass in a state which has sub-columns') - end if + end if - lchnk = state%lchnk - ncol = state%ncol - - ! store old pressure - ps_old (:ncol) = state%ps(:ncol) - pint_old(:ncol,:) = state%pint(:ncol,:) + ! dme_energy_adjust code: + end subroutine physics_dme_adjust - zm(:ncol,:)=state%zm(:ncol,:) +!=============================================================================== - ! get local specific enthalpy, excluding latent heats - if (conserve_dycore) then - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cp_or_cv_dycore(:ncol,:,lchnk) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,te(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & - ,vcoord=vc_dycore ,refstate='liq' & - ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq & + , step , eflx_out , mflx_out & + , ntrnprd, ntsnprd & + , mflx, eflx) + + use air_composition, only: dry_air_species_num & + ,thermodynamic_active_species_idx & + ,thermodynamic_active_species_liq_idx & + ,thermodynamic_active_species_ice_idx & + ,thermodynamic_active_species_num & + ,thermodynamic_active_species_liq_num & + ,thermodynamic_active_species_ice_num & + ,cpairv, cp_or_cv_dycore + use constituents, only: cnst_get_type_byind, cnst_get_ind + use physconst, only: cpair, cpwv, cpliq, cpice, tmelt + use air_composition, only: t00a, h00a + use hycoef, only: hyai, hybi, ps0, hyam, hybm + use cam_thermo, only: inv_conserved_energy, get_conserved_energy & + ,cam_thermo_water_update + use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure + + !----------------------------------------------------------------------- + ! + ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to + ! atmospheric moisture change + ! + ! Method + ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) + ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, + ! CONDEPS, and a matching heat exchange betweeen air and condensated + ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). + ! Choice 2. is taken with dme_ ohf_adjust=.true. For CONDEPS then the following + ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS + ! cpcond is a parameter representing the heat capacity of the condensate phase. + ! The heating rates and enthalpy boundary fluxes are not applied here, + ! they are intended to be passed to dme_adjust. + ! + ! Author: Thomas Toniazzo (17.07.21) + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in ) :: tevp (pcols) ! temperature of evaporation at bottom of atmo + real(r8), intent(in ) :: tprc (pcols) ! temperature of precipitation at bottom of atmo + real(r8), intent(in ) :: dt ! model physics timestep + real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust + real(r8), intent(out ) :: mdq (pcols,pver) ! total water increment for dme_adjust + character(len=*),optional,intent(in)::step !which call in physpkg + real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer + real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer + real(r8), intent(in) , optional :: eflx (pcols) ! input : boundary enthalpy flux + real(r8), intent(in) , optional :: mflx (pcols) ! input : boundary mass flux + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k,m, ixq ! Longitude, level indices + integer :: ierr ! error flag + + real(r8) :: fdq (pcols) ! mass adjustment factor + + real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values + + real(r8) :: dcvap(pcols) ! total column vapour change + real(r8) :: dcliq(pcols) ! total column liquid change + real(r8) :: dcice(pcols) ! total column ice change + real(r8) :: dcwat(pcols) ! total column water change + real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) + + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + + real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) + real(r8) :: tot_water_chg(pcols) ! work array: total water change + integer :: m_cnst + + real(r8) :: ps_old(pcols) ! old surface pressure + + real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) + real(r8) :: dvap (pcols,pver) ! wv mass adjustment + real(r8) :: dliq (pcols,pver) ! liq mass adjustment + real(r8) :: dice (pcols,pver) ! ice mass adjustment + real(r8) :: dprat (pcols) ! Dp'/Dp'' (=1 in lagrangean adj) + + real(r8) :: mdqr (pcols,pver) ! residual mass change (work array) + real(r8) :: dcqm (pcols) ! fraction of total/absolute mass change + + real(r8) :: te (pcols,pver) ! conserved energy in layer + real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm (pcols,pver) ! (phi-phis)/g + real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) + real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes + real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes + real(r8) :: condmox_ref(pcols,pver) ! local specific x-momentum of "condensates" (mass source) + real(r8) :: condmox (pcols,pver) ! specific x-momentum of moist reservoir with which q is exchanged + real(r8) :: condmoy_ref(pcols,pver) ! local specific y-momentum of "condensates" (mass source) + real(r8) :: condmoy (pcols,pver) ! specific y-momentum of moist reservoir with which q is exchanged + + real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp + + real(r8) :: uf(pcols), vf(pcols) ! work arrays + + real(r8) :: pint_old(pcols,pver+1)! work array + !real(r8) :: tbot(pcols) ! work array + real(r8) :: dummy(pcols,pver) ! work array + + integer :: is_invalid(pcols) + logical , parameter :: conserve = conserve_dycore .or. conserve_physics + real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) + + ! set to T to use distribute implied heating over column section to the surface + logical, parameter :: l_nolocdcpttend=.true. + + logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_bflx: cannot pass in a state which has sub-columns') + end if + + lchnk = state%lchnk + ncol = state%ncol + + ! store old pressure + ps_old (:ncol) = state%ps(:ncol) + pint_old(:ncol,:) = state%pint(:ncol,:) + + zm(:ncol,:)=state%zm(:ncol,:) + + ! get local specific enthalpy, excluding latent heats + if (conserve_dycore) then + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cp_or_cv_dycore(:ncol,:,lchnk) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,te(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & + ,vcoord=vc_dycore ,refstate='liq' & + ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) else - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cpairv(:ncol,:,lchnk) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,te(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & - ,refstate='liq' & - ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) - endif + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cpairv(:ncol,:,lchnk) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,te(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & + ,refstate='liq' & + ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + endif - call cnst_get_ind('Q', ixq) - ! change in water - dcvap(:ncol)=0._r8 - dcliq(:ncol)=0._r8 - dcice(:ncol)=0._r8 - dcwat(:ncol)=0._r8 - ! heat associated with cp change - do k = 1, pver - ! mass increments Dp'/Dp - tot_water(:ncol,1) = qini(:ncol,k)+liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O - tot_water(:ncol,2) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) - end do - mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) + call cnst_get_ind('Q', ixq) + ! change in water + dcvap(:ncol)=0._r8 + dcliq(:ncol)=0._r8 + dcice(:ncol)=0._r8 + dcwat(:ncol)=0._r8 + ! heat associated with cp change + do k = 1, pver + ! mass increments Dp'/Dp + tot_water(:ncol,1) = qini(:ncol,k)+liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O + tot_water(:ncol,2) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) + end do + mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) - dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) - dliq(:ncol,k) = -liqini(:ncol,k) - do m_cnst=1,thermodynamic_active_species_liq_num - m = thermodynamic_active_species_liq_idx(m_cnst) - dliq(:ncol,k) = dliq(:ncol,k)+state%q(:ncol,k,m) - end do - dice(:ncol,k) = -iceini(:ncol,k) - do m_cnst=1,thermodynamic_active_species_ice_num - m = thermodynamic_active_species_ice_idx(m_cnst) - dice(:ncol,k) = dice(:ncol,k)+state%q(:ncol,k,m) - end do + dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) + dliq(:ncol,k) = -liqini(:ncol,k) + do m_cnst=1,thermodynamic_active_species_liq_num + m = thermodynamic_active_species_liq_idx(m_cnst) + dliq(:ncol,k) = dliq(:ncol,k)+state%q(:ncol,k,m) + end do + dice(:ncol,k) = -iceini(:ncol,k) + do m_cnst=1,thermodynamic_active_species_ice_num + m = thermodynamic_active_species_ice_idx(m_cnst) + dice(:ncol,k) = dice(:ncol,k)+state%q(:ncol,k,m) + end do - dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state%pdel(:ncol,k)/gravit - dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state%pdel(:ncol,k)/gravit - dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state%pdel(:ncol,k)/gravit - dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state%pdel(:ncol,k)/gravit + dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state%pdel(:ncol,k)/gravit + dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state%pdel(:ncol,k)/gravit + dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state%pdel(:ncol,k)/gravit + dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state%pdel(:ncol,k)/gravit - end do + end do - is_invalid(:ncol)=0 - if (present(mflx)) then - if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then - k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) - if (masterproc.and.logorrhoic) & ! for testing - print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) - endif - where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) - is_invalid(:ncol)=1 - endwhere - if (maxval(is_invalid(:ncol)).gt.0) then - k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) - if (abs(eflx(k)).gt.rtiny) then - if (masterproc.and.logorrhoic) & ! for testing - print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) + is_invalid(:ncol)=0 + if (present(mflx)) then + if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then + k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) + if (masterproc.and.logorrhoic) & ! for testing + print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) endif - endif - endif + where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) + is_invalid(:ncol)=1 + endwhere + if (maxval(is_invalid(:ncol)).gt.0) then + k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) + if (abs(eflx(k)).gt.rtiny) then + if (masterproc.and.logorrhoic) & ! for testing + print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) + endif + endif + endif - ! local specific enthalpy - if (conserve) then - do k = 1, pver - condeps_ref(:ncol,k) = te(:ncol,k) +emce(:ncol,k) - enddo - else - condeps_ref(:ncol,:) = 0._r8 - endif + ! local specific enthalpy + if (conserve) then + do k = 1, pver + condeps_ref(:ncol,k) = te(:ncol,k) +emce(:ncol,k) + enddo + else + condeps_ref(:ncol,:) = 0._r8 + endif - ! exchange specific enthalpies, incremental - if (conserve .and. present(ntrnprd) .and. present(ntsnprd)) then ! we can partition between source and destination - dcwatr (:ncol) = 0._r8 - do k=1,pver - mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change - if (conserve_physics.or..not.l_nolocdcpttend) then - condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) - else if (conserve_dycore) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq (:ncol,k) - condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) - endif - if (bndry_flx_surface) then - condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntsnprd(:ncol,k) - condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state%phis(:ncol)+(cpliq*t00a+h00a)) - else if (bndry_flx_local) then - if (conserve_dycore) then - condepsf(:ncol,k) =-(cpliq*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntsnprd(:ncol,k) - condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(state%t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state%phis(:ncol)+(cpliq*t00a+h00a)) - else if (conserve_physics) then - condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) - condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) - endif - endif - ! residual column water change: integrates to surface evaporation - dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit - enddo - else - mdqr (:ncol,:)=mdq (:ncol,:) - dcwatr (:ncol) =dcwat(:ncol) - condepsf(:ncol,:)=0._r8 - condepss(:ncol,:)=0._r8 - do k=1,pver - if (conserve_physics.or..not.l_nolocdcpttend) then - condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) - else if (conserve_dycore ) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq(:ncol,k) - condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) - endif - if (bndry_flx_surface) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state%phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) - condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) - else if (bndry_flx_local) then - condepsf(:ncol,k) = condepss(:ncol,k) - if (conserve_dycore .and.l_nolocdcpttend) & - condepsf(:ncol,k) = condepsf(:ncol,k)+((cpliq-cpair)*t00a+h00a)*mdq(:ncol,k) - endif - enddo - endif + ! exchange specific enthalpies, incremental + if (conserve .and. present(ntrnprd) .and. present(ntsnprd)) then ! we can partition between source and destination + dcwatr (:ncol) = 0._r8 + do k=1,pver + mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change + if (conserve_physics.or..not.l_nolocdcpttend) then + condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) + else if (conserve_dycore) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice + condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq (:ncol,k) + condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) + endif + if (bndry_flx_surface) then + condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) + condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state%phis(:ncol)+(cpliq*t00a+h00a)) + else if (bndry_flx_local) then + if (conserve_dycore) then + condepsf(:ncol,k) = -(cpliq*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = condepsf(:ncol,k) - & + (ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) + condepsf(:ncol,k) = condepsf(:ncol,k) + & + mdqr(:ncol,k)*(cpwv*(state%t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state%phis(:ncol)+(cpliq*t00a+h00a)) + else if (conserve_physics) then + condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) + condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) + endif + endif + ! residual column water change: integrates to surface evaporation + dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + enddo + else + mdqr (:ncol,:)=mdq (:ncol,:) + dcwatr (:ncol) =dcwat(:ncol) + condepsf(:ncol,:)=0._r8 + condepss(:ncol,:)=0._r8 + do k=1,pver + if (conserve_physics.or..not.l_nolocdcpttend) then + condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) + else if (conserve_dycore ) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice + condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq(:ncol,k) + condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) + endif + if (bndry_flx_surface) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice + condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state%phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) + condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) + else if (bndry_flx_local) then + condepsf(:ncol,k) = condepss(:ncol,k) + if (conserve_dycore .and.l_nolocdcpttend) & + condepsf(:ncol,k) = condepsf(:ncol,k)+((cpliq-cpair)*t00a+h00a)*mdq(:ncol,k) + endif + enddo + endif - if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match - ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR - eflx_out(:ncol ) = eflx(:ncol)*dt - do k = 1, pver - where(is_invalid(:ncol).eq.0) - eflx_out(:ncol) = eflx_out(:ncol) - state%pdel(:ncol,k)/gravit*condepsf(:ncol,k) - elsewhere - eflx_out(:ncol) = 0._r8 - endwhere - enddo - dcqm(:ncol)=0._r8 - do k=1,pver - where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match + ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR + eflx_out(:ncol ) = eflx(:ncol)*dt + do k = 1, pver + where(is_invalid(:ncol).eq.0) + eflx_out(:ncol) = eflx_out(:ncol) - state%pdel(:ncol,k)/gravit*condepsf(:ncol,k) + elsewhere + eflx_out(:ncol) = 0._r8 + endwhere + enddo + dcqm(:ncol)=0._r8 + do k=1,pver + where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) + dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + endwhere + enddo + where(abs(dcwatr(:ncol)).gt.rtiny) + dcqm(:ncol)=dcwatr(:ncol)/dcqm(:ncol) + elsewhere + dcqm(:ncol)=0._r8 endwhere - enddo - where(abs(dcwatr(:ncol)).gt.rtiny) - dcqm(:ncol)=dcwatr(:ncol)/dcqm(:ncol) - elsewhere - dcqm(:ncol)=0._r8 - endwhere - do k=1,pver - where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) - endwhere - where(is_invalid(:ncol).eq.1) - condepsf(:ncol,k) = 0._r8 - endwhere - enddo - endif - - ! boundary flux of energy due to mass sources (diagnostic) - mflx_out(:ncol ) = 0._r8 - do k = 1, pver - where( is_invalid(:ncol).eq.0) - ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - mflx_out(:ncol) = mflx_out(:ncol) + state%pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt - endwhere - enddo + do k=1,pver + where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) + condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) + endwhere + where(is_invalid(:ncol).eq.1) + condepsf(:ncol,k) = 0._r8 + endwhere + enddo + endif - ! boundary flux of energy due to mass sources (diagnostic) - eflx_out(:ncol ) = 0._r8 - do k = 1, pver - where( is_invalid(:ncol).eq.0) - ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - eflx_out(:ncol) = eflx_out(:ncol) + state%pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt - endwhere - enddo + ! boundary flux of energy due to mass sources (diagnostic) + mflx_out(:ncol ) = 0._r8 + do k = 1, pver + where( is_invalid(:ncol).eq.0) + ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) + mflx_out(:ncol) = mflx_out(:ncol) + state%pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt + endwhere + enddo - ! make local specific enthalpy incremental - if (conserve) then - do k = 1, pver - condeps_ref(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) - enddo - endif + ! boundary flux of energy due to mass sources (diagnostic) + eflx_out(:ncol ) = 0._r8 + do k = 1, pver + where( is_invalid(:ncol).eq.0) + ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) + eflx_out(:ncol) = eflx_out(:ncol) + state%pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt + endwhere + enddo - ! new surface pressure - state%ps(:ncol) = state%pint(:ncol,1) - do k = 1, pver - state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - end do + ! make local specific enthalpy incremental + if (conserve) then + do k = 1, pver + condeps_ref(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) + enddo + endif - ! heat exchange with condensates - htx_cond(:ncol,:) = 0._r8 - do k = 1, pver - do i=1,ncol - if(l_nolocdcpttend)then - ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below - if(k.eq.1) then - condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) - else - condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & - +condepsf(i,k-1) - endif - else - condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) - endif - htx_cond(i,k) = condepsf(i,k) & - ! diff. between LOCAL enthalpy and reference enthalpy is applied locally - +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) - enddo + ! new surface pressure + state%ps(:ncol) = state%pint(:ncol,1) + do k = 1, pver + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + end do - pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + ! heat exchange with condensates + htx_cond(:ncol,:) = 0._r8 + do k = 1, pver + do i=1,ncol + if(l_nolocdcpttend)then + ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below + if(k.eq.1) then + condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & + *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) + else + condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & + *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & + +condepsf(i,k-1) + endif + else + condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) + endif + htx_cond(i,k) = condepsf(i,k) & + ! diff. between LOCAL enthalpy and reference enthalpy is applied locally + +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) + enddo + + pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - ! compute new total pressure variables - state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) + ! compute new total pressure variables + state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) - end do + end do - ! original pressure - state%ps (:ncol) = ps_old (:ncol) - state%pint(:ncol,:) = pint_old(:ncol,:) + ! original pressure + state%ps (:ncol) = ps_old (:ncol) + state%pint(:ncol,:) = pint_old(:ncol,:) end subroutine physics_dme_bflx !----------------------------------------------------------------------- subroutine physics_dme_adjust_THT(state, tend, dt & -,qini,liqini,iceini & + , qini,liqini,iceini & , htx_cond , mdq, step & , ent_tnd, pdel_rf & , hydrostatic ) @@ -1799,7 +1829,6 @@ subroutine physics_dme_adjust_THT(state, tend, dt & ! !----------------------------------------------------------------------- - implicit none ! ! Arguments @@ -2228,8 +2257,8 @@ subroutine physics_state_copy(state_in, state_out) end do state_out%te_ini (:ncol,:) = state_in%te_ini (:ncol,:) state_out%te_cur (:ncol,:) = state_in%te_cur (:ncol,:) - state_out%hflx_ac(:ncol,:) = state_in%hflx_ac(:ncol,:) - state_out%hflx_bc(:ncol,:) = state_in%hflx_bc(:ncol,:) + ! state_out%hflx_ac(:ncol,:) = state_in%hflx_ac(:ncol,:) + ! state_out%hflx_bc(:ncol,:) = state_in%hflx_bc(:ncol,:) state_out%tw_ini (:ncol ) = state_in%tw_ini (:ncol ) state_out%tw_cur (:ncol ) = state_in%tw_cur (:ncol ) @@ -2544,11 +2573,10 @@ subroutine physics_state_alloc(state,lchnk,psetcols) allocate(state%te_cur(psetcols,2), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur') - allocate(state%hflx_ac(psetcols,num_hflx), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_ac') - - allocate(state%hflx_bc(psetcols,num_hflx), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_bc') + ! allocate(state%hflx_ac(psetcols,num_hflx), stat=ierr) + ! if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_ac') + ! allocate(state%hflx_bc(psetcols,num_hflx), stat=ierr) + ! if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_bc') allocate(state%tw_ini(psetcols ), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini') @@ -2603,8 +2631,8 @@ subroutine physics_state_alloc(state,lchnk,psetcols) state%te_ini (:,:) = inf state%te_cur (:,:) = inf - state%hflx_ac (:,:) = inf - state%hflx_bc (:,:) = inf + ! state%hflx_ac (:,:) = inf + ! state%hflx_bc (:,:) = inf state%tw_ini (: ) = inf state%tw_cur (: ) = inf state%temp_ini(:,:) = inf @@ -2711,11 +2739,10 @@ subroutine physics_state_dealloc(state) deallocate(state%te_cur, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur') - deallocate(state%hflx_ac, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_ac') - - deallocate(state%hflx_bc, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_bc') + ! deallocate(state%hflx_ac, stat=ierr) + ! if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_ac') + ! deallocate(state%hflx_bc, stat=ierr) + ! if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_bc') deallocate(state%tw_ini, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini') diff --git a/src/physics/camnor_phys/physics/physpkg.F90 b/src/physics/camnor_phys/physics/physpkg.F90 deleted file mode 100644 index 8471ac9e5e..0000000000 --- a/src/physics/camnor_phys/physics/physpkg.F90 +++ /dev/null @@ -1,3177 +0,0 @@ -module physpkg - !----------------------------------------------------------------------- - ! Purpose: - ! - ! Provides the interface to CAM physics package - ! - ! Module contains reordered physics to accomodate CLUBB - ! Modified after original physpkg module, Dec 2021, A. Herrington - !----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use physconst, only: latvap, latice - use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & - physics_ptend, physics_tend_init, physics_update, & - physics_type_alloc, physics_ptend_dealloc,& - physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc - use phys_grid, only: get_ncols_p - use phys_gmean, only: gmean_mass - use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols - use constituents, only: pcnst, cnst_name, cnst_get_ind - use camsrfexch, only: cam_out_t, cam_in_t - - use phys_control, only: use_hemco ! Use Harmonized Emissions Component (HEMCO) - - use cam_control_mod, only: ideal_phys, adiabatic - use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is - use scamMod, only: single_column, scm_crm_mode - use flux_avg, only: flux_avg_init - use perf_mod - 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 - - implicit none - private - save - - ! Public methods - public phys_register ! was initindx - register physics methods - public phys_init ! Public initialization method - public phys_run1 ! First phase of the public run method - public phys_run2 ! Second phase of the public run method - public phys_final ! Public finalization method - - ! Private module data - - ! Physics package options - character(len=16) :: shallow_scheme - character(len=16) :: macrop_scheme - character(len=16) :: microp_scheme - character(len=16) :: subcol_scheme - character(len=32) :: cam_take_snapshot_before ! Physics routine to take a snapshot "before" - character(len=32) :: cam_take_snapshot_after ! Physics routine to take a snapshot "after" - integer :: cld_macmic_num_steps ! Number of macro/micro substeps - integer :: cam_snapshot_before_num ! tape number for before snapshots - integer :: cam_snapshot_after_num ! tape number for after snapshots - logical :: do_clubb_sgs - logical :: use_subcol_microp ! if true, use subcolumns in microphysics - logical :: state_debug_checks ! Debug physics_state. - logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols - logical :: prog_modal_aero ! Prognostic modal aerosols present - - ! Physics buffer index - integer :: teout_idx = 0 - - integer :: landm_idx = 0 - integer :: sgh_idx = 0 - integer :: sgh30_idx = 0 - - integer :: qini_idx = 0 - integer :: cldliqini_idx = 0 - integer :: cldiceini_idx = 0 - integer :: totliqini_idx = 0 - integer :: toticeini_idx = 0 - - integer :: enthalpy_prec_bc_idx = 0 - integer :: enthalpy_prec_ac_idx = 0 - integer :: enthalpy_evop_idx = 0 - integer :: qcsedten_idx=0, qrsedten_idx=0 - integer :: qisedten_idx=0, qssedten_idx=0, qgsedten_idx=0 - integer :: qrain_mg_idx=0, qsnow_mg_idx=0 - - integer :: prec_str_idx = 0 - integer :: snow_str_idx = 0 - integer :: prec_sed_idx = 0 - integer :: snow_sed_idx = 0 - integer :: prec_pcw_idx = 0 - integer :: snow_pcw_idx = 0 - integer :: prec_dp_idx = 0 - integer :: snow_dp_idx = 0 - integer :: prec_sh_idx = 0 - integer :: snow_sh_idx = 0 - integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. - integer :: ducore_idx = 0 ! ducore index in physics buffer - integer :: dvcore_idx = 0 ! dvcore index in physics buffer - integer :: dtcore_idx = 0 ! dtcore index in physics buffer - integer :: dqcore_idx = 0 ! dqcore index in physics buffer - integer :: cmfmczm_idx = 0 ! Zhang-McFarlane convective mass fluxes - integer :: rliqbc_idx = 0 ! tphysbc reserve liquid - integer :: psl_idx = 0 -!======================================================================= -contains -!======================================================================= - - subroutine phys_register - !----------------------------------------------------------------------- - ! - ! Purpose: Register constituents and physics buffer fields. - ! - ! Author: CSM Contact: M. Vertenstein, Aug. 1997 - ! B.A. Boville, Oct 2001 - ! A. Gettelman, Nov 2010 - put micro/macro physics into separate routines - ! - !----------------------------------------------------------------------- - use cam_abortutils, only: endrun - use physics_buffer, only: pbuf_init_time, pbuf_cam_snapshot_register - use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol - use constituents, only: cnst_add, cnst_chk_dim - - use cam_control_mod, only: moist_physics - use chemistry, only: chem_register - use mo_lightning, only: lightning_register - use cloud_fraction, only: cldfrc_register - use microp_driver, only: microp_driver_register - use microp_aero, only: microp_aero_register - ! OSLO_AERO begin - use oslo_aero_microp, only: oslo_aero_microp_register - ! OSLO_AERO end - use macrop_driver, only: macrop_driver_register - use clubb_intr, only: clubb_register_cam - use conv_water, only: conv_water_register - use physconst, only: mwh2o, cpwv - use tracers, only: tracers_register - use check_energy, only: check_energy_register - use carma_intr, only: carma_register - use ghg_data, only: ghg_data_register - use vertical_diffusion, only: vd_register - use convect_deep, only: convect_deep_register - use convect_diagnostics,only: convect_diagnostics_register - use radiation, only: radiation_register - use co2_cycle, only: co2_register - use flux_avg, only: flux_avg_register - use iondrag, only: iondrag_register - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_reg - use prescribed_ozone, only: prescribed_ozone_register - use prescribed_volcaero,only: prescribed_volcaero_register - use prescribed_strataero,only: prescribed_strataero_register - use prescribed_aero, only: prescribed_aero_register - use prescribed_ghg, only: prescribed_ghg_register - use aoa_tracers, only: aoa_tracers_register - use aircraft_emit, only: aircraft_emit_register - use cam_diagnostics, only: diag_register - use cloud_diagnostics, only: cloud_diagnostics_register - use cospsimulator_intr, only: cospsimulator_intr_register - use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not - use radheat, only: radheat_register - use subcol, only: subcol_register - use subcol_utils, only: is_subcol_on, subcol_get_scheme - use dyn_comp, only: dyn_register - use offline_driver, only: offline_driver_reg - use hemco_interface, only: HCOI_Chunk_Init - use surface_emissions_mod, only: surface_emissions_reg - use elevated_emissions_mod, only: elevated_emissions_reg - - use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars - - !---------------------------Local variables----------------------------- - ! - integer :: m ! loop index - integer :: mm ! constituent index - integer :: nmodes - !----------------------------------------------------------------------- - - ! Get physics options - call phys_getopts(shallow_scheme_out = shallow_scheme, & - macrop_scheme_out = macrop_scheme, & - microp_scheme_out = microp_scheme, & - cld_macmic_num_steps_out = cld_macmic_num_steps, & - do_clubb_sgs_out = do_clubb_sgs, & - use_subcol_microp_out = use_subcol_microp, & - state_debug_checks_out = state_debug_checks, & - cam_take_snapshot_before_out= cam_take_snapshot_before, & - cam_take_snapshot_after_out = cam_take_snapshot_after, & - cam_snapshot_before_num_out = cam_snapshot_before_num, & - cam_snapshot_after_num_out = cam_snapshot_after_num) - - subcol_scheme = subcol_get_scheme() - - ! Initialize dyn_time_lvls - call pbuf_init_time() - - ! Register the subcol scheme - call subcol_register() - - ! Register water vapor. - ! ***** N.B. ***** This must be the first call to cnst_add so that - ! water vapor is constituent 1. - if (moist_physics) then - call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & - longname='Specific humidity', readiv=.true., is_convtran1=.true.) - else - call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & - longname='Specific humidity', readiv=.false., is_convtran1=.true.) - end if - - ! Topography file fields. - call pbuf_add_field('LANDM', 'global', dtype_r8, (/pcols/), landm_idx) - call pbuf_add_field('SGH', 'global', dtype_r8, (/pcols/), sgh_idx) - call pbuf_add_field('SGH30', 'global', dtype_r8, (/pcols/), sgh30_idx) - - ! Fields for physics package diagnostics - call pbuf_add_field('QINI', 'physpkg', dtype_r8, (/pcols,pver/), qini_idx) - call pbuf_add_field('CLDLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), cldliqini_idx) - call pbuf_add_field('CLDICEINI', 'physpkg', dtype_r8, (/pcols,pver/), cldiceini_idx) - call pbuf_add_field('TOTLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), totliqini_idx) - call pbuf_add_field('TOTICEINI', 'physpkg', dtype_r8, (/pcols,pver/), toticeini_idx) - - if (compute_enthalpy_flux) then - call pbuf_add_field('ENTHALPY_PREC_BC','physpkg', dtype_r8, (/pcols,num_enthalpy_vars/), enthalpy_prec_bc_idx) - call pbuf_add_field('ENTHALPY_PREC_AC','global' , dtype_r8, (/pcols,num_enthalpy_vars/), enthalpy_prec_ac_idx) - call pbuf_add_field('ENTHALPY_EVOP' ,'global' , dtype_r8, (/pcols/), enthalpy_evop_idx) - call pbuf_add_field('qrain_mg' , 'physpkg', dtype_r8, (/pcols,pver/), qrain_mg_idx) - call pbuf_add_field('qsnow_mg' , 'physpkg', dtype_r8, (/pcols,pver/), qsnow_mg_idx) - end if - - ! check energy package - call check_energy_register - - ! If using a simple physics option (e.g., held_suarez, adiabatic), - ! the normal CAM physics parameterizations are not called. - if (moist_physics) then - - ! register fluxes for saving across time - if (phys_do_flux_avg()) call flux_avg_register() - - call cldfrc_register() - - ! cloud water - if (.not. do_clubb_sgs) call macrop_driver_register() - ! OSLO_AERO begin - call oslo_aero_microp_register() - ! OSLO_AERO end - call microp_driver_register() - - ! Register CLUBB_SGS here - if (do_clubb_sgs) call clubb_register_cam() - - call pbuf_add_field('PREC_STR', 'global',dtype_r8,(/pcols/),prec_str_idx) - call pbuf_add_field('SNOW_STR', 'global',dtype_r8,(/pcols/),snow_str_idx) - call pbuf_add_field('PREC_PCW', 'global',dtype_r8,(/pcols/),prec_pcw_idx) - call pbuf_add_field('SNOW_PCW', 'global',dtype_r8,(/pcols/),snow_pcw_idx) - call pbuf_add_field('PREC_SED', 'global',dtype_r8,(/pcols/),prec_sed_idx) - call pbuf_add_field('SNOW_SED', 'global',dtype_r8,(/pcols/),snow_sed_idx) - - if (is_subcol_on()) then - call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) - call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) - call pbuf_register_subcol('PREC_PCW', 'phys_register', prec_pcw_idx) - call pbuf_register_subcol('SNOW_PCW', 'phys_register', snow_pcw_idx) - call pbuf_register_subcol('PREC_SED', 'phys_register', prec_sed_idx) - call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) - end if - - ! Reserve liquid at end of tphysbc - call pbuf_add_field('RLIQBC','physpkg',dtype_r8,(/pcols/),rliqbc_idx) - - ! Who should add FRACIS? - ! -- It does not seem that aero_intr should add it since FRACIS is used in convection - ! even if there are no prognostic aerosols ... so do it here for now - call pbuf_add_field('FRACIS','physpkg',dtype_r8,(/pcols,pver,pcnst/),m) - - call conv_water_register() - - ! Determine whether its a 'modal' aerosol simulation or not - ! OSLO_AERO begin - clim_modal_aero = .false. - ! OSLO_AERO end - - call surface_emissions_reg() - call elevated_emissions_reg() - - ! register chemical constituents including aerosols ... - call chem_register() - - ! add prognostic lightning flash freq pbuf fld - call lightning_register() - - ! co2 constituents - call co2_register() - - ! register other constituents - call prescribed_volcaero_register() - call prescribed_strataero_register() - call prescribed_ozone_register() - call prescribed_aero_register() - call prescribed_ghg_register() - - ! register various data model gasses with pbuf - call ghg_data_register() - - ! carma microphysics - ! - call carma_register() - - ! Register iondrag variables with pbuf - call iondrag_register() - - ! Register ionosphere variables with pbuf if mode set to ionosphere - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_reg() - endif - - call aircraft_emit_register() - - ! deep convection - call convect_deep_register - - ! convection diagnostics - call convect_diagnostics_register - - ! radiation - call radiation_register - call cloud_diagnostics_register - call radheat_register - - ! COSP - call cospsimulator_intr_register - - ! vertical diffusion - call vd_register() - else - ! held_suarez/adiabatic physics option should be in simple_physics - call endrun('phys_register: moist_physics configuration error') - end if - - ! Register diagnostics PBUF - call diag_register() - - ! Register age of air tracers - call aoa_tracers_register() - - ! Register test tracers - call tracers_register() - - call dyn_register() - - ! All tracers registered, check that the dimensions are correct - call cnst_chk_dim() - - ! ***NOTE*** No registering constituents after the call to cnst_chk_dim. - - call offline_driver_reg() - - if (use_hemco) then - ! initialize harmonized emissions component (HEMCO) - call HCOI_Chunk_Init() - endif - - ! This needs to be last as it requires all pbuf fields to be added - if (cam_snapshot_before_num > 0 .or. cam_snapshot_after_num > 0) then - call pbuf_cam_snapshot_register() - end if - - end subroutine phys_register - - - - !======================================================================= - - subroutine phys_inidat( cam_out, pbuf2d ) - use cam_abortutils, only: endrun - - use physics_buffer, only: pbuf_get_index, physics_buffer_desc, pbuf_set_field, dyn_time_lvls - - - use cam_initfiles, only: initial_file_get_id, topo_file_get_id - use cam_grid_support, only: cam_grid_check, cam_grid_id - use cam_grid_support, only: cam_grid_get_dim_names - use pio, only: file_desc_t - use ncdio_atm, only: infld - use dycore, only: dycore_is - use polar_avg, only: polar_average - use short_lived_species, only: initialize_short_lived_species - use cam_control_mod, only: aqua_planet - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_inidat - - type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - integer :: lchnk, m, n, i, k, ncol - type(file_desc_t), pointer :: fh_ini, fh_topo - character(len=8) :: fieldname - real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) - - character(len=11) :: subname='phys_inidat' ! subroutine name - integer :: tpert_idx, qpert_idx, pblh_idx - - logical :: found=.false., found2=.false. - integer :: ierr - character(len=8) :: dim1name, dim2name - integer :: ixcldice, ixcldliq - integer :: grid_id ! grid ID for data mapping - - nullify(tptr,tptr_2,tptr3d,tptr3d_2) - - fh_ini => initial_file_get_id() - fh_topo => topo_file_get_id() - - ! dynamics variables are handled in dyn_init - here we read variables needed for physics - ! but not dynamics - - grid_id = cam_grid_id('physgrid') - if (.not. cam_grid_check(grid_id)) then - call endrun(trim(subname)//': Internal error, no "physgrid" grid') - end if - call cam_grid_get_dim_names(grid_id, dim1name, dim2name) - - allocate(tptr(1:pcols,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr(1:pcols,begchunk:endchunk)') - end if - - if (associated(fh_topo) .and. .not. aqua_planet) then - call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - if(.not. found) call endrun('ERROR: SGH not found on topo file') - - call pbuf_set_field(pbuf2d, sgh_idx, tptr) - - allocate(tptr_2(1:pcols,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr_2(1:pcols,begchunk:endchunk)') - end if - call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr_2, found, gridname='physgrid') - if(found) then - call pbuf_set_field(pbuf2d, sgh30_idx, tptr_2) - else - if (masterproc) write(iulog,*) 'Warning: Error reading SGH30 from topo file.' - if (masterproc) write(iulog,*) 'The field SGH30 will be filled using data from SGH.' - call pbuf_set_field(pbuf2d, sgh30_idx, tptr) - end if - - deallocate(tptr_2) - - call infld('LANDM_COSLAT', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - - if(.not.found) call endrun(' ERROR: LANDM_COSLAT not found on topo dataset.') - - call pbuf_set_field(pbuf2d, landm_idx, tptr) - - else - call pbuf_set_field(pbuf2d, sgh_idx, 0._r8) - call pbuf_set_field(pbuf2d, sgh30_idx, 0._r8) - call pbuf_set_field(pbuf2d, landm_idx, 0._r8) - end if - - call infld('PBLH', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr(:,:), found, gridname='physgrid') - if(.not. found) then - tptr(:,:) = 0._r8 - if (masterproc) write(iulog,*) 'PBLH initialized to 0.' - end if - pblh_idx = pbuf_get_index('pblh') - - call pbuf_set_field(pbuf2d, pblh_idx, tptr) - - call infld('TPERT', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr(:,:), found, gridname='physgrid') - if(.not. found) then - tptr(:,:) = 0._r8 - if (masterproc) write(iulog,*) 'TPERT initialized to 0.' - end if - tpert_idx = pbuf_get_index( 'tpert') - call pbuf_set_field(pbuf2d, tpert_idx, tptr) - - fieldname='QPERT' - qpert_idx = pbuf_get_index( 'qpert',ierr) - if (qpert_idx > 0) then - call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr(:,:), found, gridname='physgrid') - if(.not. found) then - tptr(:,:) = 0._r8 - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - call pbuf_set_field(pbuf2d, qpert_idx, tptr) - end if - - fieldname='CUSH' - m = pbuf_get_index('cush', ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - if(.not.found) then - if(masterproc) write(iulog,*) trim(fieldname), ' initialized to 1000.' - tptr=1000._r8 - end if - do n=1,dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr, start=(/1,n/), kount=(/pcols,1/)) - end do - deallocate(tptr) - end if - - ! - ! 3-D fields - ! - - allocate(tptr3d(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') - end if - - fieldname='CLOUD' - m = pbuf_get_index('CLD') - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - fieldname='QCWAT' - m = pbuf_get_index(fieldname,ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(.not. found) then - call infld('Q',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with Q' - if(dycore_is('LR')) call polar_average(pver, tptr3d) - else - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to huge()' - tptr3d = huge(1.0_r8) - end if - end if - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - end if - - fieldname = 'ICCWAT' - m = pbuf_get_index(fieldname, ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call cnst_get_ind('CLDICE', ixcldice) - call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - end if - if (masterproc) then - if (found) then - write(iulog,*) trim(fieldname), ' initialized with CLDICE' - else - write(iulog,*) trim(fieldname), ' initialized to 0.0' - end if - end if - end if - end if - - fieldname = 'LCWAT' - m = pbuf_get_index(fieldname,ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - allocate(tptr3d_2(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d_2(pcols,pver,begchunk:endchunk)') - end if - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - call infld('CLDLIQ',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d_2, found2, gridname='physgrid') - if(found .and. found2) then - do lchnk = begchunk, endchunk - ncol = get_ncols_p(lchnk) - tptr3d(:ncol,:,lchnk)=tptr3d(:ncol,:,lchnk)+tptr3d_2(:ncol,:,lchnk) - end do - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE + CLDLIQ' - else if (found) then ! Data already loaded in tptr3d - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE only' - else if (found2) then - tptr3d(:,:,:)=tptr3d_2(:,:,:) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDLIQ only' - end if - - if (found .or. found2) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - if(dycore_is('LR')) call polar_average(pver, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.0' - end if - deallocate(tptr3d_2) - end if - end if - - fieldname = 'TCWAT' - m = pbuf_get_index(fieldname,ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(.not.found) then - call infld('T', fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - if(dycore_is('LR')) call polar_average(pver, tptr3d) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with T' - else - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to huge()' - tptr3d = huge(1._r8) - end if - end if - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - end if - - fieldname = 'CONCLD' - m = pbuf_get_index('CONCLD',ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - end if - - deallocate(tptr3d) - allocate(tptr3d(pcols,pverp,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') - end if - - fieldname = 'TKE' - m = pbuf_get_index( 'tke') - call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - call pbuf_set_field(pbuf2d, m, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0.01_r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.01' - end if - - - fieldname = 'KVM' - m = pbuf_get_index('kvm') - call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - call pbuf_set_field(pbuf2d, m, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - - fieldname = 'KVH' - m = pbuf_get_index('kvh') - call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - call pbuf_set_field(pbuf2d, m, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - call initialize_short_lived_species(fh_ini, pbuf2d) - - !--------------------------------------------------------------------------------- - ! If needed, get ion and electron temperature fields from initial condition file - !--------------------------------------------------------------------------------- - - call waccmx_phys_ion_elec_temp_inidat(fh_ini,pbuf2d) - - end subroutine phys_inidat - - - subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) - - !----------------------------------------------------------------------- - ! - ! Initialization of physics package. - ! - !----------------------------------------------------------------------- - - use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index - use physconst, only: rair, cpair, gravit, zvir, & - karman - use cam_thermo, only: cam_thermo_init - use ref_pres, only: pref_edge, pref_mid - - use carma_intr, only: carma_init - use cam_control_mod, only: initial_run - use check_energy, only: check_energy_init - use chemistry, only: chem_init - use mo_lightning, only: lightning_init - use prescribed_ozone, only: prescribed_ozone_init - use prescribed_ghg, only: prescribed_ghg_init - use prescribed_aero, only: prescribed_aero_init - use aerodep_flx, only: aerodep_flx_init - use aircraft_emit, only: aircraft_emit_init - use prescribed_volcaero,only: prescribed_volcaero_init - use prescribed_strataero,only: prescribed_strataero_init - use cloud_fraction, only: cldfrc_init - use cldfrc2m, only: cldfrc2m_init - use co2_cycle, only: co2_init, co2_transport - use convect_deep, only: convect_deep_init - use convect_diagnostics,only: convect_diagnostics_init - use cam_diagnostics, only: diag_init - ! OSLO_AERO begin - use oslo_aero_diagnostics, only: oslo_aero_diagnostics_init - ! OSLO_AERO end - use gw_drag, only: gw_init - use radheat, only: radheat_init - use radiation, only: radiation_init - use cloud_diagnostics, only: cloud_diagnostics_init - use wv_saturation, only: wv_sat_init - use microp_driver, only: microp_driver_init - use microp_aero, only: microp_aero_init - ! OSLO_AERO begin - use oslo_aero_microp, only: oslo_aero_microp_init - ! OSLO_AERO end - use macrop_driver, only: macrop_driver_init - use conv_water, only: conv_water_init - use tracers, only: tracers_init - use aoa_tracers, only: aoa_tracers_init - use rayleigh_friction, only: rayleigh_friction_init - use vertical_diffusion, only: vertical_diffusion_init - use phys_debug_util, only: phys_debug_init - use phys_debug, only: phys_debug_state_init - use rad_constituents, only: rad_cnst_init - use aer_rad_props, only: aer_rad_props_init - use subcol, only: subcol_init - use qbo, only: qbo_init - use qneg_module, only: qneg_init - use lunar_tides, only: lunar_tides_init - use iondrag, only: iondrag_init -#if ( defined OFFLINE_DYN ) - use metdata, only: metdata_phys_init -#endif - use epp_ionization, only: epp_ionization_init, epp_ionization_active - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) - use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) - use clubb_intr, only: clubb_ini_cam - use tropopause, only: tropopause_init - use solar_data, only: solar_data_init - use dadadj_cam, only: dadadj_cam_init - use cam_abortutils, only: endrun - use nudging, only: Nudge_Model, nudging_init - use cam_snapshot, only: cam_snapshot_init - use cam_history, only: addfld, register_vector_field, add_default - use cam_budget, only: cam_budget_init - use phys_grid_ctem, only: phys_grid_ctem_init - use surface_emissions_mod, only: surface_emissions_init - use elevated_emissions_mod, only: elevated_emissions_init - - use ccpp_constituent_prop_mod, only: ccpp_const_props_init - - ! Input/output arguments - type(physics_state), pointer :: phys_state(:) - type(physics_tend ), pointer :: phys_tend(:) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - type(cam_in_t), intent(in) :: cam_in(begchunk:endchunk) - type(cam_out_t),intent(inout) :: cam_out(begchunk:endchunk) - - ! local variables - integer :: lchnk - integer :: ierr - integer :: ixq - - logical :: history_budget ! output tendencies and state variables for - ! temperature, water vapor, cloud - ! ice, cloud liquid, U, V - integer :: history_budget_histfile_num ! output history file number for budget fields - - !----------------------------------------------------------------------- - - call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) - - do lchnk = begchunk, endchunk - call physics_state_set_grid(lchnk, phys_state(lchnk)) - end do - - !------------------------------------------------------------------------------------------- - ! Initialize any variables in cam_thermo which are not temporally and/or spatially constant - !------------------------------------------------------------------------------------------- - call cam_thermo_init() - - ! Initialize debugging a physics column - call phys_debug_init() - - call pbuf_initialize(pbuf2d) - - ! Initialize subcol scheme - call subcol_init(pbuf2d) - - ! diag_init makes addfld calls for dynamics fields that are output from - ! the physics decomposition - call diag_init(pbuf2d) - ! OSLO_AERO begin - call oslo_aero_diagnostics_init() - ! OSLO_AERO end - - call check_energy_init() - - call tracers_init() - - ! age of air tracers - call aoa_tracers_init() - - teout_idx = pbuf_get_index( 'TEOUT') - - ! adiabatic or ideal physics should be only used if in simple_physics - if (adiabatic .or. ideal_phys) then - if (adiabatic) then - call endrun('phys_init: adiabatic configuration error') - else - call endrun('phys_init: ideal_phys configuration error') - end if - end if - - if (initial_run) then - call phys_inidat(cam_out, pbuf2d) - end if - - ! wv_saturation is relatively independent of everything else and - ! low level, so init it early. Must at least do this before radiation. - call wv_sat_init - - ! solar irradiance data modules - call solar_data_init() - - ! Initialize rad constituents and their properties - call rad_cnst_init() - - call radiation_init(pbuf2d) - - call aer_rad_props_init() - - ! initialize carma - call carma_init(pbuf2d) - call surface_emissions_init(pbuf2d) - call elevated_emissions_init(pbuf2d) - - ! Prognostic chemistry. - call chem_init(phys_state,pbuf2d) - - ! Lightning flash frq and NOx prod - call lightning_init( pbuf2d ) - - ! Prescribed tracers - call prescribed_ozone_init() - call prescribed_ghg_init() - call prescribed_aero_init() - call aerodep_flx_init() - call aircraft_emit_init() - call prescribed_volcaero_init() - call prescribed_strataero_init() - - ! co2 cycle - if (co2_transport()) then - call co2_init() - end if - - call gw_init() - - call rayleigh_friction_init() - - call vertical_diffusion_init(pbuf2d) - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call waccmx_phys_mspd_init () - ! Initialization of ionosphere module if mode set to ionosphere - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_init(pbuf2d) - endif - endif - - call cloud_diagnostics_init(pbuf2d) - - call radheat_init(pref_mid) - - call convect_diagnostics_init() - - call cldfrc_init() - call cldfrc2m_init() - - call convect_deep_init(pref_edge) - - if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) - ! OSLO_AERO begin - call oslo_aero_microp_init() - ! OSLO_AERO end - call microp_driver_init(pbuf2d) - call conv_water_init - - ! initiate CLUBB within CAM - if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) - - call qbo_init - - call lunar_tides_init() - - call iondrag_init(pref_mid) - ! Geomagnetic module -- after iondrag_init - if (epp_ionization_active) then - call epp_ionization_init() - endif - -#if ( defined OFFLINE_DYN ) - call metdata_phys_init() -#endif - call tropopause_init() - call dadadj_cam_init() - - prec_dp_idx = pbuf_get_index('PREC_DP') - snow_dp_idx = pbuf_get_index('SNOW_DP') - prec_sh_idx = pbuf_get_index('PREC_SH') - snow_sh_idx = pbuf_get_index('SNOW_SH') - - dlfzm_idx = pbuf_get_index('DLFZM', ierr) - cmfmczm_idx = pbuf_get_index('CMFMC_DP', ierr) - - ! OSLO_AERO begin - prog_modal_aero = .true. - ! OSLO_AERO end - - ! Initialize Nudging Parameters - !-------------------------------- - if(Nudge_Model) call nudging_init - - if (clim_modal_aero) then - - ! If climate calculations are affected by prescribed modal aerosols, the - ! initialization routine for the dry mode radius calculation is called - ! here. For prognostic MAM the initialization is called from - ! modal_aero_initialize - if (.not. prog_modal_aero) then - call modal_aero_calcsize_init(pbuf2d) - endif - - call modal_aero_wateruptake_init(pbuf2d) - - end if - - ! Initialize CAM CCPP constituent properties array - ! for use in CCPP-ized physics schemes: - call cnst_get_ind('Q', ixq) - call ccpp_const_props_init(ixq) - - ! Initialize qneg3 and qneg4 - call qneg_init() - - ! Initialize phys TEM diagnostics - call phys_grid_ctem_init() - - ! Initialize the snapshot capability - call cam_snapshot_init(cam_in, cam_out, pbuf2d, begchunk) - - ! Initialize the budget capability - call cam_budget_init() - - ! addfld calls for U, V tendency budget variables that are output in - ! tphysac, tphysbc - call addfld ( 'UTEND_DCONV', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by deep convection') - call addfld ( 'VTEND_DCONV', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by deep convection') - call register_vector_field ( 'UTEND_DCONV', 'VTEND_DCONV') - call addfld ( 'UTEND_SHCONV', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by shallow convection') - call addfld ( 'VTEND_SHCONV', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by shallow convection') - call register_vector_field ( 'UTEND_SHCONV', 'VTEND_SHCONV') - call addfld ( 'UTEND_MACROP', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by macrophysics') - call addfld ( 'VTEND_MACROP', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by macrophysics') - call register_vector_field ( 'UTEND_MACROP', 'VTEND_MACROP') - call addfld ( 'UTEND_VDIFF', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by vert. diffus.') - call addfld ( 'VTEND_VDIFF', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by vert. diffus.') - call register_vector_field ( 'UTEND_VDIFF', 'VTEND_VDIFF') - call addfld ( 'UTEND_RAYLEIGH', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by Rayleigh Fric.') - call addfld ( 'VTEND_RAYLEIGH', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by Rayleigh Fric.') - call register_vector_field ( 'UTEND_RAYLEIGH', 'VTEND_RAYLEIGH') - call addfld ( 'UTEND_GWDTOT', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by all GWs') - call addfld ( 'VTEND_GWDTOT', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by all GWs') - call register_vector_field ( 'UTEND_GWDTOT', 'VTEND_GWDTOT') - call addfld ( 'UTEND_QBORLX', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by QBO relaxation') - call addfld ( 'VTEND_QBORLX', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by QBO relaxation') - call register_vector_field ( 'UTEND_QBORLX', 'VTEND_QBORLX') - call addfld ( 'UTEND_LUNART', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by lunar tides') - call addfld ( 'VTEND_LUNART', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by lunar tides') - call register_vector_field ( 'UTEND_LUNART', 'VTEND_LUNART') - call addfld ( 'UTEND_IONDRG', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by ion drag') - call addfld ( 'VTEND_IONDRG', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by ion drag') - call register_vector_field ( 'UTEND_IONDRG', 'VTEND_IONDRG') - call addfld ( 'UTEND_NDG', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind tendency by nudging') - call addfld ( 'VTEND_NDG', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind tendency by nudging') - call register_vector_field ( 'UTEND_NDG', 'VTEND_NDG') - call addfld('UTEND_CORE', (/ 'lev' /), 'A', 'm/s2' , 'Zonal wind tendency due to dynamical core') - call addfld('VTEND_CORE', (/ 'lev' /), 'A', 'm/s2' , 'Meridional wind tendency due to dynamical core') - call register_vector_field('UTEND_CORE','VTEND_CORE') - - - call phys_getopts(history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num) - - if ( history_budget ) then - call add_default ( 'UTEND_DCONV' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_DCONV' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_SHCONV' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_SHCONV' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_MACROP' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_MACROP' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_VDIFF' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_VDIFF' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_RAYLEIGH' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_RAYLEIGH' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_GWDTOT' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_GWDTOT' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_QBORLX' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_QBORLX' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_LUNART' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_LUNART' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_IONDRG' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_IONDRG' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_NDG' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_NDG' , history_budget_histfile_num, ' ') - call add_default ( 'UTEND_CORE' , history_budget_histfile_num, ' ') - call add_default ( 'VTEND_CORE' , history_budget_histfile_num, ' ') - end if - - ducore_idx = pbuf_get_index('DUCORE') - dvcore_idx = pbuf_get_index('DVCORE') - dtcore_idx = pbuf_get_index('DTCORE') - dqcore_idx = pbuf_get_index('DQCORE') - - psl_idx = pbuf_get_index('PSL') - - end subroutine phys_init - - ! - !----------------------------------------------------------------------- - ! - - subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! First part of atmospheric physics package before updating of surface models - ! - !----------------------------------------------------------------------- - use time_manager, only: get_nstep - use cam_diagnostics,only: diag_allocate, diag_physvar_ic - use check_energy, only: check_energy_gmean - use spmd_utils, only: mpicom - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate - use cam_history, only: outfld, write_camiop - use cam_abortutils, only: endrun -#if ( defined OFFLINE_DYN ) - use metdata, only: get_met_srf1 -#endif - ! - ! Input arguments - ! - real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 - ! - ! Input/Output arguments - ! - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend - - type(physics_buffer_desc), pointer, dimension(:,:) :: pbuf2d - type(cam_in_t), dimension(begchunk:endchunk) :: cam_in - type(cam_out_t), dimension(begchunk:endchunk) :: cam_out - !----------------------------------------------------------------------- - ! - !---------------------------Local workspace----------------------------- - ! - integer :: c ! indices - integer :: ncol ! number of columns - integer :: nstep ! current timestep number - type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) - - call t_startf ('physpkg_st1') - nstep = get_nstep() - -#if ( defined OFFLINE_DYN ) - ! - ! if offline mode set SNOWH and TS for micro-phys - ! - call get_met_srf1( cam_in ) -#endif - - ! The following initialization depends on the import state (cam_in) - ! being initialized. This isn't true when cam_init is called, so need - ! to postpone this initialization to here. - if (nstep == 0 .and. phys_do_flux_avg()) call flux_avg_init(cam_in, pbuf2d) - - ! Compute total energy of input state and previous output state - call t_startf ('chk_en_gmean') - call check_energy_gmean(phys_state, pbuf2d, ztodt, nstep) - call t_stopf ('chk_en_gmean') - - call pbuf_allocate(pbuf2d, 'physpkg') - call diag_allocate() - - !----------------------------------------------------------------------- - ! Advance time information - !----------------------------------------------------------------------- - - call phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) - - call t_stopf ('physpkg_st1') - -#ifdef TRACER_CHECK - call gmean_mass ('before tphysbc DRY', phys_state) -#endif - - - !----------------------------------------------------------------------- - ! Tendency physics before flux coupler invocation - !----------------------------------------------------------------------- - ! - - if (write_camiop) then - do c=begchunk, endchunk - call outfld('Tg',cam_in(c)%ts,pcols ,c ) - end do - end if - - call t_barrierf('sync_bc_physics', mpicom) - call t_startf ('bc_physics') - call t_adj_detailf(+1) - -!$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) - do c=begchunk, endchunk - ! - ! Output physics terms to IC file - ! - phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) - - call t_startf ('diag_physvar_ic') - call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) - call t_stopf ('diag_physvar_ic') - - call tphysbc (ztodt, phys_state(c), & - phys_tend(c), phys_buffer_chunk, & - cam_out(c), cam_in(c) ) - end do - - call t_adj_detailf(-1) - call t_stopf ('bc_physics') - - ! Don't call the rest in CRM mode - if(single_column.and.scm_crm_mode) return - -#ifdef TRACER_CHECK - call gmean_mass ('between DRY', phys_state) -#endif - - end subroutine phys_run1 - - ! - !----------------------------------------------------------------------- - ! - - subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & - cam_in ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Second part of atmospheric physics package after updating of surface models - ! - !----------------------------------------------------------------------- - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_deallocate, pbuf_update_tim_idx - use mo_lightning, only: lightning_no_prod - use cam_diagnostics, only: diag_deallocate, diag_surf - use carma_intr, only: carma_accumulate_stats - use spmd_utils, only: mpicom - use iop_forcing, only: scam_use_iop_srf -#if ( defined OFFLINE_DYN ) - use metdata, only: get_met_srf2 -#endif - use hemco_interface, only: HCOI_Chunk_Run - ! - ! Input arguments - ! - real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 - ! - ! Input/Output arguments - ! - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend - type(physics_buffer_desc),pointer, dimension(:,:) :: pbuf2d - - type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out - type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in - ! - !----------------------------------------------------------------------- - !---------------------------Local workspace----------------------------- - ! - integer :: c ! chunk index - integer :: ncol ! number of columns - type(physics_buffer_desc),pointer, dimension(:) :: phys_buffer_chunk - ! - ! If exit condition just return - ! - - if(single_column.and.scm_crm_mode) then - call diag_deallocate() - return - end if - !----------------------------------------------------------------------- - ! if using IOP values for surface fluxes overwrite here after surface components run - !----------------------------------------------------------------------- - if (single_column) call scam_use_iop_srf(cam_in) - - if(use_hemco) then - !---------------------------------------------------------- - ! run hemco (phase 2 before chemistry) - ! only phase 2 is used currently for HEMCO-CESM - !---------------------------------------------------------- - call HCOI_Chunk_Run(cam_in, phys_state, pbuf2d, phase=2) - endif - - !----------------------------------------------------------------------- - ! Tendency physics after coupler - ! Not necessary at terminal timestep. - !----------------------------------------------------------------------- - ! -#if ( defined OFFLINE_DYN ) - ! - ! if offline mode set SHFLX QFLX TAUX TAUY for vert diffusion - ! - call get_met_srf2( cam_in ) -#endif - ! lightning flash freq and prod rate of NOx - call t_startf ('lightning_no_prod') - call lightning_no_prod( phys_state, pbuf2d, cam_in ) - call t_stopf ('lightning_no_prod') - - call t_barrierf('sync_ac_physics', mpicom) - call t_startf ('ac_physics') - call t_adj_detailf(+1) - -!$OMP PARALLEL DO PRIVATE (C, NCOL, phys_buffer_chunk) - - do c=begchunk,endchunk - ncol = get_ncols_p(c) - phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) - ! - ! surface diagnostics for history files - ! - call t_startf('diag_surf') - call diag_surf(cam_in(c), cam_out(c), phys_state(c), phys_buffer_chunk) - call t_stopf('diag_surf') - - call tphysac(ztodt, cam_in(c), & - cam_out(c), & - phys_state(c), phys_tend(c), phys_buffer_chunk) - end do ! Chunk loop - - call t_adj_detailf(-1) - call t_stopf('ac_physics') - -#ifdef TRACER_CHECK - call gmean_mass ('after tphysac FV:WET)', phys_state) -#endif - - call t_startf ('carma_accumulate_stats') - call carma_accumulate_stats() - call t_stopf ('carma_accumulate_stats') - - call t_startf ('physpkg_st2') - call pbuf_deallocate(pbuf2d, 'physpkg') - - call pbuf_update_tim_idx() - call diag_deallocate() - call t_stopf ('physpkg_st2') - - end subroutine phys_run2 - - ! - !----------------------------------------------------------------------- - ! - - subroutine phys_final( phys_state, phys_tend, pbuf2d ) - use physics_buffer, only: physics_buffer_desc, pbuf_deallocate - use chemistry, only: chem_final - use carma_intr, only: carma_final - use wv_saturation, only: wv_sat_final - use microp_aero, only: microp_aero_final - use phys_grid_ctem, only: phys_grid_ctem_final - use nudging, only: Nudge_Model, nudging_final - use hemco_interface, only: HCOI_Chunk_Final - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Finalization of physics package - ! - !----------------------------------------------------------------------- - ! Input/output arguments - type(physics_state), pointer :: phys_state(:) - type(physics_tend ), pointer :: phys_tend(:) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - if(associated(pbuf2d)) then - call pbuf_deallocate(pbuf2d,'global') - deallocate(pbuf2d) - end if - deallocate(phys_state) - deallocate(phys_tend) - call chem_final - call carma_final - call wv_sat_final - ! OSLO_AERO begin - ! microp_aero_final() not called - ! OSLO_AERO end - call phys_grid_ctem_final() - if(Nudge_Model) call nudging_final() - - if(use_hemco) then - ! cleanup hemco - call HCOI_Chunk_Final - endif - - end subroutine phys_final - - - subroutine tphysac (ztodt, cam_in, & - cam_out, state, tend, pbuf) - !----------------------------------------------------------------------- - ! - ! Tendency physics after coupling to land, sea, and ice models. - ! - ! Computes the following: - ! - ! o Aerosol Emission at Surface - ! o Stratiform Macro-Microphysics - ! o Wet Scavenging of Aerosol - ! o Radiation - ! o Source-Sink for Advected Tracers - ! o Symmetric Turbulence Scheme - Vertical Diffusion - ! o Rayleigh Friction - ! o Dry Deposition of Aerosol - ! o Enforce Charge Neutrality ( Only for WACCM ) - ! o Gravity Wave Drag - ! o QBO Relaxation ( Only for WACCM ) - ! o Ion Drag ( Only for WACCM ) - ! o Scale Dry Mass Energy - !----------------------------------------------------------------------- - use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx - use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions - use cam_diagnostics, only: diag_phys_tend_writeout - use gw_drag, only: gw_tend - use vertical_diffusion, only: vertical_diffusion_tend - use rayleigh_friction, only: rayleigh_friction_tend - use physics_types, only: physics_dme_adjust, set_dry_to_wet, physics_state_check, & - dyn_te_idx - use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X - use aoa_tracers, only: aoa_tracers_timestep_tend - use physconst, only: rhoh2o - use aero_model, only: aero_model_drydep - use check_energy, only: check_energy_timestep_init, check_energy_cam_chng - use check_energy, only: tot_energy_phys, enthalpy_adjustment - use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng - use time_manager, only: get_nstep - use cam_abortutils, only: endrun - use dycore, only: dycore_is - use cam_control_mod, only: aqua_planet - use mo_gas_phase_chemdr,only: map2chm - use clybry_fam, only: clybry_fam_set - use charge_neutrality, only: charge_balance - use qbo, only: qbo_relax - use iondrag, only: iondrag_calc, do_waccm_ions - use perf_mod - use flux_avg, only: flux_avg_run - use cam_history, only: hist_fld_active, outfld - use qneg_module, only: qneg4 - use co2_cycle, only: co2_cycle_set_ptend - use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend - use cam_snapshot, only: cam_snapshot_all_outfld_tphysac - use cam_snapshot_common,only: cam_snapshot_ptend_outfld - use lunar_tides, only: lunar_tides_tend - use ssatcontrail, only: ssatcontrail_d0 - use physics_types, only: physics_ptend_init, physics_ptend_sum, physics_ptend_scale - use microp_driver, only: microp_driver_tend - use microp_aero, only: microp_aero_run - ! OSLO_AERO begin - use oslo_aero_microp, only: oslo_aero_microp_run - use oslo_aero_share - ! OSLO_AERO end - use clubb_intr, only: clubb_tend_cam, clubb_emissions_cam - use subcol, only: subcol_gen, subcol_ptend_avg - use subcol_utils, only: subcol_ptend_copy, is_subcol_on - use subcol_SILHS, only: subcol_SILHS_var_covar_driver, init_state_subcol - use subcol_SILHS, only: subcol_SILHS_fill_holes_conserv - use subcol_SILHS, only: subcol_SILHS_hydromet_conc_tend_lim - use micro_pumas_cam, only: massless_droplet_destroyer - use convect_deep, only: convect_deep_tend_2, deep_scheme_does_scav_trans - use cloud_diagnostics, only: cloud_diagnostics_calc - use radiation, only: radiation_tend - use tropopause, only: tropopause_output - use cam_diagnostics, only: diag_phys_writeout, diag_conv, diag_clip_tend_writeout - use aero_model, only: aero_model_wetdep - use aero_wetdep_cam, only: wetdep_lq - use physics_buffer, only: col_type_subcol - use carma_intr, only: carma_wetdep_tend, carma_timestep_tend, carma_emission_tend - use carma_flags_mod, only: carma_do_aerosol, carma_do_emission, carma_do_detrain - use carma_flags_mod, only: carma_do_cldice, carma_do_cldliq, carma_do_wetdep - use dyn_tests_utils, only: vc_dycore - use cam_thermo, only: cam_thermo_water_update - use cam_budget, only: thermo_budget_history - use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure - use air_composition, only: cpairv, cp_or_cv_dycore - use air_composition, only: compute_enthalpy_flux - use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx - ! - ! Arguments - ! - real(r8), intent(in) :: ztodt ! Two times model timestep (2 delta-t) - - type(cam_in_t), intent(inout) :: cam_in - type(cam_out_t), intent(inout) :: cam_out - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) - - - type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes - - ! - !---------------------------Local workspace----------------------------- - ! - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - type(physics_ptend) :: ptend_macp_all ! sum of macrophysics tendencies (e.g. CLUBB) over substeps - type(physics_state) :: state_sc ! state for sub-columns - type(physics_ptend) :: ptend_sc ! ptend for sub-columns - type(physics_ptend) :: ptend_aero ! ptend for microp_aero - type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns - type(physics_tend) :: tend_sc ! tend for sub-columns - - integer :: nstep ! current timestep number - real(r8) :: zero(pcols) ! array of zeros - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer i,k,m ! Longitude, level indices - integer :: yr, mon, day, tod ! components of a date - integer :: ixq, ixcldice, ixcldliq ! constituent indices for vapor, cloud liquid and ice water. - - ! for macro/micro co-substepping - integer :: macmic_it ! iteration variables - real(r8) :: cld_macmic_ztodt ! modified timestep - - real(r8) :: net_flx(pcols) - - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) rtdt ! 1./ztodt - - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice - real(r8) :: flx_cnd(pcols) - - real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: zero_tracers(pcols,pcnst) - - real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. - real(r8), pointer :: cmfmczm(:,:) ! ZM convective mass fluxes - real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid - - ! stratiform precipitation variables - real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) - real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) - real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns - real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns - real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme - real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme - real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation - real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation - - ! Local copies for substepping - real(r8) :: prec_pcw_macmic(pcols) - real(r8) :: snow_pcw_macmic(pcols) - real(r8) :: prec_sed_macmic(pcols) - real(r8) :: snow_sed_macmic(pcols) - - ! carma precipitation variables - real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) - real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) - - logical :: labort ! abort flag - - real(r8) tvm(pcols,pver) ! virtual temperature - real(r8) prect(pcols) ! total precipitation - real(r8) surfric(pcols) ! surface friction velocity - real(r8) obklen(pcols) ! Obukhov length - real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_cam_chng. - real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space - real(r8) :: tmp_pdel (pcols,pver) ! tmp space - real(r8) :: tmp_ps (pcols) ! tmp space - real(r8) :: scaling(pcols,pver) - logical :: moist_mixing_ratio_dycore - - ! physics buffer fields for total energy and mass adjustment - integer itim_old, ifld - - real(r8), pointer, dimension(:,:) :: cld - real(r8), pointer, dimension(:,:) :: qini - real(r8), pointer, dimension(:,:) :: cldliqini - real(r8), pointer, dimension(:,:) :: cldiceini - real(r8), pointer, dimension(:,:) :: totliqini - real(r8), pointer, dimension(:,:) :: toticeini - real(r8), pointer, dimension(:,:) :: dtcore - real(r8), pointer, dimension(:,:) :: dqcore - real(r8), pointer, dimension(:,:) :: ducore - real(r8), pointer, dimension(:,:) :: dvcore - real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction - - ! variables for dme_energy_adjust - real(r8), pointer, dimension(:,:) :: qcsedten, qrsedten, qisedten, qssedten, qgsedten - real(r8), pointer, dimension(:,:) :: qrain_mg , qsnow_mg - real(r8), dimension(pcols,pver) :: qrain_mg_macmic , qsnow_mg_macmic - integer :: m_cnst - real(r8):: hflx_iref(pcols) - character(50) :: physparname !(and a little extra log info) - - !----------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - - nstep = get_nstep() - rtdt = 1._r8/ztodt - - ! Adjust the surface fluxes to reduce instabilities in near sfc layer - if (phys_do_flux_avg()) then - call flux_avg_run(state, cam_in, pbuf, nstep, ztodt) - endif - - ! Validate the physics state. - if (state_debug_checks) then - call physics_state_check(state, name="before tphysac") - end if - - call t_startf('tphysac_init') - ! Associate pointers with physics buffer fields - itim_old = pbuf_old_tim_idx() - - call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, qini_idx, qini) - call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) - call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - call pbuf_get_field(pbuf, totliqini_idx, totliqini) - call pbuf_get_field(pbuf, toticeini_idx, toticeini) - - ifld = pbuf_get_index('CLD') - call pbuf_get_field(pbuf, ifld, cld, start=(/1,1,itim_old/),kount=(/pcols,pver,1/)) - - ifld = pbuf_get_index('AST') - call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call cnst_get_ind('Q', ixq) - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - call pbuf_get_field(pbuf, prec_str_idx, prec_str ) - call pbuf_get_field(pbuf, snow_str_idx, snow_str ) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) - - if (is_subcol_on()) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) - end if - - if (dlfzm_idx > 0) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - dlf(:ncol,:) = dlfzm(:ncol,:) - else - dlf(:,:) = 0._r8 - end if - - if (cmfmczm_idx > 0) then - call pbuf_get_field(pbuf, cmfmczm_idx, cmfmczm) - cmfmc(:ncol,:) = cmfmczm(:ncol,:) - else - cmfmc(:ncol,:) = 0._r8 - end if - - call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) - rliq(:ncol) = rliqbc(:ncol) - - ! - ! accumulate fluxes into net flux array for spectral dycores - ! jrm Include latent heat of fusion for snow - ! - do i=1,ncol - tend%flx_net(i) = tend%flx_net(i) + cam_in%shf(i) + (cam_out%precc(i) & - + cam_out%precl(i))*latvap*rhoh2o & - + (cam_out%precsc(i) + cam_out%precsl(i))*latice*rhoh2o - end do - - ! emissions of aerosols and gas-phase chemistry constituents at surface - - if (trim(cam_take_snapshot_before) == "chem_emissions") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call chem_emissions( state, cam_in, pbuf ) - if (trim(cam_take_snapshot_after) == "chem_emissions") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - if (carma_do_emission) then - ! carma emissions - call carma_emission_tend (state, ptend, cam_in, ztodt, pbuf) - call physics_update(state, ptend, ztodt, tend) - end if - - ! get nstep and zero array for energy checker - zero = 0._r8 - zero_sc(:) = 0._r8 - zero_tracers(:,:) = 0._r8 - nstep = get_nstep() - call check_tracers_init(state, tracerint) - - ! Check if latent heat flux exceeds the total moisture content of the - ! lowest model layer, thereby creating negative moisture. - - hflx_iref(:ncol) = cam_in%shf(:ncol) - call qneg4('TPHYSAC', lchnk, ncol, ztodt , & - state%q(1,pver,1), state%rpdel(1,pver), & - cam_in%shf, cam_in%lhf, cam_in%cflx), & - seflx=hflx_iref) - - call t_stopf('tphysac_init') - - !=================================================== - ! Apply tracer surface fluxes to lowest model layer - !=================================================== - call t_startf('clubb_emissions_tend') - - call clubb_emissions_cam(state, cam_in, ptend) - - call physics_update(state, ptend, ztodt, tend) - - call check_energy_cam_chng(state, tend, "clubb_emissions_tend", nstep, ztodt, zero, zero, zero, zero) - - call t_stopf('clubb_emissions_tend') - - !=================================================== - ! Calculate tendencies from CARMA bin microphysics. - !=================================================== - ! - ! If CARMA is doing detrainment, then on output, rliq no longer represents - ! water reserved - ! for detrainment, but instead represents potential snow fall. The mass and - ! number of the - ! snow are stored in the physics buffer and will be incorporated by the MG - ! microphysics. - ! - ! Currently CARMA cloud microphysics is only supported with the MG - ! microphysics. - call t_startf('carma_timestep_tend') - - if (carma_do_cldice .or. carma_do_cldliq) then - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & - prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) - call physics_update(state, ptend, ztodt, tend) - - ! Before the detrainment, the reserved condensate is all liquid, but if - ! CARMA is doing - ! detrainment, then the reserved condensate is snow. - if (carma_do_detrain) then - call check_energy_cam_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) - else - call check_energy_cam_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) - end if - end if - - call t_stopf('carma_timestep_tend') - - if( microp_scheme == 'MG' ) then - ! Start co-substepping of macrophysics and microphysics - cld_macmic_ztodt = ztodt/cld_macmic_num_steps - - ! Clear precip fields that should accumulate. - prec_sed_macmic = 0._r8 - snow_sed_macmic = 0._r8 - prec_pcw_macmic = 0._r8 - snow_pcw_macmic = 0._r8 - - if (compute_enthalpy_flux) then - qrain_mg_macmic(:ncol,:) = 0._r8 - qsnow_mg_macmic(:ncol,:) = 0._r8 - endif - - ! contrail parameterization - ! see Chen et al., 2012: Global contrail coverage simulated - ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES - ! https://doi.org/10.1029/2011MS000105 - call ssatcontrail_d0(state, pbuf, ztodt, ptend) - call physics_update(state, ptend, ztodt, tend) - - ! initialize ptend structures where macro and microphysics tendencies are - ! accumulated over macmic substeps - call physics_ptend_init(ptend_macp_all,state%psetcols,'macrophysics',lu=.true.,lv=.true.) - - do macmic_it = 1, cld_macmic_num_steps - - !=================================================== - ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) - !=================================================== - - call t_startf('macrop_tend') - - ! ===================================================== - ! CLUBB call (PBL, shallow convection, macrophysics) - ! ===================================================== - - if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& - cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & - dlf, det_s, det_ice) - - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - - !flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) - flx_heat(:ncol) = hflx_iref(:ncol) + det_s(:ncol) - - ! Unfortunately, physics_update does not know what time period - ! "tend" is supposed to cover, and therefore can't update it - ! with substeps correctly. For now, work around this by scaling - ! ptend down by the number of substeps, then applying it for - ! the full time (ztodt). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - - ! Update physics tendencies and copy state to state_eq, because that is - ! input for microphysics - if ( (trim(cam_take_snapshot_after) == "clubb_tend_cam") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_ptend_sum(ptend,ptend_macp_all,ncol) - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code - ! a little extra log info - !call check_energy_cam_chng(state, tend, "clubb_tend", nstep, ztodt, & - write(physparname,"(i3)") macmic_it - physparname="clubb_tend "//trim(physparname) - call check_energy_cam_chng(state, tend, physparname, nstep, ztodt, & - cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & - flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) - - call t_stopf('macrop_tend') - - !=================================================== - ! Calculate cloud microphysics - !=================================================== - - if (is_subcol_on() .neqv. use_subcol_microp ) then - call endrun("Error calculating cloud microphysics: is_subcol_on() != use_subcol_microp") - end if - - if (is_subcol_on()) then - ! Allocate sub-column structures. - call physics_state_alloc(state_sc, lchnk, psubcols*pcols) - call physics_tend_alloc(tend_sc, psubcols*pcols) - - ! Generate sub-columns using the requested scheme - if (trim(subcol_scheme) == 'SILHS') call init_state_subcol(state, tend, state_sc, tend_sc) - call subcol_gen(state, tend, state_sc, tend_sc, pbuf) - - !Initialize check energy for subcolumns - call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) - end if - - if (trim(cam_take_snapshot_before) == "microp_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - ! OSLO_AERO begin - call t_startf('oslo_aero_microp_run') - call oslo_aero_microp_run(state, ptend_aero, cld_macmic_ztodt, pbuf) - call t_stopf('oslo_aero_microp_run') - ! OSLO_AERO end - - call t_startf('microp_tend') - - if (use_subcol_microp) then - - if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) - ! Parameterize subcolumn effects on covariances, if enabled - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_var_covar_driver( cld_macmic_ztodt, state_sc, ptend_sc, pbuf ) - - ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero - call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) - - ! Call the conservative hole filler. - ! Hole filling is only necessary when using subcolumns. - ! Note: this needs to be called after subcol_ptend_avg but before - ! physics_ptend_scale. - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_fill_holes_conserv( state, cld_macmic_ztodt, & - ptend, pbuf ) - - ! Destroy massless droplets - Note this routine returns with no change unless - ! micro_do_massless_droplet_destroyer has been set to true - call massless_droplet_destroyer( cld_macmic_ztodt, state, & ! Intent(in) - ptend ) ! Intent(inout) - - ! Limit the value of hydrometeor concentrations in order to place - ! reasonable limits on hydrometeor drop size and keep them from - ! becoming too large. - ! Note: this needs to be called after hydrometeor mixing ratio - ! tendencies are adjusted by subcol_SILHS_fill_holes_conserv - ! and after massless drop concentrations are removed by the - ! subcol_SILHS_massless_droplet_destroyer, but before the - ! call to physics_ptend_scale. - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_hydromet_conc_tend_lim( state, cld_macmic_ztodt, ptend ) - - ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend - call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) - call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) - call physics_ptend_dealloc(ptend_aero_sc) - - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) - - if ( (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update (state_sc, ptend_sc, ztodt, tend_sc) - - if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call check_energy_cam_chng(state_sc, tend_sc, "microp_tend_subcol", & - nstep, ztodt, zero_sc, & - prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & - snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) - - call physics_state_dealloc(state_sc) - call physics_tend_dealloc(tend_sc) - call physics_ptend_dealloc(ptend_sc) - else - call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) - end if - ! combine aero and micro tendencies for the grid - call physics_ptend_sum(ptend_aero, ptend, ncol) - call physics_ptend_dealloc(ptend_aero) - - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - - call diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) - - if ( (trim(cam_take_snapshot_after) == "microp_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update (state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "microp_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - ! a little extra log info - !call check_energy_cam_chng(state, tend, "microp_tend", nstep, ztodt, & - write(physparname,"(i3)") macmic_it - physparname="microp_tend "//trim(physparname) - call check_energy_cam_chng(state, tend, physparname, nstep, ztodt, & - zero, prec_str(:ncol)/cld_macmic_num_steps, & - snow_str(:ncol)/cld_macmic_num_steps, zero) - - call t_stopf('microp_tend') - - prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) - snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) - prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) - snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) - - if (compute_enthalpy_flux) then - if(macmic_it.eq.1) then - qcsedten_idx = pbuf_get_index('QCSEDTEN' , errcode=i) - qrsedten_idx = pbuf_get_index('QRSEDTEN' , errcode=i) - qisedten_idx = pbuf_get_index('QISEDTEN' , errcode=i) - qssedten_idx = pbuf_get_index('QSSEDTEN' , errcode=i) - qgsedten_idx = pbuf_get_index('QGSEDTEN' , errcode=i) - endif - if (qcsedten_idx.gt.0) then - call pbuf_get_field(pbuf, qcsedten_idx, qcsedten) - qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qcsedten(:ncol,:) - endif - if (qrsedten_idx.gt.0) then - call pbuf_get_field(pbuf, qrsedten_idx, qrsedten) - qrain_mg_macmic(:ncol,:) = qrain_mg_macmic(:ncol,:)-qrsedten(:ncol,:) - endif - if (qisedten_idx.gt.0) then - call pbuf_get_field(pbuf, qisedten_idx, qisedten) - qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qisedten(:ncol,:) - endif - if (qssedten_idx.gt.0) then - call pbuf_get_field(pbuf, qssedten_idx, qssedten) - qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qssedten(:ncol,:) - endif - if (qgsedten_idx.gt.0) then - call pbuf_get_field(pbuf, qgsedten_idx, qgsedten) - qsnow_mg_macmic(:ncol,:) = qsnow_mg_macmic(:ncol,:)-qgsedten(:ncol,:) - endif - endif - - end do ! end substepping over macrophysics/microphysics - - call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) - call outfld( 'VTEND_MACROP', ptend_macp_all%v, pcols, lchnk) - call physics_ptend_dealloc(ptend_macp_all) - - prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps - snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps - prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps - snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps - prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) - snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) - - if (compute_enthalpy_flux) then - qrain_mg_idx = pbuf_get_index('qrain_mg' , errcode=i) - qsnow_mg_idx = pbuf_get_index('qsnow_mg' , errcode=i) - call pbuf_get_field(pbuf, qrain_mg_idx, qrain_mg) - call pbuf_get_field(pbuf, qsnow_mg_idx, qsnow_mg) - qrain_mg(:ncol,:) = qrain_mg_macmic(:ncol,:)/cld_macmic_num_steps - qsnow_mg(:ncol,:) = qsnow_mg_macmic(:ncol,:)/cld_macmic_num_steps - endif - endif - - ! Add the precipitation from CARMA to the precipitation from stratiform. - if (carma_do_cldice .or. carma_do_cldliq) then - prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) - snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) - end if - - if ( .not. deep_scheme_does_scav_trans() ) then - - ! ------------------------------------------------------------------------------- - ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. - ! 2. Convective Transport of Non-Water Aerosol Species. - ! - ! . Aerosol wet chemistry determines scavenging fractions, and transformations - ! . Then do convective transport of all trace species except qv,ql,qi. - ! . We needed to do the scavenging first to determine the interstitial fraction. - ! . When UNICON is used as unified convection, we should still perform - ! wet scavenging but not 'convect_deep_tend2'. - ! ------------------------------------------------------------------------------- - - call t_startf('aerosol_wet_processes') - if (clim_modal_aero) then - if (prog_modal_aero) then - call physics_ptend_init(ptend, state%psetcols, 'aero_water_uptake', lq=wetdep_lq) - ! Do calculations of mode radius and water uptake if: - ! 1) modal aerosols are affecting the climate, or - ! 2) prognostic modal aerosols are enabled - call modal_aero_calcsize_sub(state, ptend, ztodt, pbuf) - ! for prognostic modal aerosols the transfer of mass between aitken and accumulation - ! modes is done in conjunction with the dry radius calculation - call modal_aero_wateruptake_dr(state, pbuf) - call physics_update(state, ptend, ztodt, tend) - else - call modal_aero_calcsize_diag(state, pbuf) - call modal_aero_wateruptake_dr(state, pbuf) - endif - endif - - if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) - if ( (trim(cam_take_snapshot_after) == "aero_model_wetdep") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - if (carma_do_wetdep) then - ! CARMA wet deposition - ! - ! NOTE: It needs to follow aero_model_wetdep, so that - ! cam_out%xxxwetxxx - ! fields have already been set for CAM aerosols and cam_out can be - ! added - ! to for CARMA aerosols. - call t_startf ('carma_wetdep_tend') - call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('carma_wetdep_tend') - end if - - call t_startf ('convect_deep_tend2') - call convect_deep_tend_2( state, ptend, ztodt, pbuf ) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('convect_deep_tend2') - - ! check tracer integrals - call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) - - call t_stopf('aerosol_wet_processes') - - endif - - !=================================================== - ! Moist physical parameteriztions complete: - ! send dynamical variables, and derived variables to history file - !=================================================== - - call t_startf('bc_history_write') - call diag_phys_writeout(state, pbuf) - call diag_conv(state, ztodt, pbuf) - - call t_stopf('bc_history_write') - - !=================================================== - ! Write cloud diagnostics on history file - !=================================================== - - call t_startf('bc_cld_diag_history_write') - - call cloud_diagnostics_calc(state, pbuf) - - call t_stopf('bc_cld_diag_history_write') - - !=================================================== - ! Radiation computations - !=================================================== - call t_startf('radiation') - - if (trim(cam_take_snapshot_before) == "radiation_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) - - ! Set net flux used by spectral dycores - do i=1,ncol - tend%flx_net(i) = net_flx(i) - end do - - if ( (trim(cam_take_snapshot_after) == "radiation_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "radiation_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call check_energy_cam_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) - - call t_stopf('radiation') - - ! Diagnose the location of the tropopause and its location to the history file(s). - call t_startf('tropopause') - call tropopause_output(state) - call t_stopf('tropopause') - - !=================================================== - ! Source/sink terms for advected tracers. - !=================================================== - call t_startf('adv_tracer_src_snk') - ! Test tracers - - if (trim(cam_take_snapshot_before) == "aoa_tracers_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call aoa_tracers_timestep_tend(state, ptend, ztodt) - if ( (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & - cam_in%cflx) - - if (trim(cam_take_snapshot_before) == "co2_cycle_set_ptend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call co2_cycle_set_ptend(state, pbuf, ptend) - if ( (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - !=================================================== - ! Chemistry and MAM calculation - ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. - ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and - ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before - ! Gas chemistry and MAM core aerosol conversion. - ! Note that surface flux is not added into the atmosphere, but elevated emission is - ! added into the atmosphere as tendency. - !=================================================== - if (chem_is_active()) then - - if (trim(cam_take_snapshot_before) == "chem_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & - pbuf, fh2o=fh2o) - - - if ( (trim(cam_take_snapshot_after) == "chem_timestep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "chem_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call check_energy_cam_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) - call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & - cam_in%cflx) - end if - call t_stopf('adv_tracer_src_snk') - - !=================================================== - ! Vertical diffusion/pbl calculation - ! Call vertical diffusion (apply tracer emissions, molecular diffusion and pbl form drag) - !=================================================== - - call t_startf('vertical_diffusion_tend') - - if (trim(cam_take_snapshot_before) == "vertical_diffusion_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call vertical_diffusion_tend (ztodt ,state , cam_in, & - surfric ,obklen ,ptend ,ast ,pbuf ) - - !------------------------------------------ - ! Call major diffusion for extended model - !------------------------------------------ - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call waccmx_phys_mspd_tend (ztodt ,state ,ptend) - endif - - if ( (trim(cam_take_snapshot_after) == "vertical_diffusion_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_VDIFF', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_VDIFF', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "vertical_diffusion_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call t_stopf ('vertical_diffusion_tend') - - !=================================================== - ! Rayleigh friction calculation - !=================================================== - call t_startf('rayleigh_friction') - call rayleigh_friction_tend( ztodt, state, ptend) - if ( ptend%lu ) then - call outfld( 'UTEND_RAYLEIGH', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_RAYLEIGH', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - call t_stopf('rayleigh_friction') - - if (do_clubb_sgs) then - call check_energy_cam_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) - else - call check_energy_cam_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & - zero, cam_in%shf) - endif - - call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) - - ! aerosol dry deposition processes - call t_startf('aero_drydep') - - if (trim(cam_take_snapshot_before) == "aero_model_drydep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) - if ( (trim(cam_take_snapshot_after) == "aero_model_drydep") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "aero_model_drydep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call t_stopf('aero_drydep') - - ! CARMA microphysics - ! - ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing - ! the dry - ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, - ! so that - ! obklen and surfric have been calculated. It needs to follow - ! aero_model_drydep, so - ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and - ! cam_out - ! can be added to for CARMA aerosols. - if (carma_do_aerosol) then - call t_startf('carma_timestep_tend') - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) - call physics_update(state, ptend, ztodt, tend) - - call check_energy_cam_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) - call t_stopf('carma_timestep_tend') - end if - - !--------------------------------------------------------------------------------- - ! ... enforce charge neutrality - !--------------------------------------------------------------------------------- - call charge_balance(state, pbuf) - - !=================================================== - ! Gravity wave drag - !=================================================== - call t_startf('gw_tend') - - if (trim(cam_take_snapshot_before) == "gw_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) - - if ( (trim(cam_take_snapshot_after) == "gw_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_GWDTOT', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_GWDTOT', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "gw_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - ! Check energy integrals - call check_energy_cam_chng(state, tend, "gwdrag", nstep, ztodt, zero, & - zero, zero, flx_heat) - call t_stopf('gw_tend') - - ! QBO relaxation - - if (trim(cam_take_snapshot_before) == "qbo_relax") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - call qbo_relax(state, pbuf, ptend) - if ( (trim(cam_take_snapshot_after) == "qbo_relax") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_QBORLX', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_QBORLX', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "qbo_relax") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - ! Check energy integrals - call check_energy_cam_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) - - ! Lunar tides - call lunar_tides_tend( state, ptend ) - if ( ptend%lu ) then - call outfld( 'UTEND_LUNART', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_LUNART', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - ! Check energy integrals - call check_energy_cam_chng(state, tend, "lunar_tides", nstep, ztodt, zero, zero, zero, zero) - - ! Ion drag calculation - call t_startf ( 'iondrag' ) - - if (trim(cam_take_snapshot_before) == "iondrag_calc_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - - if ( do_waccm_ions ) then - call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) - else - call iondrag_calc( lchnk, ncol, state, ptend) - endif - !---------------------------------------------------------------------------- - ! Call ionosphere routines for extended model if mode is set to ionosphere - !---------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) - endif - - if ( (trim(cam_take_snapshot_after) == "iondrag_calc_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_IONDRG', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_IONDRG', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "iondrag_calc_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call tot_energy_phys(state, 'phAP') - call tot_energy_phys(state, 'dyAP',vc=vc_dycore) - - !--------------------------------------------------------------------------------- - ! Enforce charge neutrality after O+ change from ionos_tend - !--------------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call charge_balance(state, pbuf) - endif - - ! Check energy integrals - call check_energy_cam_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) - - call t_stopf ( 'iondrag' ) - - ! Update Nudging values, if needed - !---------------------------------- - if((Nudge_Model).and.(Nudge_ON)) then - call nudging_timestep_tend(state,ptend) - if ( ptend%lu ) then - call outfld( 'UTEND_NDG', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_NDG', ptend%v, pcols, lchnk) - end if - call physics_update(state,ptend,ztodt,tend) - call check_energy_cam_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) - endif - - if (compute_enthalpy_flux) then - - ! conserve energy - if (.not.dycore_is('SE')) then - call endrun("Explicit enthalpy flux functionality only supported for SE dycore") - end if - call enthalpy_adjustment(ncol,lchnk,state,cam_in,cam_out,pbuf,ztodt,itim_old,& - qini(:,:),totliqini(:,:),toticeini(:,:),tend) - else - - ! standard CAM (violate energy conservation) - !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - ! Save total energy for global fixer in next timestep - ! - ! This call must be after the last parameterization and call to physics_update - ! - call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) - ! - ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust - ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. - moist_mixing_ratio_dycore = dycore_is('LR').or. dycore_is('FV3') - ! - ! update cp/cv for energy computation based in updated water variables - ! - call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore,& - to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) - - ! for dry mixing ratio dycore, physics_dme_adjust is called for energy diagnostic purposes only. - ! So, save off tracers - if (.not.moist_mixing_ratio_dycore) then - ! - ! for dry-mixing ratio based dycores dme_adjust takes place in the dynamical core - ! - ! only compute dme_adjust for diagnostics purposes - ! - if (thermo_budget_history) then - tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) - tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) - tmp_ps(:ncol) = state%ps(:ncol) - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - ! Restore pre-"physics_dme_adjust" tracers - state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) - state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) - state%ps(:ncol) = tmp_ps(:ncol) - end if - else - ! - ! for moist-mixing ratio based dycores - ! - ! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call - ! - call set_dry_to_wet(state, convert_cnst_type='dry') - - if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) - if (trim(cam_take_snapshot_after) == "physics_dme_adjust") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - endif - - if (vc_dycore == vc_height.or.vc_dycore == vc_dry_pressure) then - ! - ! MPAS and SE specific scaling of temperature for enforcing energy consistency - ! (and to make sure that temperature dependent diagnostic tendencies - ! are computed correctly; e.g. dtcore) - ! - scaling(1:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv_dycore(:ncol,:,lchnk) - state%T(1:ncol,:) = state%temp_ini(1:ncol,:)+& - scaling(1:ncol,:)*(state%T(1:ncol,:)-state%temp_ini(1:ncol,:)) - tend%dtdt(:ncol,:) = scaling(:ncol,:)*tend%dtdt(:ncol,:) - ! - ! else: do nothing for dycores with energy consistent with CAM physics - ! - endif - endif - - - ! store T, U, and V in buffer for use in computing dynamics T-tendency in next timestep - do k = 1,pver - dtcore(:ncol,k) = state%t(:ncol,k) - dqcore(:ncol,k) = state%q(:ncol,k,ixq) - ducore(:ncol,k) = state%u(:ncol,k) - dvcore(:ncol,k) = state%v(:ncol,k) - end do - - !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - if (aqua_planet) then - labort = .false. - do i=1,ncol - if (cam_in%ocnfrac(i) /= 1._r8) then - labort = .true. - if (masterproc) write(iulog,*) 'oceanfrac(',i,')=',cam_in%ocnfrac(i) - end if - end do - if (labort) then - call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') - endif - endif - - call diag_phys_tend_writeout (state, pbuf, tend, ztodt, qini, cldliqini, cldiceini) - - call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) - - end subroutine tphysac - - subroutine tphysbc (ztodt, state, & - tend, pbuf, & - cam_out, cam_in ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Evaluate and apply physical processes that are calculated BEFORE - ! coupling to land, sea, and ice models. - ! - ! Processes currently included are: - ! - ! o Resetting Negative Tracers to Positive - ! o Global Mean Total Energy Fixer - ! o Dry Adjustment - ! o Asymmetric Turbulence Scheme - Deep Convection & Shallow Convection - ! - ! Method: - ! - ! Each parameterization should be implemented with this sequence of calls: - ! 1) Call physics interface - ! 2) Check energy - ! 3) Call physics_update - ! See Interface to Column Physics and Chemistry Packages - ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html - ! - !----------------------------------------------------------------------- - - use physics_buffer, only: physics_buffer_desc, pbuf_get_field - use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx - use physics_buffer, only: col_type_subcol, dyn_time_lvls - - use dadadj_cam, only: dadadj_tend - use physics_types, only: physics_update, & - physics_state_check, & - dyn_te_idx - use physconst, only: rair, gravit - use cam_diagnostics, only: diag_conv_tend_ini, diag_export, diag_state_b4_phys_write - use cam_diagnostic_utils, only: cpslec - use cam_history, only: outfld - use constituents, only: qmin - use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx - use air_composition, only: compute_enthalpy_flux, num_enthalpy_vars, cp_or_cv_dycore - use physics_buffer, only: pbuf_set_field - use convect_deep, only: convect_deep_tend - use time_manager, only: is_first_step, get_nstep - use convect_diagnostics,only: convect_diagnostics_calc - use check_energy, only: check_energy_cam_chng, check_energy_cam_fix - use check_energy, only: check_tracers_data, check_tracers_init - use check_energy, only: tot_energy_phys - use dycore, only: dycore_is - use radiation, only: radiation_tend - use perf_mod - use mo_gas_phase_chemdr,only: map2chm - use clybry_fam, only: clybry_fam_adj - use cam_abortutils, only: endrun - use subcol_utils, only: is_subcol_on - use qneg_module, only: qneg3 - use cam_snapshot, only: cam_snapshot_all_outfld_tphysbc - use cam_snapshot_common, only: cam_snapshot_ptend_outfld - use dyn_tests_utils, only: vc_dycore - use surface_emissions_mod,only: surface_emissions_set - use elevated_emissions_mod,only: elevated_emissions_set - use air_composition, only: te_init,cpairv,compute_enthalpy_flux !xxx - use cam_thermo, only: get_hydrostatic_energy !xxx - - ! Arguments - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) - - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in - - - ! - !---------------------------Local workspace----------------------------- - ! - - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - - integer :: nstep ! current timestep number - - real(r8) :: net_flx(pcols) - - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation - - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) rtdt ! 1./ztodt - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. - integer :: m, m_cnst - - ! physics buffer fields to compute tendencies for stratiform package - integer itim_old, ifld - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - - ! physics buffer fields for total energy and mass adjustment - real(r8), pointer, dimension(: ) :: teout - real(r8), pointer, dimension(:,:) :: qini - real(r8), pointer, dimension(:,:) :: cldliqini - real(r8), pointer, dimension(:,:) :: cldiceini - real(r8), pointer, dimension(:,:) :: totliqini - real(r8), pointer, dimension(:,:) :: toticeini - real(r8), pointer, dimension(:,:) :: dtcore - real(r8), pointer, dimension(:,:) :: dqcore - real(r8), pointer, dimension(:,:) :: ducore - real(r8), pointer, dimension(:,:) :: dvcore - - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - - real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. - real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid - - ! convective precipitation variables - real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8),pointer :: snow_dp(:) ! snow from ZM convection - real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8),pointer :: snow_sh(:) ! snow from Hack convection - - ! stratiform precipitation variables - real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) - real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) - real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns - real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns - real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme - real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme - real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation - real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation - - ! energy checking variables - real(r8) :: zero(pcols) ! array of zeros - real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme - real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) - type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes - real(r8) :: zero_tracers(pcols,pcnst) - - real(r8), pointer :: psl(:) ! Sea Level Pressure - - logical :: lq(pcnst) - - !----------------------------------------------------------------------- - - call t_startf('bc_init') - - zero = 0._r8 - zero_tracers(:,:) = 0._r8 - zero_sc(:) = 0._r8 - - lchnk = state%lchnk - ncol = state%ncol - - rtdt = 1._r8/ztodt - - nstep = get_nstep() - - ! Associate pointers with physics buffer fields - itim_old = pbuf_old_tim_idx() - ifld = pbuf_get_index('CLD') - call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) - - call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) - - call pbuf_get_field(pbuf, qini_idx, qini) - call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) - call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - call pbuf_get_field(pbuf, totliqini_idx, totliqini) - call pbuf_get_field(pbuf, toticeini_idx, toticeini) - - call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - ifld = pbuf_get_index('FRACIS') - call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - fracis (:ncol,:,1:pcnst) = 1._r8 - - ! Set physics tendencies to 0 - tend%dTdt(:ncol,:pver) = 0._r8 - tend%dudt(:ncol,:pver) = 0._r8 - tend%dvdt(:ncol,:pver) = 0._r8 - - ! Verify state coming from the dynamics - if (state_debug_checks) then - call physics_state_check(state, name="before tphysbc (dycore?)") - end if - - call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) - - ! Since clybry_fam_adj operates directly on the tracers, and has no - ! physics_update call, re-run qneg3. - call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,state%q ) - - ! Validate output of clybry_fam_adj. - if (state_debug_checks) then - call physics_state_check(state, name="clybry_fam_adj") - end if - ! - ! Dump out "before physics" state - ! - call diag_state_b4_phys_write (state) - - ! compute mass integrals of input tracers state - call check_tracers_init(state, tracerint) - - call t_stopf('bc_init') - - call cnst_get_ind('Q', ixq) - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - qini (:ncol,:pver) = state%q(:ncol,:pver, ixq) - cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) - cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - - totliqini(:ncol,:pver) = 0.0_r8 - do m_cnst=1,thermodynamic_active_species_liq_num - m = thermodynamic_active_species_liq_idx(m_cnst) - totliqini(:ncol,:pver) = totliqini(:ncol,:pver)+state%q(:ncol,:pver,m) - end do - toticeini(:ncol,:pver) = 0.0_r8 - do m_cnst=1,thermodynamic_active_species_ice_num - m = thermodynamic_active_species_ice_idx(m_cnst) - toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) - end do - - ! compute energy variables for state at the beginning of physics - xxx - if (compute_enthalpy_flux) then - call get_hydrostatic_energy(state%q(1:ncol,1:pver,1:pcnst),.true., & - state%pdel(1:ncol,1:pver), cp_or_cv_dycore(:ncol,:,lchnk), & - state%u(1:ncol,1:pver), state%v(1:ncol,1:pver), state%T(1:ncol,1:pver),& - vc_dycore, ptop=state%pintdry(1:ncol,1), phis = state%phis(1:ncol), & - te = te_init(:ncol,1,lchnk), se=te_init(:ncol,2,lchnk), po=te_init(:ncol,3,lchnk), ke=te_init(:ncol,4,lchnk)) - endif - - ! postponed call to fixer - !=================================================== - ! Global mean total energy fixer - !=================================================== - - call t_startf('energy_fixer') - - call tot_energy_phys(state, 'phBF') - call tot_energy_phys(state, 'dyBF',vc=vc_dycore) - - if (.not.dycore_is('EUL')) then - call check_energy_cam_fix(state, ptend, nstep, flx_heat) - call physics_update(state, ptend, ztodt, tend) - call check_energy_cam_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) - call outfld( 'EFIX', flx_heat , pcols, lchnk ) - end if - - call tot_energy_phys(state, 'phBP') - call tot_energy_phys(state, 'dyBP',vc=vc_dycore) - ! Save state for convective tendency calculations. - call diag_conv_tend_ini(state, pbuf) - - call outfld('TEOUT', teout , pcols, lchnk ) - call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) - call outfld('TEFIX', state%te_cur(:,dyn_te_idx), pcols, lchnk ) - - ! T, U, V tendency due to dynamics - if ( nstep > dyn_time_lvls-1 ) then - dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt - dqcore(:ncol,:pver) = (state%q(:ncol,:pver,ixq) - dqcore(:ncol,:pver))/ztodt - ducore(:ncol,:pver) = (state%u(:ncol,:pver) - ducore(:ncol,:pver))/ztodt - dvcore(:ncol,:pver) = (state%v(:ncol,:pver) - dvcore(:ncol,:pver))/ztodt - call outfld( 'DTCORE', dtcore, pcols, lchnk ) - call outfld( 'DQCORE', dqcore, pcols, lchnk ) - call outfld( 'UTEND_CORE', ducore, pcols, lchnk ) - call outfld( 'VTEND_CORE', dvcore, pcols, lchnk ) - end if - - call t_stopf('energy_fixer') - - call surface_emissions_set( lchnk, ncol, pbuf ) - call elevated_emissions_set( lchnk, ncol, pbuf ) - - ! - !=================================================== - ! Dry adjustment - !=================================================== - call t_startf('dry_adjustment') - - if (trim(cam_take_snapshot_before) == "dadadj_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - - call dadadj_tend(ztodt, state, ptend) - - if ( (trim(cam_take_snapshot_after) == "dadadj_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "dadadj_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - - call t_stopf('dry_adjustment') - - !=================================================== - ! Moist convection - !=================================================== - call t_startf('moist_convection') - - call t_startf ('convect_deep_tend') - - if (trim(cam_take_snapshot_before) == "convect_deep_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - - call convect_deep_tend( & - cmfmc, cmfcme, & - zdu, & - rliq, rice, & - ztodt, & - state, ptend, cam_in%landfrac, pbuf) - - if ( (trim(cam_take_snapshot_after) == "convect_deep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - - if ( ptend%lu ) then - call outfld( 'UTEND_DCONV', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_DCONV', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "convect_deep_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - - call t_stopf('convect_deep_tend') - - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) - - call pbuf_get_field(pbuf, prec_str_idx, prec_str ) - call pbuf_get_field(pbuf, snow_str_idx, snow_str ) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) - - if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) - end if - - ! Check energy integrals, including "reserved liquid" - flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) - snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) - call check_energy_cam_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) - snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) - - !=================================================== - ! Compute convect diagnostics - !=================================================== - - if (dlfzm_idx > 0) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - dlf(:ncol,:) = dlfzm(:ncol,:) - else - dlf(:,:) = 0._r8 - end if - - if (trim(cam_take_snapshot_before) == "convect_diagnostics_calc") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - call convect_diagnostics_calc (ztodt , cmfmc, & - dlf , dlf2 , rliq , rliq2, & - state , pbuf) - if ( (trim(cam_take_snapshot_after) == "convect_diagnostics_calc") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - - ! add reserve liquid to pbuf - call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) - rliqbc(:ncol) = rliq(:ncol) - - call t_stopf('moist_convection') - - if (is_first_step()) then - - !initiailize sedimentation arrays - prec_pcw = 0._r8 - snow_pcw = 0._r8 - prec_sed = 0._r8 - snow_sed = 0._r8 - prec_str = 0._r8 - snow_str = 0._r8 - - ! In first time-step tphysac variables need to be zero'd out - if (compute_enthalpy_flux) then - ifld = pbuf_get_index('ENTHALPY_PREC_AC', errcode=i) - if (ifld>0) call pbuf_set_field(pbuf, ifld, 0._r8) - end if - - if (is_subcol_on()) then - prec_str_sc = 0._r8 - snow_str_sc = 0._r8 - end if - - ! OSLO_AERO begin - !=================================================== - ! Run wet deposition routines to intialize aerosols - ! NOT CALLED IN OSLO AERO - !=================================================== - ! OSLO_AERO end - - !=================================================== - ! Radiation computations - ! initialize fluxes only, do not update state - !=================================================== - - call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) - - end if - - ! Save atmospheric fields to force surface models - call t_startf('cam_export') - call pbuf_get_field(pbuf, psl_idx, psl) - call cpslec(ncol, state%pmid, state%phis, state%ps, state%t, psl, gravit, rair) - call cam_export (state,cam_in,cam_out,pbuf) - call t_stopf('cam_export') - - ! Write export state to history file - call t_startf('diag_export') - call diag_export(cam_out) - call t_stopf('diag_export') - - ! output these here -- after updates by chem_timestep_tend or export_fields within the current time step - if (associated(cam_out%nhx_nitrogen_flx)) then - call outfld('a2x_NHXDEP', cam_out%nhx_nitrogen_flx, pcols, lchnk) - end if - if (associated(cam_out%noy_nitrogen_flx)) then - call outfld('a2x_NOYDEP', cam_out%noy_nitrogen_flx, pcols, lchnk) - end if - - end subroutine tphysbc - -subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) -!----------------------------------------------------------------------------------- -! -! Purpose: The place for parameterizations to call per timestep initializations. -! Generally this is used to update time interpolated fields from boundary -! datasets. -! -!----------------------------------------------------------------------------------- - use chemistry, only: chem_timestep_init - use chem_surfvals, only: chem_surfvals_set - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc - use carma_intr, only: carma_timestep_init - use ghg_data, only: ghg_data_timestep_init - use aoa_tracers, only: aoa_tracers_timestep_init - use vertical_diffusion, only: vertical_diffusion_ts_init - use radheat, only: radheat_timestep_init - use solar_data, only: solar_data_advance - use qbo, only: qbo_timestep_init - use iondrag, only: do_waccm_ions, iondrag_timestep_init - use perf_mod - - use prescribed_ozone, only: prescribed_ozone_adv - use prescribed_ghg, only: prescribed_ghg_adv - use prescribed_aero, only: prescribed_aero_adv - use aerodep_flx, only: aerodep_flx_adv - use aircraft_emit, only: aircraft_emit_adv - use prescribed_volcaero, only: prescribed_volcaero_adv - use prescribed_strataero,only: prescribed_strataero_adv - use mo_apex, only: mo_apex_init - use epp_ionization, only: epp_ionization_active - use iop_forcing, only: scam_use_iop_srf - use nudging, only: Nudge_Model, nudging_timestep_init - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_timestep_init - use phys_grid_ctem, only: phys_grid_ctem_diags - use surface_emissions_mod,only: surface_emissions_adv - use elevated_emissions_mod,only: elevated_emissions_adv - ! OSLO_AERO begin - use oslo_aero_ocean, only: oslo_aero_ocean_adv - ! OSLO_AERO end - - implicit none - - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in - type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - !----------------------------------------------------------------------------- - - if (single_column) call scam_use_iop_srf(cam_in) - - ! update geomagnetic coordinates - if (epp_ionization_active .or. do_waccm_ions) then - call mo_apex_init(phys_state) - endif - - ! Chemistry surface values - call chem_surfvals_set() - call surface_emissions_adv(pbuf2d, phys_state) - call elevated_emissions_adv(pbuf2d, phys_state) - - ! Solar irradiance - call solar_data_advance() - - ! Time interpolate for chemistry. - call chem_timestep_init(phys_state, pbuf2d) - - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_timestep_init(phys_state,pbuf2d) - endif - - ! Prescribed tracers - call prescribed_ozone_adv(phys_state, pbuf2d) - call prescribed_ghg_adv(phys_state, pbuf2d) - call prescribed_aero_adv(phys_state, pbuf2d) - call aircraft_emit_adv(phys_state, pbuf2d) - call prescribed_volcaero_adv(phys_state, pbuf2d) - call prescribed_strataero_adv(phys_state, pbuf2d) - ! OSLO_AERO begin - call oslo_aero_ocean_adv(phys_state, pbuf2d) - ! OSLO_AERO end - - ! prescribed aerosol deposition fluxes - call aerodep_flx_adv(phys_state, pbuf2d, cam_out) - - ! Time interpolate data models of gasses in pbuf2d - call ghg_data_timestep_init(pbuf2d, phys_state) - - ! Upper atmosphere radiative processes - call radheat_timestep_init(phys_state, pbuf2d) - - ! Time interpolate for vertical diffusion upper boundary condition - call vertical_diffusion_ts_init(pbuf2d, phys_state) - - !---------------------------------------------------------------------- - ! update QBO data for this time step - !---------------------------------------------------------------------- - call qbo_timestep_init - - call iondrag_timestep_init() - - call carma_timestep_init() - - ! age of air tracers - call aoa_tracers_timestep_init(phys_state) - - ! Update Nudging values, if needed - !---------------------------------- - if(Nudge_Model) call nudging_timestep_init(phys_state) - - ! Update TEM diagnostics - call phys_grid_ctem_diags(phys_state) - -end subroutine phys_timestep_init - -end module physpkg diff --git a/src/utils/air_composition.F90 b/src/utils/air_composition.F90 index 4826e844c6..5db350d4ba 100644 --- a/src/utils/air_composition.F90 +++ b/src/utils/air_composition.F90 @@ -26,7 +26,7 @@ module air_composition ! get_mbarv: molecular weight of dry air public :: get_mbarv ! - ! for book keeping of enthalpy variables in physics buffer + ! enthalpy variables in physics buffer ! integer, parameter, public :: num_enthalpy_vars = 4 ! index for enthalpy flux associated with liquid precipitation integer, parameter, public :: hliq_idx = 1 ! index for enthalpy flux associated with liquid precipitation @@ -34,12 +34,13 @@ module air_composition integer, parameter, public :: fliq_idx = 3 ! index for flux of liquid precipitation integer, parameter, public :: fice_idx = 4 ! index for flux of frozen precipitation + logical, protected, public :: compute_enthalpy_flux ! obtained from nuopc mediator + private :: air_species_info integer, parameter :: unseti = -HUGE(1) real(r8), parameter :: unsetr = HUGE(1.0_r8) - logical, protected, public :: compute_enthalpy_flux ! composition of air ! @@ -204,9 +205,6 @@ subroutine air_composition_readnl(nlfile) len(water_species_in_air)*num_names_max, mpi_character, & masterprocid, mpicom, ierr) if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: water_species_in_air") - call mpi_bcast(compute_enthalpy_flux, 1, mpi_logical, & - masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: compute_enthalpy_flux") dry_air_species_num = 0 water_species_in_air_num = 0 @@ -225,9 +223,6 @@ subroutine air_composition_readnl(nlfile) dry_air_species_num + water_species_in_air_num if (masterproc) then - if (compute_enthalpy_flux) then - write(iulog, *) "Computing enthalpy flux: compute_enthalpy_flux=",compute_enthalpy_flux - endif write(iulog, *) banner write(iulog, *) bline @@ -247,10 +242,6 @@ subroutine air_composition_readnl(nlfile) do indx = 1, water_species_in_air_num write(iulog, *) ' ', trim(water_species_in_air(indx)) end do - if (compute_enthalpy_flux) then - write(iulog, *) ' ' - write(iulog, *) 'CAM computes enthalpy flux and sends to surface.' - end if write(iulog, *) bline write(iulog, *) banner end if @@ -267,6 +258,7 @@ subroutine air_composition_init(compute_enthalpy_flux_in) use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry, cpwv, latice, latvap, tmelt use constituents, only: cnst_get_ind, cnst_mw use ppgrid, only: pcols, pver, begchunk, endchunk + use spmd_utils, only: masterproc ! Arguments logical, intent(in) :: compute_enthalpy_flux_in @@ -306,6 +298,14 @@ subroutine air_composition_init(compute_enthalpy_flux_in) ! Set module variable compute_enthalpy_flux compute_enthalpy_flux = compute_enthalpy_flux_in + if (masterproc) then + if (compute_enthalpy_flux) then + write(iulog, *) ' ' + write(iulog, *) 'CAM computes enthalpy flux and sends it to surface.' + else + write(iulog, *) 'CAM does not compute enthalpy flux. ' + end if + end if liq_num = 0 ice_num = 0 From a440147026393df56087f4df8559ea341f4b7bf6 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 30 Sep 2025 22:26:34 +0200 Subject: [PATCH 21/78] fixed order of dependence on compute_canopy_fluxes --- src/control/cam_comp.F90 | 9 ++++++-- src/utils/air_composition.F90 | 43 ++++++++++++++++++++--------------- 2 files changed, 32 insertions(+), 20 deletions(-) diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index c911d0addb..c55a0d6a70 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -28,6 +28,7 @@ module cam_comp use perf_mod use cam_logfile, only: iulog use cam_abortutils, only: endrun +use air_composition, only: air_composition_register implicit none private @@ -170,14 +171,18 @@ subroutine cam_init( & ! Register zonal average grid for phys TEM diagnostics call phys_grid_ctem_reg() + ! Need to call this before phys_register - sets module variable + ! compute_enthalpy_flux in air_composition_register + call air_composition_register(compute_enthalpy_flux) + ! Register advected tracers and physics buffer fields - call phys_register () + call phys_register() ! Initialize ghg surface values before default initial distributions ! are set in dyn_init call chem_surfvals_init() - call air_composition_init(compute_enthalpy_flux) + call air_composition_init() ! initialize ionosphere call ionosphere_init() diff --git a/src/utils/air_composition.F90 b/src/utils/air_composition.F90 index 5db350d4ba..8203959f07 100644 --- a/src/utils/air_composition.F90 +++ b/src/utils/air_composition.F90 @@ -10,6 +10,7 @@ module air_composition private save + public :: air_composition_register ! sets module variable compute_enthalpy_flux public :: air_composition_readnl public :: air_composition_init public :: dry_air_composition_update @@ -34,7 +35,7 @@ module air_composition integer, parameter, public :: fliq_idx = 3 ! index for flux of liquid precipitation integer, parameter, public :: fice_idx = 4 ! index for flux of frozen precipitation - logical, protected, public :: compute_enthalpy_flux ! obtained from nuopc mediator + logical, protected, public :: compute_enthalpy_flux = .false. ! obtained from nuopc mediator private :: air_species_info @@ -158,8 +159,29 @@ module air_composition CONTAINS - ! Read namelist variables. + subroutine air_composition_register(compute_enthalpy_flux_in) + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + + logical, intent(in) :: compute_enthalpy_flux_in + + ! Set module variable compute_enthalpy_flux + compute_enthalpy_flux = compute_enthalpy_flux_in + if (masterproc) then + if (compute_enthalpy_flux) then + write(iulog, *) ' ' + write(iulog, *) 'CAM computes enthalpy flux and sends it to surface.' + else + write(iulog, *) 'CAM does not compute enthalpy flux. ' + end if + end if + + end subroutine air_composition_register + + !=========================================================================== + subroutine air_composition_readnl(nlfile) + ! Read namelist variables. use namelist_utils, only: find_group_name use spmd_utils, only: masterproc, mpicom, masterprocid use spmd_utils, only: mpi_character, mpi_logical @@ -250,7 +272,7 @@ end subroutine air_composition_readnl !=========================================================================== - subroutine air_composition_init(compute_enthalpy_flux_in) + subroutine air_composition_init() use string_utils, only: int2str use spmd_utils, only: masterproc @@ -258,10 +280,6 @@ subroutine air_composition_init(compute_enthalpy_flux_in) use physconst, only: r_universal, cpair, rair, cpwv, rh2o, cpliq, cpice, mwdry, cpwv, latice, latvap, tmelt use constituents, only: cnst_get_ind, cnst_mw use ppgrid, only: pcols, pver, begchunk, endchunk - use spmd_utils, only: masterproc - - ! Arguments - logical, intent(in) :: compute_enthalpy_flux_in ! Local variables integer :: icnst, ix, isize, ierr, idx @@ -296,17 +314,6 @@ subroutine air_composition_init(compute_enthalpy_flux_in) real(r8), parameter :: cp3 = 0.5_r8 * r_universal * (2._r8 + dof3) !----------------------------------------------------------------------- - ! Set module variable compute_enthalpy_flux - compute_enthalpy_flux = compute_enthalpy_flux_in - if (masterproc) then - if (compute_enthalpy_flux) then - write(iulog, *) ' ' - write(iulog, *) 'CAM computes enthalpy flux and sends it to surface.' - else - write(iulog, *) 'CAM does not compute enthalpy flux. ' - end if - end if - liq_num = 0 ice_num = 0 has_liq = .false. From 23574d5c399d8af116d6e0996b8b179f92a7c7be Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 30 Sep 2025 22:28:50 +0200 Subject: [PATCH 22/78] removed state%hflx_bc and state%hflx_ac since they cause aborts in DEBUG mode and did participate in any computation --- .../camnor_phys/physics/physics_types.F90 | 36 ------------------- 1 file changed, 36 deletions(-) diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 72bbf49add..59f26be8b7 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -113,13 +113,6 @@ module physics_types real(r8), dimension(: ),allocatable :: & tw_ini, &! vertically integrated total water of initial state tw_cur ! vertically integrated total water of new state - ! - ! Array for enthalpy flux calculations - ! - real(r8), dimension(:,:),allocatable :: & - hflx_ac ! enthalpy flux variables after coupler - real(r8), dimension(:,:),allocatable :: & - hflx_bc ! enthalpy flux variables before coupler real(r8), dimension(:,:),allocatable :: & temp_ini, &! Temperature of initial state (used for energy computations) z_ini ! Height of initial state (used for energy computations) @@ -627,13 +620,6 @@ subroutine physics_state_check(state, name) varname="state%te_ini", msg=msg) call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., & varname="state%te_cur", msg=msg) - - !xxx make allocation dependent on if energy budget history is turned on - ! call shr_assert_in_domain(state%hflx_ac(:ncol,num_hflx), is_nan=.false., & - ! varname="state%hflx_ac", msg=msg) - ! call shr_assert_in_domain(state%hflx_bc(:ncol,num_hflx), is_nan=.false., & - ! varname="state%hflx_bc", msg=msg) - call shr_assert_in_domain(state%tw_ini(:ncol ), is_nan=.false., & varname="state%tw_ini", msg=msg) call shr_assert_in_domain(state%tw_cur(:ncol ), is_nan=.false., & @@ -712,14 +698,6 @@ subroutine physics_state_check(state, name) varname="state%te_ini", msg=msg) call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, & varname="state%te_cur", msg=msg) - - ! The following two calls result in crashes with inf when running in DEBUG mode - why - ! do these even exist since they are never used elsewhere - ! call shr_assert_in_domain(state%hflx_bc(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & - ! varname="state%hflx_bc", msg=msg) - ! call shr_assert_in_domain(state%hflx_ac(:ncol,:num_hflx), lt=posinf_r8, gt=neginf_r8, & - ! varname="state%hflx_ac", msg=msg) - call shr_assert_in_domain(state%tw_ini(:ncol ), lt=posinf_r8, gt=neginf_r8, & varname="state%tw_ini", msg=msg) call shr_assert_in_domain(state%tw_cur(:ncol ), lt=posinf_r8, gt=neginf_r8, & @@ -2257,8 +2235,6 @@ subroutine physics_state_copy(state_in, state_out) end do state_out%te_ini (:ncol,:) = state_in%te_ini (:ncol,:) state_out%te_cur (:ncol,:) = state_in%te_cur (:ncol,:) - ! state_out%hflx_ac(:ncol,:) = state_in%hflx_ac(:ncol,:) - ! state_out%hflx_bc(:ncol,:) = state_in%hflx_bc(:ncol,:) state_out%tw_ini (:ncol ) = state_in%tw_ini (:ncol ) state_out%tw_cur (:ncol ) = state_in%tw_cur (:ncol ) @@ -2573,11 +2549,6 @@ subroutine physics_state_alloc(state,lchnk,psetcols) allocate(state%te_cur(psetcols,2), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur') - ! allocate(state%hflx_ac(psetcols,num_hflx), stat=ierr) - ! if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_ac') - ! allocate(state%hflx_bc(psetcols,num_hflx), stat=ierr) - ! if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%hflx_bc') - allocate(state%tw_ini(psetcols ), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini') @@ -2631,8 +2602,6 @@ subroutine physics_state_alloc(state,lchnk,psetcols) state%te_ini (:,:) = inf state%te_cur (:,:) = inf - ! state%hflx_ac (:,:) = inf - ! state%hflx_bc (:,:) = inf state%tw_ini (: ) = inf state%tw_cur (: ) = inf state%temp_ini(:,:) = inf @@ -2739,11 +2708,6 @@ subroutine physics_state_dealloc(state) deallocate(state%te_cur, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur') - ! deallocate(state%hflx_ac, stat=ierr) - ! if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_ac') - ! deallocate(state%hflx_bc, stat=ierr) - ! if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%hflx_bc') - deallocate(state%tw_ini, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini') From d11f78a5a3685a5780fc232511e07b454e6a6271 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 13:02:33 +0200 Subject: [PATCH 23/78] major refactoring of physics_types --- src/physics/cam/check_energy.F90 | 48 +- .../camnor_phys/physics/dme_adjust_camnor.F90 | 736 +++++++++++++++ .../camnor_phys/physics/physics_types.F90 | 888 +----------------- 3 files changed, 814 insertions(+), 858 deletions(-) create mode 100644 src/physics/camnor_phys/physics/dme_adjust_camnor.F90 diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 7ffbacfb97..44865abac5 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -55,6 +55,7 @@ module check_energy public :: check_energy_cam_fix ! add heating rate required for global mean total energy conservation + ! This routine adjusts enthalpy if compute_enthalpy_flux = .true. public :: enthalpy_adjustment ! Private module data @@ -927,6 +928,8 @@ end subroutine check_energy_cam_fix subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, itim_old,& qini,totliqini,toticeini,tend) + ! This routine is called by routine tphysac and is only called if compute_enthalpy_flux is .true. + use camsrfexch, only: cam_in_t, cam_out_t, get_prec_vars use physics_buffer, only: pbuf_get_index, physics_buffer_desc, pbuf_set_field, pbuf_get_field use cam_abortutils, only: endrun @@ -939,22 +942,22 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, use physconst, only: rga, latvap, latice use dyn_tests_utils, only: vc_dycore use cam_thermo, only: get_hydrostatic_energy - use physics_types, only: physics_dme_adjust, dyn_te_idx + use physics_types, only: physics_dme_adjust_camnor, dyn_te_idx use cam_thermo, only: cam_thermo_water_update use cam_history, only: outfld use cam_budget, only: thermo_budget_history use time_manager, only: get_nstep ! Arguments - integer, intent(in) :: ncol, lchnk - type(physics_state), intent(inout) :: state - type(cam_in_t), intent(in ) :: cam_in - type(cam_out_t), intent(inout) :: cam_out - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: ztodt - integer, intent(in) :: itim_old - real(r8), dimension(pcols,pver), intent(in) :: qini, totliqini, toticeini - type(physics_tend ) , intent(inout) :: tend + integer, intent(in) :: ncol, lchnk + type(physics_state), intent(inout) :: state + type(cam_in_t), intent(in ) :: cam_in + type(cam_out_t), intent(inout) :: cam_out + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: ztodt + integer, intent(in) :: itim_old + real(r8), dimension(pcols,pver), intent(in) :: qini, totliqini, toticeini + type(physics_tend ) , intent(inout) :: tend ! Local variables integer:: enthalpy_prec_bc_idx, enthalpy_prec_ac_idx, enthalpy_evop_idx @@ -1162,17 +1165,20 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, snsrc_tot(:ncol,:) = snsrc_pbc(:ncol,:)+snsrc_pac(:ncol,:) !- picerp rof sdleif fubp teg - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt & - , dme_energy_adjust=.true.,step='bc+ac' & - , ntrnprd=rnsrc_tot*ztodt & - , ntsnprd=snsrc_tot*ztodt & - , tevap=tevp, tprec=tprc & - , mflx=water_flux_bc+water_flux_ac & - , eflx=enthalpy_flux_atm & - , mflx_out=mflx_out & - , eflx_out=eflx_out & - , ent_tnd=dsema & - , pdel_rf=pdel_rf ) + ! Adjust the dry mass in each layer back to the value of physics input state + ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. + call physics_dme_adjust_camnor(state, tend, qini, totliqini, toticeini, ztodt & + step='bc+ac', & + ntrnprd=rnsrc_tot*ztodt, & + ntsnprd=snsrc_tot*ztodt, & + tevap=tevp, & + tprec=tprc, & + mflx=water_flux_bc+water_flux_ac, & + eflx=enthalpy_flux_atm, & + mflx_out=mflx_out, & + eflx_out=eflx_out, & + ent_tnd=dsema, & + pdel_rf=pdel_rf ) call outfld('IETEND_DME', dsema , pcols, lchnk) call outfld('EFLX' , enthalpy_flux_atm , pcols, lchnk) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 new file mode 100644 index 0000000000..862a285c67 --- /dev/null +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -0,0 +1,736 @@ +module dme_adjust_camnor + + implicit none + private ! Make default type private to the module + + public :: dme_adjust_camnor_run + +contains + + subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + ent_tnd, pdel_rf) + !----------------------------------------------------------------------- + ! + ! Purpose: Adjust the dry mass in each layer back to the value of physics input state + ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. + ! + ! Method + ! Revised adjustment towards consistency with local energy conservation. + ! Hydrostatic pressure work, de = alpha * dp, where alpha is the specific volume + ! pressure adjustment, is added locally as an source of enthalpy. An enthalpy of + ! mass (water) exchange with the surface is also defined, which should be passed + ! to the surface model components (ocean/land/ice etc). + ! If moist thermodynamics where handled correctly in CAM, the two terms would + ! match, guaranteeing local energy conservation. + ! With the present CAM formulation (constant dry heat capacity, constant latent + ! heat of condensation valid for 0 degree C), consistency demands one of these + ! choices: + ! 1. no pressure work and no boundary enthalpy flux (CESM) + ! 2. correct local pressure work and boundary enthalpy flux equal to (S dp/g) + ! where S=local *dry* static energy of air + ! The boundary enthalpy flux is at present not passed to other model components, + ! so it is treated as internal CAM non-conservation and folded into fix_energy. + ! + ! Author: Thomas Toniazzo (17.07.21) + ! + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, qmin + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use shr_const_mod, only: shr_const_rwv + use ppgrid, only: pcols, pver + use geopotential, only: geopotential_t + use phys_control, only: waccmx_is + use air_composition, only: dry_air_species_num, thermodynamic_active_species_num + use air_composItion, only: thermodynamic_active_species_idx, + use air_composition, only: cpairv, cp_or_cv_dycore + use constituents, only: cnst_get_ind, cnst_type + use cam_thermo, only: inv_conserved_energy + use cam_thermo, only: get_conserved_energy + use cam_thermo, only: cam_thermo_water_update + use dyn_tests_utils, only: vc_dycore, vc_physics + use qneg_module, only: qneg3 + use cam_history, only: outfld + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in) :: dt + character(len=*), intent(in) :: step ! which call in physpkg + real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer + real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation + real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation + real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy + real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy + real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: ent_tnd (pcols) ! column-integrated enthalpy tendency + real(r8), intent(out) :: pdel_rf (pcols,pver) ! ratio old pdel / new pdel + + ! + !---------------------------Local workspace----------------------------- + ! + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k,m ! Longitude, level indices + integer :: ierr ! error flag + real(r8) :: fdq (pcols) ! mass adjustment factor + real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values + real(r8) :: te (pcols,pver) ! conserved energy in layer + real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm (pcols,pver) ! (phi-phis)/g + real(r8) :: cpm (pcols,pver) ! moist air heat capacity + real(r8) :: ttsc (pcols,pver) ! moist air heat capacity + integer :: vcoord + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + real(r8) :: tot_water (pcols ) ! total water (initial, present) + real(r8) :: tot_water_chg(pcols) ! total water change + integer :: m_cnst + real(r8) :: ps_old(pcols) ! old surface pressure + real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) + real(r8) :: pdot (pcols) ! total (lagrangian) pressure adjustment + real(r8) :: pdzp (pcols) ! pressure work term in press adjustment + real(r8) :: edot (pcols) ! advective pressure adjustment + real(r8) :: uf(pcols), vf(pcols) ! work arrays + real(r8) :: tp(pcols,pver) ! work array for T/Tv + real(r8) :: latent(pcols,pver) ! work array for Lq + integer :: ixnumice, ixnumliq + integer :: ixnumsnow, ixnumrain + real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" + real(r8) :: mdq (pcols,pver) ! total water tendency + logical :: hydrostatic = .true. + + ! 5 possibilities (-> = currently reccommended): + ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) + ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) + ! -> 3) conserve_dycore=.true. , bndry_flx_local=.true. (requires fixer to match correct surface fluxes) + ! 4) conserve_physics=.true. , bndry_flx_local=.true. (as 3., plus fixer for atmo energy) + ! 5) conserve_physics=.true. , bndry_flx_surface=.true. (no advantage wrt option 2) + + ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its + ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. + + logical, parameter :: conserve_dycore = .true. + logical, parameter :: bndry_flx_surface = .true. + logical, parameter :: conserve_physics = .not. conserve_dycore + logical, parameter :: bndry_flx_local = .not. bndry_flx_surface + !----------------------------------------------------------------------- + + ! Diagnose boundary enthalpy flux and local heating rates associated to + ! atmospheric moisture change + call dme_bflx(state, tend, qini, liqini, iceini, tevap, tprec, dt, & + htx_cond, mdq, step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & + mflx=mflx, eflx=eflx, eflx_out=eflx_out, mflx_out=mflx_out) + + ! Ajust the dry mass in each layer back to the value of physics input state + ! Adjust air specific enthalpy accordingly + ! Diagnose boundary enthalpy flux + + call cnst_get_ind('NUMICE', ixnumice, abort=.false.) + call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) + call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) + call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') + end if + + !------------------------------------ + ! initialise adjustment loop + !------------------------------------ + + lchnk = state%lchnk + ncol = state%ncol + + ! old surface pressure + ps_old (:ncol) = state%ps(:ncol) + state%ps(:ncol) = state%pint(:ncol,1) + + zm(:ncol,:)=state%zm(:ncol,:) + + if (conserve_dycore) then + vcoord=vc_dycore + cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) + else + vcoord=vc_physics + cpm(:ncol,:)=cpairv(:ncol,:,lchnk) + endif + + do k = 1, pver + tp(:ncol,k) = state%t(:ncol,k) + enddo + + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cpm(:ncol,:) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,state%s(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:),rairv=rairv(:ncol,:,lchnk) & + ,vcoord=vcoord ,refstate='liq' & + ,flatent=latent(:ncol,:),temce=emce(:ncol,:)) + + do k = 1, pver + ! Dp'/Dp + tot_water(:ncol) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + enddo + ! new surface pressure + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + ! make all tracers wet + do m=1,pcnst + if (cnst_type(m).eq.'dry') then + state%q(:ncol,k,m) = state%q(:ncol,k,m)*(1._r8-tot_water(:ncol)) + end if + enddo + enddo + + ! lagrangian & advective pressure change at top interface + pdot (:ncol) = 0._r8 + pdzp (:ncol) = 0._r8 + edot (:ncol) = 0._r8 + + ! store old enthalpy integral + ent_tnd(:ncol)=0._r8 + do k = 1,pver + ent_tnd(:ncol) = ent_tnd(:ncol) - state%pdel(:ncol,k)*state%s(:ncol,k) + enddo + + !------------------------------------ + ! start adjustment loop + !------------------------------------ + do k = 1, pver + + ! new Dp (=:Dp") + pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + + fdq(:ncol) = pdel_new(:ncol,k)/state%pdel(:ncol,k) ! this is Dp"/Dp + + ! wind adjustment increments + uf (:ncol) = 0. + vf (:ncol) = 0. + + ! u,vtmp set to pre-physics u,v from the updated values and the tendencies + utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) + vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) + + ! adjust specific enthalpy + te (:ncol,k) = 0._r8 + + ! lagrangian pressure change *zi at upper interfac + pdzp(:ncol) = pdot(:ncol)*gravit*state%zi(:ncol,k) + + ! lagrangian pressure change at next interface + if(hydrostatic)pdot(:ncol) = pdot(:ncol) + state%pdel(:ncol,k)*mdq(:ncol,k) + + ! layer increment = work (~alpha*dp) + pdzp(:ncol) = (pdot(:ncol)*gravit*state%zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) + + ! enthalpy change due to mass loss and to hydrost. pressure work in full adjustment + te(:ncol,k) = te(:ncol,k) & + + state%s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") + + emce(:ncol,k)*mdq(:ncol,k)/fdq(:ncol) & ! (phi-phis)*dq*(Dp/Dp") + - pdzp(:ncol) & ! del(g*zm*dp) + + htx_cond(:ncol,k) ! EFLX + + ! momentum + uf(:ncol) = uf(:ncol) +state%u(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) + vf(:ncol) = vf(:ncol) +state%v(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) + + ! adjust constituents to conserve mass in each layer + do m = 1, pcnst + ! store unadjusted q for use in next k + state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) + end do + ! adjust L-dependent part of local total enthalpy accordingly + latent(:ncol,k) = latent(:ncol,k)/fdq(:ncol) + + ! adjusted u,v tendencies + tend%dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt + tend%dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt + + ! store unadjusted u,v for use in next k + utmp(:ncol) = state%u(:ncol,k) + vtmp(:ncol) = state%v(:ncol,k) + + ! write adjusted u,v + state%u(:ncol,k) = uf(:ncol) + state%v(:ncol,k) = vf(:ncol) + + ! compute new total pressure variables + state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) + state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) + + ! also update pmid for geopotential + state%pmid (:ncol,k ) = .5_r8*(state%pint(:ncol,k)+state%pint(:ncol,k+1)) + state%lnpmid(:ncol,k ) = log(state%pmid(:ncol,k )) + + pdel_rf(:ncol,k)=state%pdel(:ncol,k)/pdel_new(:ncol,k) + state%pdel (:ncol,k ) = pdel_new(:ncol,k) + state%rpdel (:ncol,k ) = 1._r8/state%pdel(:ncol,k) + + end do + + !------------------------------------ + ! end adjustment loop + !------------------------------------ + + ! make dry tracers dry again + do k = 1, pver + tot_water(:ncol) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + enddo + do m=1,pcnst + if (cnst_type(m).eq.'dry') & + state%q(:ncol,k,m) = state%q(:ncol,k,m)/(1._r8-tot_water(:ncol)) + enddo + enddo + + ! call QNEG3 (cf physics_update) + do m = 1, pcnst + if (m /= ixnumice .and. m /= ixnumliq .and. & + m /= ixnumrain .and. m /= ixnumsnow ) then + call qneg3('dme_adjust', state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m)) + else + do k = 1,pver + state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m)) + state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m)) + end do + end if + enddo + + if (conserve_dycore) then + call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore, & + to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + ttsc(:ncol,:)=cpm(:ncol,:)/cp_or_cv_dycore(:ncol,:,lchnk) + cpm (:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) + endif + + call inv_conserved_energy(levels_are_moist & + ,1 ,pver & + ,te(:ncol,:) & + ,cpm(:ncol,:) & + ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,tp(:ncol,:) & + ,flatent=latent(:ncol,:)*0._r8 & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,vcoord=vcoord ,refstate='liq' & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:)) + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 + else + zvirv(:,:) = zvir + endif + + ! diagnostics: dme T tendency + ttsc(:ncol,:) =(tp(:ncol,:) - state%t(:ncol,:))/dt ! & + + ! for tests: correct for effect of cp update on other physics ttend + ! -tend%dtdt(:ncol,:)*(ttsc(:ncol,:)-1._r8) + + call outfld('PTTEND_DME', ttsc, pcols, lchnk) + + ! update ttend and T (cf physics_update) + tend%dtdt(:ncol,:) = tend%dtdt(:ncol,:) + (tp(:ncol,:) - state%t(:ncol,:))/dt + state%t (:ncol,:) = tp(:ncol,:) + + ! diagnose total internal enthalpy change + do k=1,pver + ent_tnd(:ncol) = ent_tnd(:ncol) + state%pdel(:ncol,k)*te(:ncol,k) + enddo + ent_tnd(:ncol) = ent_tnd(:ncol)/dt/gravit + call geopotential_t ( & + state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & + state%t , state%q(:,:,:), rairv(:,:,state%lchnk), gravit , zvirv , & + state%zi , state%zm , ncol ) + + ! update original dry static energy + do k = 1, pver + state%s(:ncol,k) = state%t(:ncol,k )*cpairv(:ncol,k,lchnk) & + + gravit*state%zm(:ncol,k) + state%phis(:ncol) + enddo + + contains + + !=============================================================================== + + subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq, & + step , eflx_out , mflx_out, ntrnprd, ntsnprd, mflx, eflx) + + !----------------------------------------------------------------------- + ! + ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to + ! atmospheric moisture change + ! + ! Method + ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) + ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, + ! CONDEPS, and a matching heat exchange betweeen air and condensated + ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). + ! Choice 2. is taken with dme_ ohf_adjust=.true. For CONDEPS then the following + ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS + ! cpcond is a parameter representing the heat capacity of the condensate phase. + ! The heating rates and enthalpy boundary fluxes are not applied here, + ! they are intended to be passed to dme_adjust. + ! + ! Author: Thomas Toniazzo (17.07.21) + ! + !----------------------------------------------------------------------- + + use air_composition, only: thermodynamic_active_species_idx + use air_composition, only: thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_idx + use air_composition, only: thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_liq_num + use air_composition, only: thermodynamic_active_species_ice_num + use air_composition, only: dry_air_species_num + use air_composition, only: t00a, h00a + use physconst, only: cpair, cpwv, cpliq, cpice + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in ) :: tevp(pcols) ! temperature of evaporation at bottom of atmo + real(r8), intent(in ) :: tprc(pcols) ! temperature of precipitation at bottom of atmo + real(r8), intent(in ) :: dt ! model physics timestep + real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust + real(r8), intent(out ) :: mdq(pcols,pver) ! total water increment for dme_adjust + character(len=*), intent(in) :: step ! which call in physpkg + real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer + real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8), intent(in) :: eflx(pcols) ! boundary enthalpy flux + real(r8), intent(in) :: mflx(pcols) ! boundary mass flux + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k,m, ixq ! Longitude, level indices + integer :: ierr ! error flag + real(r8) :: fdq (pcols) ! mass adjustment factor + real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values + real(r8) :: dcvap(pcols) ! total column vapour change + real(r8) :: dcliq(pcols) ! total column liquid change + real(r8) :: dcice(pcols) ! total column ice change + real(r8) :: dcwat(pcols) ! total column water change + real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) + real(r8) :: tot_water_chg(pcols) ! work array: total water change + integer :: m_cnst + real(r8) :: ps_old(pcols) ! old surface pressure + real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) + real(r8) :: dvap (pcols,pver) ! wv mass adjustment + real(r8) :: dliq (pcols,pver) ! liq mass adjustment + real(r8) :: dice (pcols,pver) ! ice mass adjustment + real(r8) :: dprat (pcols) ! Dp'/Dp'' (=1 in lagrangean adj) + real(r8) :: mdqr (pcols,pver) ! residual mass change (work array) + real(r8) :: dcqm (pcols) ! fraction of total/absolute mass change + real(r8) :: te (pcols,pver) ! conserved energy in layer + real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm (pcols,pver) ! (phi-phis)/g + real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) + real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes + real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes + real(r8) :: condmox_ref(pcols,pver) ! local specific x-momentum of "condensates" (mass source) + real(r8) :: condmox (pcols,pver) ! specific x-momentum of moist reservoir with which q is exchanged + real(r8) :: condmoy_ref(pcols,pver) ! local specific y-momentum of "condensates" (mass source) + real(r8) :: condmoy (pcols,pver) ! specific y-momentum of moist reservoir with which q is exchanged + real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp + real(r8) :: uf(pcols), vf(pcols) ! work arrays + real(r8) :: pint_old(pcols,pver+1) ! work array + real(r8) :: dummy(pcols,pver) ! work array + integer :: is_invalid(pcols) + ! + logical , parameter :: conserve = conserve_dycore .or. conserve_physics + real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) + ! set to T to use distribute implied heating over column section to the surface + logical, parameter :: l_nolocdcpttend=.true. + logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot + !----------------------------------------------------------------------- + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_bflx: cannot pass in a state which has sub-columns') + end if + + lchnk = state%lchnk + ncol = state%ncol + + ! store old pressure + ps_old (:ncol) = state%ps(:ncol) + pint_old(:ncol,:) = state%pint(:ncol,:) + + zm(:ncol,:)=state%zm(:ncol,:) + + ! get local specific enthalpy, excluding latent heats + if (conserve_dycore) then + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cp_or_cv_dycore(:ncol,:,lchnk) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,te(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & + ,vcoord=vc_dycore ,refstate='liq' & + ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + else + call get_conserved_energy(levels_are_moist & + ,1 ,pver & + ,cpairv(:ncol,:,lchnk) & + ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & + ,pdel_new(:ncol,:) ,te(:ncol,:) & + ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & + ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & + ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & + ,refstate='liq' & + ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + endif + + call cnst_get_ind('Q', ixq) + + ! change in water + dcvap(:ncol)=0._r8 + dcliq(:ncol)=0._r8 + dcice(:ncol)=0._r8 + dcwat(:ncol)=0._r8 + ! heat associated with cp change + do k = 1, pver + ! mass increments Dp'/Dp + tot_water(:ncol,1) = qini(:ncol,k)+liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O + tot_water(:ncol,2) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) + end do + mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) + + dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) + dliq(:ncol,k) = -liqini(:ncol,k) + do m_cnst=1,thermodynamic_active_species_liq_num + m = thermodynamic_active_species_liq_idx(m_cnst) + dliq(:ncol,k) = dliq(:ncol,k)+state%q(:ncol,k,m) + end do + dice(:ncol,k) = -iceini(:ncol,k) + do m_cnst=1,thermodynamic_active_species_ice_num + m = thermodynamic_active_species_ice_idx(m_cnst) + dice(:ncol,k) = dice(:ncol,k)+state%q(:ncol,k,m) + end do + + dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state%pdel(:ncol,k)/gravit + dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state%pdel(:ncol,k)/gravit + dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state%pdel(:ncol,k)/gravit + dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state%pdel(:ncol,k)/gravit + + end do + + is_invalid(:ncol)=0 + if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then + k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) + if (masterproc.and.logorrhoic) & ! for testing + print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) + endif + where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) + is_invalid(:ncol)=1 + endwhere + if (maxval(is_invalid(:ncol)).gt.0) then + k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) + if (abs(eflx(k)).gt.rtiny) then + if (masterproc.and.logorrhoic) & ! for testing + print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) + endif + endif + + ! local specific enthalpy + if (conserve) then + do k = 1, pver + condeps_ref(:ncol,k) = te(:ncol,k) +emce(:ncol,k) + enddo + else + condeps_ref(:ncol,:) = 0._r8 + endif + + ! exchange specific enthalpies, incremental + if (conserve) then ! we can partition between source and destination + dcwatr(:ncol) = 0._r8 + do k=1,pver + mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change + if (conserve_physics.or..not.l_nolocdcpttend) then + condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) + else if (conserve_dycore) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice + condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq (:ncol,k) + condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) + endif + if (bndry_flx_surface) then + condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) + condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state%phis(:ncol)+(cpliq*t00a+h00a)) + else if (bndry_flx_local) then + if (conserve_dycore) then + condepsf(:ncol,k) = -(cpliq*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = condepsf(:ncol,k) - & + (ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) + condepsf(:ncol,k) = condepsf(:ncol,k) + & + mdqr(:ncol,k)*(cpwv*(state%t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state%phis(:ncol)+(cpliq*t00a+h00a)) + else if (conserve_physics) then + condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) + condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) + endif + endif + ! residual column water change: integrates to surface evaporation + dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + enddo + else + mdqr (:ncol,:)=mdq (:ncol,:) + dcwatr (:ncol) =dcwat(:ncol) + condepsf(:ncol,:)=0._r8 + condepss(:ncol,:)=0._r8 + do k=1,pver + if (conserve_physics.or..not.l_nolocdcpttend) then + condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) + else if (conserve_dycore ) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice + condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq(:ncol,k) + condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) + endif + if (bndry_flx_surface) then + condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice + condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state%phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) + condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) + else if (bndry_flx_local) then + condepsf(:ncol,k) = condepss(:ncol,k) + if (conserve_dycore .and.l_nolocdcpttend) & + condepsf(:ncol,k) = condepsf(:ncol,k)+((cpliq-cpair)*t00a+h00a)*mdq(:ncol,k) + endif + enddo + endif + + + if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match + ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR + eflx_out(:ncol ) = eflx(:ncol)*dt + do k = 1, pver + where(is_invalid(:ncol).eq.0) + eflx_out(:ncol) = eflx_out(:ncol) - state%pdel(:ncol,k)/gravit*condepsf(:ncol,k) + elsewhere + eflx_out(:ncol) = 0._r8 + endwhere + enddo + dcqm(:ncol)=0._r8 + do k=1,pver + where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) + dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + endwhere + enddo + where(abs(dcwatr(:ncol)).gt.rtiny) + dcqm(:ncol)=dcwatr(:ncol)/dcqm(:ncol) + elsewhere + dcqm(:ncol)=0._r8 + endwhere + do k=1,pver + where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) + condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) + endwhere + where(is_invalid(:ncol).eq.1) + condepsf(:ncol,k) = 0._r8 + endwhere + enddo + endif + + ! boundary flux of energy due to mass sources (diagnostic) + mflx_out(:ncol ) = 0._r8 + do k = 1, pver + where(is_invalid(:ncol).eq.0) + ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) + mflx_out(:ncol) = mflx_out(:ncol) + state%pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt + endwhere + enddo + + ! boundary flux of energy due to mass sources (diagnostic) + eflx_out(:ncol ) = 0._r8 + do k = 1, pver + where(is_invalid(:ncol).eq.0) + ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) + eflx_out(:ncol) = eflx_out(:ncol) + state%pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt + endwhere + enddo + + ! make local specific enthalpy incremental + if (conserve) then + do k = 1, pver + condeps_ref(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) + enddo + endif + + ! new surface pressure + state%ps(:ncol) = state%pint(:ncol,1) + do k = 1, pver + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + end do + + ! heat exchange with condensates + htx_cond(:ncol,:) = 0._r8 + do k = 1, pver + do i=1,ncol + if(l_nolocdcpttend)then + ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below + if (k.eq.1) then + condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & + *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) + else + condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & + *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & + +condepsf(i,k-1) + endif + else + condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) + endif + htx_cond(i,k) = condepsf(i,k) & + ! diff. between LOCAL enthalpy and reference enthalpy is applied locally + +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) + enddo + + pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + + ! compute new total pressure variables + state%pint(:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) + + end do + + ! original pressure + state%ps (:ncol) = ps_old (:ncol) + state%pint(:ncol,:) = pint_old(:ncol,:) + + end subroutine dme_bflx + + end subroutine dme_adjust_camnor_run + +end module dme_adjust_camnor diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 59f26be8b7..c53fcd0d14 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -34,6 +34,7 @@ module physics_types public physics_ptend_init public physics_state_set_grid public physics_dme_adjust ! adjust dry mass and energy for change in water + public physics_dme_adjust_camnor ! adjust dry mass and energy for change in water public physics_state_copy ! copy a physics_state object public physics_ptend_copy ! copy a physics_ptend object public physics_ptend_sum ! accumulate physics_ptend objects @@ -181,20 +182,6 @@ module physics_types end type physics_ptend logical :: levels_are_moist=.true. ! TODO: put in namelist? - ! 5 possibilities (-> = currently reccommended): - ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) - ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) - ! -> 3) conserve_dycore=.true. , bndry_flx_local=.true. (requires fixer to match correct surface fluxes) - ! 4) conserve_physics=.true. , bndry_flx_local=.true. (as 3., plus fixer for atmo energy) - ! 5) conserve_physics=.true. , bndry_flx_surface=.true. (no advantage wrt option 2) - - ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its - ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. - - logical, parameter :: conserve_dycore = .true. - logical, parameter :: bndry_flx_surface = .true. - logical, parameter :: conserve_physics = .not. conserve_dycore - logical, parameter :: bndry_flx_local = .not. bndry_flx_surface !=============================================================================== contains @@ -1273,825 +1260,10 @@ subroutine physics_cnst_limit(state) end subroutine physics_cnst_limit !=============================================================================== - - ! gatekeeper module to control options for dme adjustment - subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt & - , dme_energy_adjust , step & - , ntrnprd, ntsnprd & - , tevap, tprec & - , mflx, eflx & - , eflx_out & - , mflx_out & - , ent_tnd, pdel_rf & - , dycore_is_hydrostatic) - - !use phys_control, only: phys_getopts - ! 25.06.14 Added new formulation of Thomas Toniazzo (Bjerknes Centre / NORCE) - ! obligate args - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in ) :: dt - ! optional args - logical , optional, intent(in ) :: dme_energy_adjust - character(len=*),optional,intent(in)::step !which call in physpkg - real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer - real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer - real(r8), intent(in) , optional :: tevap (pcols) ! temperature of surface evaporation - real(r8), intent(in) , optional :: tprec (pcols) ! temperature of surface precipitation - real(r8), intent(in) , optional :: mflx (pcols) ! mass flux for use in check_energy - real(r8), intent(in) , optional :: eflx (pcols) ! energy flux for use in check_energy - real(r8), intent(out), optional :: ent_tnd (pcols) ! column-integrated enthalpy tendency - real(r8), intent(out), optional :: pdel_rf (pcols,pver)! ratio old pdel / new pdel - logical , intent(in) , optional :: dycore_is_hydrostatic - - real(r8), intent(out), optional :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out), optional :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - ! local work space - integer :: ncol,icol - !real(r8) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8) :: tevp (pcols) ! temperature for surface evaporation - real(r8) :: tprc (pcols) ! temperature for precipitation at surface - real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" - real(r8) :: mdq (pcols,pver) ! total water tendency - logical :: hydrostatic =.true. - real(r8), parameter :: rtiny = 1e-04_r8 ! a small number (relative to total q change) - - - if(present(dycore_is_hydrostatic)) then - hydrostatic = dycore_is_hydrostatic - end if - - if (present(dme_energy_adjust)) then - if (dme_energy_adjust) then - - if(present(tevap))then - tevp=tevap - else - tevp(:ncol)=state%t(:ncol,pver) - endif - if(present(tprec))then - tprc=tprec - else - tprc(:ncol)=state%t(:ncol,pver) - endif - - if (present(ntrnprd).and.present(ntsnprd)) then ! use physics (ZM+MG) precip production rates - if (present(eflx).and.present(mflx)) then ! also correct to match prescribed surface enthalpy flux - call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & - , htx_cond, mdq, step & - , ntrnprd=ntrnprd, ntsnprd=ntsnprd & - , mflx=mflx, eflx=eflx & - , eflx_out=eflx_out, mflx_out=mflx_out) - else - call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & - , htx_cond, mdq, step & - , ntrnprd=ntrnprd, ntsnprd=ntsnprd & - , eflx_out=eflx_out , mflx_out=mflx_out) - endif - else - call physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt & - , htx_cond, mdq, step & - , eflx_out=eflx_out, mflx_out=mflx_out) - endif - call physics_dme_adjust_THT(state, tend, dt & - , qini, liqini, iceini, htx_cond, mdq, step & - , ent_tnd=ent_tnd , pdel_rf=pdel_rf & - , hydrostatic=hydrostatic) - else ! not present dme_energy_adjust - if (present(ent_tnd)) ent_tnd (:)=0._r8 - call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) - end if - - else ! not present dme_energy_adjust - - if (present(ent_tnd)) ent_tnd (:)=0._r8 - call physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) - - end if - - ! dme_energy_adjust code: - end subroutine physics_dme_adjust - -!=============================================================================== - - subroutine physics_dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq & - , step , eflx_out , mflx_out & - , ntrnprd, ntsnprd & - , mflx, eflx) - - use air_composition, only: dry_air_species_num & - ,thermodynamic_active_species_idx & - ,thermodynamic_active_species_liq_idx & - ,thermodynamic_active_species_ice_idx & - ,thermodynamic_active_species_num & - ,thermodynamic_active_species_liq_num & - ,thermodynamic_active_species_ice_num & - ,cpairv, cp_or_cv_dycore - use constituents, only: cnst_get_type_byind, cnst_get_ind - use physconst, only: cpair, cpwv, cpliq, cpice, tmelt - use air_composition, only: t00a, h00a - use hycoef, only: hyai, hybi, ps0, hyam, hybm - use cam_thermo, only: inv_conserved_energy, get_conserved_energy & - ,cam_thermo_water_update - use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure - - !----------------------------------------------------------------------- - ! - ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to - ! atmospheric moisture change - ! - ! Method - ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) - ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, - ! CONDEPS, and a matching heat exchange betweeen air and condensated - ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). - ! Choice 2. is taken with dme_ ohf_adjust=.true. For CONDEPS then the following - ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS - ! cpcond is a parameter representing the heat capacity of the condensate phase. - ! The heating rates and enthalpy boundary fluxes are not applied here, - ! they are intended to be passed to dme_adjust. - ! - ! Author: Thomas Toniazzo (17.07.21) - ! - !----------------------------------------------------------------------- - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in ) :: tevp (pcols) ! temperature of evaporation at bottom of atmo - real(r8), intent(in ) :: tprc (pcols) ! temperature of precipitation at bottom of atmo - real(r8), intent(in ) :: dt ! model physics timestep - real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust - real(r8), intent(out ) :: mdq (pcols,pver) ! total water increment for dme_adjust - character(len=*),optional,intent(in)::step !which call in physpkg - real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(in) , optional :: ntrnprd(pcols,pver)! net precip (liq+ice) production in layer - real(r8), intent(in) , optional :: ntsnprd(pcols,pver)! net snow production in layer - real(r8), intent(in) , optional :: eflx (pcols) ! input : boundary enthalpy flux - real(r8), intent(in) , optional :: mflx (pcols) ! input : boundary mass flux - - !---------------------------Local workspace----------------------------- - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i,k,m, ixq ! Longitude, level indices - integer :: ierr ! error flag - - real(r8) :: fdq (pcols) ! mass adjustment factor - - real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values - - real(r8) :: dcvap(pcols) ! total column vapour change - real(r8) :: dcliq(pcols) ! total column liquid change - real(r8) :: dcice(pcols) ! total column ice change - real(r8) :: dcwat(pcols) ! total column water change - real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) - - real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - - real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) - real(r8) :: tot_water_chg(pcols) ! work array: total water change - integer :: m_cnst - - real(r8) :: ps_old(pcols) ! old surface pressure - - real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - real(r8) :: dvap (pcols,pver) ! wv mass adjustment - real(r8) :: dliq (pcols,pver) ! liq mass adjustment - real(r8) :: dice (pcols,pver) ! ice mass adjustment - real(r8) :: dprat (pcols) ! Dp'/Dp'' (=1 in lagrangean adj) - - real(r8) :: mdqr (pcols,pver) ! residual mass change (work array) - real(r8) :: dcqm (pcols) ! fraction of total/absolute mass change - - real(r8) :: te (pcols,pver) ! conserved energy in layer - real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm (pcols,pver) ! (phi-phis)/g - real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) - real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes - real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes - real(r8) :: condmox_ref(pcols,pver) ! local specific x-momentum of "condensates" (mass source) - real(r8) :: condmox (pcols,pver) ! specific x-momentum of moist reservoir with which q is exchanged - real(r8) :: condmoy_ref(pcols,pver) ! local specific y-momentum of "condensates" (mass source) - real(r8) :: condmoy (pcols,pver) ! specific y-momentum of moist reservoir with which q is exchanged - - real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp - - real(r8) :: uf(pcols), vf(pcols) ! work arrays - - real(r8) :: pint_old(pcols,pver+1)! work array - !real(r8) :: tbot(pcols) ! work array - real(r8) :: dummy(pcols,pver) ! work array - - integer :: is_invalid(pcols) - logical , parameter :: conserve = conserve_dycore .or. conserve_physics - real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) - - ! set to T to use distribute implied heating over column section to the surface - logical, parameter :: l_nolocdcpttend=.true. - - logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot - - if (state%psetcols .ne. pcols) then - call endrun('physics_dme_bflx: cannot pass in a state which has sub-columns') - end if - - lchnk = state%lchnk - ncol = state%ncol - - ! store old pressure - ps_old (:ncol) = state%ps(:ncol) - pint_old(:ncol,:) = state%pint(:ncol,:) - - zm(:ncol,:)=state%zm(:ncol,:) - - ! get local specific enthalpy, excluding latent heats - if (conserve_dycore) then - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cp_or_cv_dycore(:ncol,:,lchnk) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,te(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & - ,vcoord=vc_dycore ,refstate='liq' & - ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) - else - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cpairv(:ncol,:,lchnk) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,te(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & - ,refstate='liq' & - ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) - endif - - call cnst_get_ind('Q', ixq) - ! change in water - dcvap(:ncol)=0._r8 - dcliq(:ncol)=0._r8 - dcice(:ncol)=0._r8 - dcwat(:ncol)=0._r8 - ! heat associated with cp change - do k = 1, pver - ! mass increments Dp'/Dp - tot_water(:ncol,1) = qini(:ncol,k)+liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O - tot_water(:ncol,2) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) - end do - mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) - - dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) - dliq(:ncol,k) = -liqini(:ncol,k) - do m_cnst=1,thermodynamic_active_species_liq_num - m = thermodynamic_active_species_liq_idx(m_cnst) - dliq(:ncol,k) = dliq(:ncol,k)+state%q(:ncol,k,m) - end do - dice(:ncol,k) = -iceini(:ncol,k) - do m_cnst=1,thermodynamic_active_species_ice_num - m = thermodynamic_active_species_ice_idx(m_cnst) - dice(:ncol,k) = dice(:ncol,k)+state%q(:ncol,k,m) - end do - - dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state%pdel(:ncol,k)/gravit - dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state%pdel(:ncol,k)/gravit - dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state%pdel(:ncol,k)/gravit - dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state%pdel(:ncol,k)/gravit - - end do - - is_invalid(:ncol)=0 - if (present(mflx)) then - if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then - k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) - if (masterproc.and.logorrhoic) & ! for testing - print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) - endif - where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) - is_invalid(:ncol)=1 - endwhere - if (maxval(is_invalid(:ncol)).gt.0) then - k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) - if (abs(eflx(k)).gt.rtiny) then - if (masterproc.and.logorrhoic) & ! for testing - print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) - endif - endif - endif - - ! local specific enthalpy - if (conserve) then - do k = 1, pver - condeps_ref(:ncol,k) = te(:ncol,k) +emce(:ncol,k) - enddo - else - condeps_ref(:ncol,:) = 0._r8 - endif - - ! exchange specific enthalpies, incremental - if (conserve .and. present(ntrnprd) .and. present(ntsnprd)) then ! we can partition between source and destination - dcwatr (:ncol) = 0._r8 - do k=1,pver - mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change - if (conserve_physics.or..not.l_nolocdcpttend) then - condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) - else if (conserve_dycore) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq (:ncol,k) - condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) - endif - if (bndry_flx_surface) then - condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntsnprd(:ncol,k) - condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state%phis(:ncol)+(cpliq*t00a+h00a)) - else if (bndry_flx_local) then - if (conserve_dycore) then - condepsf(:ncol,k) = -(cpliq*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntsnprd(:ncol,k) - condepsf(:ncol,k) = condepsf(:ncol,k) - & - (ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k) + & - mdqr(:ncol,k)*(cpwv*(state%t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state%phis(:ncol)+(cpliq*t00a+h00a)) - else if (conserve_physics) then - condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) - condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) - endif - endif - ! residual column water change: integrates to surface evaporation - dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit - enddo - else - mdqr (:ncol,:)=mdq (:ncol,:) - dcwatr (:ncol) =dcwat(:ncol) - condepsf(:ncol,:)=0._r8 - condepss(:ncol,:)=0._r8 - do k=1,pver - if (conserve_physics.or..not.l_nolocdcpttend) then - condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) - else if (conserve_dycore ) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq(:ncol,k) - condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) - endif - if (bndry_flx_surface) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state%phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) - condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) - else if (bndry_flx_local) then - condepsf(:ncol,k) = condepss(:ncol,k) - if (conserve_dycore .and.l_nolocdcpttend) & - condepsf(:ncol,k) = condepsf(:ncol,k)+((cpliq-cpair)*t00a+h00a)*mdq(:ncol,k) - endif - enddo - endif - - - if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match - ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR - eflx_out(:ncol ) = eflx(:ncol)*dt - do k = 1, pver - where(is_invalid(:ncol).eq.0) - eflx_out(:ncol) = eflx_out(:ncol) - state%pdel(:ncol,k)/gravit*condepsf(:ncol,k) - elsewhere - eflx_out(:ncol) = 0._r8 - endwhere - enddo - dcqm(:ncol)=0._r8 - do k=1,pver - where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit - endwhere - enddo - where(abs(dcwatr(:ncol)).gt.rtiny) - dcqm(:ncol)=dcwatr(:ncol)/dcqm(:ncol) - elsewhere - dcqm(:ncol)=0._r8 - endwhere - do k=1,pver - where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) - endwhere - where(is_invalid(:ncol).eq.1) - condepsf(:ncol,k) = 0._r8 - endwhere - enddo - endif - - ! boundary flux of energy due to mass sources (diagnostic) - mflx_out(:ncol ) = 0._r8 - do k = 1, pver - where( is_invalid(:ncol).eq.0) - ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - mflx_out(:ncol) = mflx_out(:ncol) + state%pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt - endwhere - enddo - - ! boundary flux of energy due to mass sources (diagnostic) - eflx_out(:ncol ) = 0._r8 - do k = 1, pver - where( is_invalid(:ncol).eq.0) - ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - eflx_out(:ncol) = eflx_out(:ncol) + state%pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt - endwhere - enddo - - ! make local specific enthalpy incremental - if (conserve) then - do k = 1, pver - condeps_ref(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) - enddo - endif - - ! new surface pressure - state%ps(:ncol) = state%pint(:ncol,1) - do k = 1, pver - state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - end do - - ! heat exchange with condensates - htx_cond(:ncol,:) = 0._r8 - do k = 1, pver - do i=1,ncol - if(l_nolocdcpttend)then - ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below - if(k.eq.1) then - condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) - else - condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & - +condepsf(i,k-1) - endif - else - condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) - endif - htx_cond(i,k) = condepsf(i,k) & - ! diff. between LOCAL enthalpy and reference enthalpy is applied locally - +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) - enddo - - pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - - ! compute new total pressure variables - state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) - - end do - - ! original pressure - state%ps (:ncol) = ps_old (:ncol) - state%pint(:ncol,:) = pint_old(:ncol,:) - - end subroutine physics_dme_bflx - -!----------------------------------------------------------------------- - - subroutine physics_dme_adjust_THT(state, tend, dt & - , qini,liqini,iceini & - , htx_cond , mdq, step & - , ent_tnd, pdel_rf & - , hydrostatic ) - - use air_composition, only: dry_air_species_num,thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx & - ,cpairv, cp_or_cv_dycore - use constituents, only: cnst_get_type_byind, cnst_get_ind, cnst_type - use hycoef, only: hyai, hybi, ps0, hyam, hybm - use cam_thermo, only: inv_conserved_energy, get_conserved_energy & - ,cam_thermo_water_update - use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure, vc_physics - use qneg_module, only: qneg3 - use dycore, only: dycore_is ! might be rm'd when code is cleaned up - use cam_history, only: outfld - - !----------------------------------------------------------------------- - ! - ! Purpose: Adjust the dry mass in each layer back to the value of physics input state - ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. - ! - ! Method - ! Revised adjustment towards consistency with local energy conservation. - ! Hydrostatic pressure work, de = alpha * dp, where alpha is the specific volume - ! pressure adjustment, is added locally as an source of enthalpy. An enthalpy of - ! mass (water) exchange with the surface is also defined, which should be passed - ! to the surface model components (ocean/land/ice etc). - ! If moist thermodynamics where handled correctly in CAM, the two terms would - ! match, guaranteeing local energy conservation. - ! With the present CAM formulation (constant dry heat capacity, constant latent - ! heat of condensation valid for 0 degree C), consistency demands one of these - ! choices: - ! 1. no pressure work and no boundary enthalpy flux (CESM) - ! 2. correct local pressure work and boundary enthalpy flux equal to (S dp/g) - ! where S=local *dry* static energy of air - ! The boundary enthalpy flux is at present not passed to other model components, - ! so it is treated as internal CAM non-conservation and folded into fix_energy. - ! - ! Author: Thomas Toniazzo (17.07.21) - ! - !----------------------------------------------------------------------- - - implicit none - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: dt ! model physics timestep - real(r8), intent(in) :: htx_cond(pcols,pver)! exchange heating with q's leaving/entering column - real(r8), intent(in) :: mdq (pcols,pver) ! mass adjustment - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - character(len=*),optional,intent(in)::step !which call in physpkg - real(r8), intent(out), optional :: ent_tnd (pcols) ! diagnostic: column-integrated enthalpy tendency - real(r8), intent(out), optional :: pdel_rf (pcols,pver)! diagnostic: ratio old pdel / new pdel - logical , intent(in) , optional :: hydrostatic ! flag to set energy function to hydrostatic - - !---------------------------Local workspace----------------------------- - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i,k,m ! Longitude, level indices - integer :: ierr ! error flag - - real(r8) :: fdq (pcols) ! mass adjustment factor - - real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values - - real(r8) :: te (pcols,pver) ! conserved energy in layer - real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm (pcols,pver) ! (phi-phis)/g - - real(r8) :: cpm (pcols,pver) ! moist air heat capacity - real(r8) :: ttsc (pcols,pver) ! moist air heat capacity - integer :: vcoord - - real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - - real(r8) :: tot_water (pcols ) ! total water (initial, present) - real(r8) :: tot_water_chg(pcols) ! total water change - integer :: m_cnst - - real(r8) :: ps_old(pcols) ! old surface pressure - - real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - - real(r8) :: pdot (pcols) ! total (lagrangian) pressure adjustment - real(r8) :: pdzp (pcols) ! pressure work term in press adjustment - real(r8) :: edot (pcols) ! advective pressure adjustment - - real(r8) :: uf(pcols), vf(pcols) ! work arrays - - real(r8) :: tp(pcols,pver) ! work array for T/Tv - real(r8) :: latent(pcols,pver) ! work array for Lq - - integer :: ixnumice, ixnumliq - integer :: ixnumsnow, ixnumrain - - call cnst_get_ind('NUMICE', ixnumice, abort=.false.) - call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) - call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) - call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) - - if (state%psetcols .ne. pcols) then - call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') - end if - -!-------------------- initialise adjustment loop ------------------------------------ - lchnk = state%lchnk - ncol = state%ncol - - ! old surface pressure - ps_old (:ncol) = state%ps(:ncol) - state%ps(:ncol) = state%pint(:ncol,1) - - zm(:ncol,:)=state%zm(:ncol,:) - - if (conserve_dycore) then - vcoord=vc_dycore - cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) - else - vcoord=vc_physics - cpm(:ncol,:)=cpairv(:ncol,:,lchnk) - endif - - do k = 1, pver - tp(:ncol,k) = state%t(:ncol,k) - enddo - - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cpm(:ncol,:) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,state%s(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:),rairv=rairv(:ncol,:,lchnk) & - ,vcoord=vcoord ,refstate='liq' & - ,flatent=latent(:ncol,:),temce=emce(:ncol,:)) - - do k = 1, pver - ! Dp'/Dp - tot_water(:ncol) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) - enddo - ! new surface pressure - state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - ! make all tracers wet - do m=1,pcnst - if (cnst_type(m).eq.'dry') & - state%q(:ncol,k,m) = state%q(:ncol,k,m)*(1._r8-tot_water(:ncol)) - enddo - enddo - - ! lagrangian & advective pressure change at top interface - pdot (:ncol) = 0._r8 - pdzp (:ncol) = 0._r8 - edot (:ncol) = 0._r8 - - ! store old enthalpy integral - if (present(ent_tnd)) then - ent_tnd(:ncol)=0._r8 - do k=1,pver - ent_tnd(:ncol) = ent_tnd(:ncol) - state%pdel(:ncol,k)*state%s(:ncol,k) - enddo - endif - -!------------------- start adjustment loop ------------------------------------------ - do k = 1, pver - - ! new Dp (=:Dp") - pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - - fdq(:ncol) = pdel_new(:ncol,k)/state%pdel(:ncol,k) ! this is Dp"/Dp - - ! wind adjustment increments - uf (:ncol) = 0. - vf (:ncol) = 0. - - ! u,vtmp set to pre-physics u,v from the updated values and the tendencies - utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) - vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) - - ! adjust specific enthalpy - te (:ncol,k) = 0._r8 - - ! lagrangian pressure change *zi at upper interfac - pdzp(:ncol) = pdot(:ncol)*gravit*state%zi(:ncol,k) - ! lagrangian pressure change at next interface - if(hydrostatic)pdot(:ncol) = pdot(:ncol) + state%pdel(:ncol,k)*mdq(:ncol,k) - ! layer increment = work (~alpha*dp) - pdzp(:ncol) = (pdot(:ncol)*gravit*state%zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) - - ! enthalpy change due to mass loss and to hydrost. pressure work in full adjustment - te(:ncol,k) = te(:ncol,k) & - + state%s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") - + emce(:ncol,k)*mdq(:ncol,k)/fdq(:ncol) & ! (phi-phis)*dq*(Dp/Dp") - - pdzp(:ncol) & ! del(g*zm*dp) - + htx_cond(:ncol,k) ! EFLX - ! momentum - uf(:ncol) = uf(:ncol) +state%u(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) - vf(:ncol) = vf(:ncol) +state%v(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) - - ! adjust constituents to conserve mass in each layer - do m = 1, pcnst - ! store unadjusted q for use in next k - state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) - end do - ! adjust L-dependent part of local total enthalpy accordingly - latent(:ncol,k) = latent(:ncol,k)/fdq(:ncol) - - ! adjusted u,v tendencies - tend%dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt - tend%dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt - ! store unadjusted u,v for use in next k - utmp(:ncol) = state%u(:ncol,k) - vtmp(:ncol) = state%v(:ncol,k) - ! write adjusted u,v - state%u(:ncol,k) = uf(:ncol) - state%v(:ncol,k) = vf(:ncol) - - ! compute new total pressure variables - state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) - state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) - ! also update pmid for geopotential - state%pmid (:ncol,k ) = .5_r8*(state%pint(:ncol,k)+state%pint(:ncol,k+1)) - state%lnpmid(:ncol,k ) = log(state%pmid(:ncol,k )) - - if(present(pdel_rf)) pdel_rf(:ncol,k)=state%pdel(:ncol,k)/pdel_new(:ncol,k) - state%pdel (:ncol,k ) = pdel_new(:ncol,k) - state%rpdel (:ncol,k ) = 1._r8/state%pdel(:ncol,k) - - end do -!------------------- end adjustment loop -------------------------------------------- - - ! make dry tracers dry again - do k = 1, pver - tot_water(:ncol) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) - enddo - do m=1,pcnst - if (cnst_type(m).eq.'dry') & - state%q(:ncol,k,m) = state%q(:ncol,k,m)/(1._r8-tot_water(:ncol)) - enddo - enddo - - !call QNEG3 (cf physics_update) - do m = 1, pcnst - if (m /= ixnumice .and. m /= ixnumliq .and. & - m /= ixnumrain .and. m /= ixnumsnow ) then - call qneg3('dme_adjust', state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m)) - else - do k = 1,pver - state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m)) - state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m)) - end do - end if - enddo - - if (conserve_dycore) then - call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore, & - to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) - ttsc(:ncol,:)=cpm(:ncol,:)/cp_or_cv_dycore(:ncol,:,lchnk) - cpm (:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) - endif - call inv_conserved_energy(levels_are_moist & - ,1 ,pver & - ,te(:ncol,:) & - ,cpm(:ncol,:) & - ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,tp(:ncol,:) & - ,flatent=latent(:ncol,:)*0._r8 & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,vcoord=vcoord ,refstate='liq' & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:)) - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 - else - zvirv(:,:) = zvir - endif - - ! diagnostics: dme T tendency - ttsc(:ncol,:) =(tp(:ncol,:) - state%t(:ncol,:))/dt ! & - ! for tests: correct for effect of cp update on other physics ttend - ! -tend%dtdt(:ncol,:)*(ttsc(:ncol,:)-1._r8) - call outfld('PTTEND_DME', ttsc, pcols, lchnk) - - ! update ttend and T (cf physics_update) - tend%dtdt(:ncol,:) = tend%dtdt(:ncol,:) & - +(tp(:ncol,:) - state%t(:ncol,:))/dt - state%t (:ncol,:) = tp(:ncol,:) - - ! diagnose total internal enthalpy change - if (present(ent_tnd)) then - do k=1,pver - ent_tnd(:ncol) = ent_tnd(:ncol) + state%pdel(:ncol,k)*te(:ncol,k) - enddo - ent_tnd(:ncol) = ent_tnd(:ncol)/dt/gravit - endif - call geopotential_t ( & - state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & - state%t , state%q(:,:,:), rairv(:,:,state%lchnk), gravit , zvirv , & - state%zi , state%zm , ncol ) - - ! update original dry static energy - do k = 1, pver - state%s(:ncol,k) = state%t(:ncol,k )*cpairv(:ncol,k,lchnk) & - + gravit*state%zm(:ncol,k) + state%phis(:ncol) - enddo - - end subroutine physics_dme_adjust_THT -!----------------------------------------------------------------------- -!-tht :edoc tsujda_ygrene_emd -!=============================================================================== - !tht: _BAB version, violates energy now just the same as it did 22 years ago - subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) - use air_composition, only: dry_air_species_num,thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx - use dycore, only: dycore_is + subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt) + use air_composition, only: dry_air_species_num,thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx + use dycore, only: dycore_is use dme_adjust, only: dme_adjust_run use ccpp_constituent_prop_mod, only: ccpp_const_props !----------------------------------------------------------------------- @@ -2120,6 +1292,7 @@ subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) ! Arguments ! type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice @@ -2132,6 +1305,8 @@ subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) integer :: k,m ! Longitude, level indices real(r8) :: fdq(pcols) ! mass adjustment factor real(r8) :: te(pcols) ! total energy in a layer + real(r8) :: utmp(pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer @@ -2158,14 +1333,16 @@ subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) ncol = state%ncol ! - ! original code for backwards compatability with FV and EUL + ! original code for backwards compatability with FV ! if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then do k = 1, pver - !tht: removed heavily misleading comment + + ! adjust dry mass in each layer back to input value, while conserving + ! constituents, momentum, and total energy state%ps(:ncol) = state%pint(:ncol,1) - ! adjustment factor is just change in water vapor + ! adjusment factor is just change in water vapor fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k) ! adjust constituents to conserve mass in each layer @@ -2195,9 +1372,46 @@ subroutine physics_dme_adjust_BAB(state, qini, liqini, iceini, dt) zvirv(:,:) = zvir endif - end subroutine physics_dme_adjust_BAB !tht :BAB + end subroutine physics_dme_adjust + !=============================================================================== + subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + ent_tnd, pdel_rf) + + use dme_adjust_camnor, only: dme_adjust_camnor_run + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in) :: dt + character(len=*), intent(in) :: step ! which call in physpkg + real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer + real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation + real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation + real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy + real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy + real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: ent_tnd(pcols) ! column-integrated enthalpy tendency + real(r8), intent(out) :: pdel_rf(pcols,pver) ! ratio old pdel / new pdel + !----------------------------------------------------------------------- + + call dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + ent_tnd, pdel_rf) + + end subroutine physics_dme_adjust_camnor + +!=============================================================================== + + subroutine physics_state_copy(state_in, state_out) use ppgrid, only: pver, pverp From 6e26f5dfc05756d7e43c3bd4a5a42be11d4acdc2 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 1 Oct 2025 14:02:53 +0200 Subject: [PATCH 24/78] fix compiler issue --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 862a285c67..26082c3c27 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -8,7 +8,7 @@ module dme_adjust_camnor contains subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) !----------------------------------------------------------------------- ! @@ -45,8 +45,9 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & use ppgrid, only: pcols, pver use geopotential, only: geopotential_t use phys_control, only: waccmx_is - use air_composition, only: dry_air_species_num, thermodynamic_active_species_num - use air_composItion, only: thermodynamic_active_species_idx, + use air_composition, only: dry_air_species_num + use air_composition, only: thermodynamic_active_species_num + use air_composItion, only: thermodynamic_active_species_idx use air_composition, only: cpairv, cp_or_cv_dycore use constituents, only: cnst_get_ind, cnst_type use cam_thermo, only: inv_conserved_energy @@ -146,7 +147,7 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & end if !------------------------------------ - ! initialise adjustment loop + ! initialise adjustment loop !------------------------------------ lchnk = state%lchnk From c26c3b944e444e3b920106c71a5f6482cf256a4f Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 16:21:34 +0200 Subject: [PATCH 25/78] removal of state and tend references in dme_adjust_camnor.F90 --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 439 +++++++++--------- .../camnor_phys/physics/physics_types.F90 | 14 +- 2 files changed, 237 insertions(+), 216 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 26082c3c27..099071f0cd 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -7,9 +7,14 @@ module dme_adjust_camnor contains - subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & + subroutine dme_adjust_camnor_run(lchnk, ncol, & + state_psetcols, state_pint, state_ps, state_phis, state_zm, state_zi, & + state_t, state_u, state_v, state_pdel, state_q, state_s, & + tend_dudt, tend_dvdt, tend_dtdt, & + qini, liqini, iceini, dt, & step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) + !----------------------------------------------------------------------- ! ! Purpose: Adjust the dry mass in each layer back to the value of physics input state @@ -59,56 +64,66 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & ! ! Arguments ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in) :: dt - character(len=*), intent(in) :: step ! which call in physpkg - real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer - real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer - real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation - real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation - real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy - real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy - real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out) :: ent_tnd (pcols) ! column-integrated enthalpy tendency - real(r8), intent(out) :: pdel_rf (pcols,pver) ! ratio old pdel / new pdel - + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: state_psetcols + real(r8), intent(inout) :: state_pint(:,:) + real(r8), intent(in) :: state_phis(:) + real(r8), intent(inout) :: state_ps(:) + real(r8), intent(in) :: state_zm(:) + real(r8), intent(in) :: state_zi(:) + real(r8), intent(inout) :: state_t(:,:) + real(r8), intent(inout) :: state_u(:,:) + real(r8), intent(inout) :: state_v(:,:) + real(r8), intent(inout) :: state_pdel(:,:) + real(r8), intent(inout) :: state_q(:,:) + real(r8), intent(inout) :: state_s(:,:) + real(r8), intent(inout) :: tend_dudt(:,:) + real(r8), intent(inout) :: tend_dvdt(:,:) + real(r8), intent(inout) :: tend_dtdt(:,:) + real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in) :: dt + character(len=*), intent(in) :: step ! which call in physpkg + real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer + real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation + real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation + real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy + real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy + real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: ent_tnd (pcols) ! column-integrated enthalpy tendency + real(r8), intent(out) :: pdel_rf (pcols,pver) ! ratio old pdel / new pdel ! !---------------------------Local workspace----------------------------- ! - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns integer :: i,k,m ! Longitude, level indices - integer :: ierr ! error flag - real(r8) :: fdq (pcols) ! mass adjustment factor - real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values - real(r8) :: te (pcols,pver) ! conserved energy in layer - real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm (pcols,pver) ! (phi-phis)/g - real(r8) :: cpm (pcols,pver) ! moist air heat capacity - real(r8) :: ttsc (pcols,pver) ! moist air heat capacity + real(r8) :: fdq(pcols) ! mass adjustment factor + real(r8) :: utmp(pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values + real(r8) :: te(pcols,pver) ! conserved energy in layer + real(r8) :: emce(pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm(pcols,pver) !(phi-phis)/g + real(r8) :: cpm(pcols,pver) ! moist air heat capacity + real(r8) :: ttsc(pcols,pver) ! moist air heat capacity integer :: vcoord real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - real(r8) :: tot_water (pcols ) ! total water (initial, present) - real(r8) :: tot_water_chg(pcols) ! total water change + real(r8) :: tot_water(pcols ) ! total water (initial, present) integer :: m_cnst real(r8) :: ps_old(pcols) ! old surface pressure real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - real(r8) :: pdot (pcols) ! total (lagrangian) pressure adjustment - real(r8) :: pdzp (pcols) ! pressure work term in press adjustment - real(r8) :: edot (pcols) ! advective pressure adjustment + real(r8) :: pdot(pcols) ! total(lagrangian) pressure adjustment + real(r8) :: pdzp(pcols) ! pressure work term in press adjustment + real(r8) :: edot(pcols) ! advective pressure adjustment real(r8) :: uf(pcols), vf(pcols) ! work arrays real(r8) :: tp(pcols,pver) ! work array for T/Tv real(r8) :: latent(pcols,pver) ! work array for Lq integer :: ixnumice, ixnumliq integer :: ixnumsnow, ixnumrain real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" - real(r8) :: mdq (pcols,pver) ! total water tendency + real(r8) :: mdq(pcols,pver) ! total water tendency logical :: hydrostatic = .true. ! 5 possibilities (-> = currently reccommended): @@ -142,22 +157,15 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) - if (state%psetcols .ne. pcols) then - call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') - end if - !------------------------------------ ! initialise adjustment loop !------------------------------------ - lchnk = state%lchnk - ncol = state%ncol - ! old surface pressure - ps_old (:ncol) = state%ps(:ncol) - state%ps(:ncol) = state%pint(:ncol,1) + ps_old (:ncol) = state_ps(:ncol) + state_ps(:ncol) = state_pint(:ncol,1) - zm(:ncol,:)=state%zm(:ncol,:) + zm(:ncol,:)=state_zm(:ncol,:) if (conserve_dycore) then vcoord=vc_dycore @@ -168,33 +176,33 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & endif do k = 1, pver - tp(:ncol,k) = state%t(:ncol,k) + tp(:ncol,k) = state_t(:ncol,k) enddo - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cpm(:ncol,:) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,state%s(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:),rairv=rairv(:ncol,:,lchnk) & - ,vcoord=vcoord ,refstate='liq' & - ,flatent=latent(:ncol,:),temce=emce(:ncol,:)) + call get_conserved_energy(levels_are_moist, & + 1 ,pver, & + cpm(:ncol,:), & + state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & + pdel_new(:ncol,:) ,state_s(:ncol,:), & + qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & + phis=state_phis(:ncol) ,gph=zm(:ncol,:), & + U=state_u(:ncol,:) ,V=state_v(:ncol,:),rairv=rairv(:ncol,:,lchnk), & + vcoord=vcoord ,refstate='liq', & + flatent=latent(:ncol,:),temce=emce(:ncol,:)) do k = 1, pver ! Dp'/Dp tot_water(:ncol) = 0.0_r8 do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + tot_water(:ncol) = tot_water(:ncol)+state_q(:ncol,k,m) enddo ! new surface pressure - state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + state_ps(:ncol) = state_ps(:ncol) + state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) ! make all tracers wet do m=1,pcnst if (cnst_type(m).eq.'dry') then - state%q(:ncol,k,m) = state%q(:ncol,k,m)*(1._r8-tot_water(:ncol)) + state_q(:ncol,k,m) = state_q(:ncol,k,m)*(1._r8-tot_water(:ncol)) end if enddo enddo @@ -207,7 +215,7 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & ! store old enthalpy integral ent_tnd(:ncol)=0._r8 do k = 1,pver - ent_tnd(:ncol) = ent_tnd(:ncol) - state%pdel(:ncol,k)*state%s(:ncol,k) + ent_tnd(:ncol) = ent_tnd(:ncol) - state_pdel(:ncol,k)*state_s(:ncol,k) enddo !------------------------------------ @@ -216,72 +224,72 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & do k = 1, pver ! new Dp (=:Dp") - pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + pdel_new(:ncol,k) = state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - fdq(:ncol) = pdel_new(:ncol,k)/state%pdel(:ncol,k) ! this is Dp"/Dp + fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) ! this is Dp"/Dp ! wind adjustment increments uf (:ncol) = 0. vf (:ncol) = 0. ! u,vtmp set to pre-physics u,v from the updated values and the tendencies - utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) - vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) + utmp(:ncol) = state_u(:ncol,k) - dt * tend_dudt(:ncol,k) + vtmp(:ncol) = state_v(:ncol,k) - dt * tend_dvdt(:ncol,k) ! adjust specific enthalpy te (:ncol,k) = 0._r8 ! lagrangian pressure change *zi at upper interfac - pdzp(:ncol) = pdot(:ncol)*gravit*state%zi(:ncol,k) + pdzp(:ncol) = pdot(:ncol)*gravit*state_zi(:ncol,k) ! lagrangian pressure change at next interface - if(hydrostatic)pdot(:ncol) = pdot(:ncol) + state%pdel(:ncol,k)*mdq(:ncol,k) + if(hydrostatic)pdot(:ncol) = pdot(:ncol) + state_pdel(:ncol,k)*mdq(:ncol,k) ! layer increment = work (~alpha*dp) - pdzp(:ncol) = (pdot(:ncol)*gravit*state%zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) + pdzp(:ncol) = (pdot(:ncol)*gravit*state_zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) ! enthalpy change due to mass loss and to hydrost. pressure work in full adjustment te(:ncol,k) = te(:ncol,k) & - + state%s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") + + state_s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") + emce(:ncol,k)*mdq(:ncol,k)/fdq(:ncol) & ! (phi-phis)*dq*(Dp/Dp") - pdzp(:ncol) & ! del(g*zm*dp) + htx_cond(:ncol,k) ! EFLX ! momentum - uf(:ncol) = uf(:ncol) +state%u(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) - vf(:ncol) = vf(:ncol) +state%v(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) + uf(:ncol) = uf(:ncol) +state_u(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) + vf(:ncol) = vf(:ncol) +state_v(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) ! adjust constituents to conserve mass in each layer do m = 1, pcnst ! store unadjusted q for use in next k - state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) + state_q(:ncol,k,m) = state_q(:ncol,k,m) / fdq(:ncol) end do ! adjust L-dependent part of local total enthalpy accordingly latent(:ncol,k) = latent(:ncol,k)/fdq(:ncol) ! adjusted u,v tendencies - tend%dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt - tend%dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt + tend_dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt + tend_dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt ! store unadjusted u,v for use in next k - utmp(:ncol) = state%u(:ncol,k) - vtmp(:ncol) = state%v(:ncol,k) + utmp(:ncol) = state_u(:ncol,k) + vtmp(:ncol) = state_v(:ncol,k) ! write adjusted u,v - state%u(:ncol,k) = uf(:ncol) - state%v(:ncol,k) = vf(:ncol) + state_u(:ncol,k) = uf(:ncol) + state_v(:ncol,k) = vf(:ncol) ! compute new total pressure variables - state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) - state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) + state_pint (:ncol,k+1) = state_pint(:ncol,k ) + pdel_new(:ncol,k) + state_lnpint(:ncol,k+1) = log(state_pint(:ncol,k+1)) ! also update pmid for geopotential - state%pmid (:ncol,k ) = .5_r8*(state%pint(:ncol,k)+state%pint(:ncol,k+1)) - state%lnpmid(:ncol,k ) = log(state%pmid(:ncol,k )) + state_pmid (:ncol,k ) = .5_r8*(state_pint(:ncol,k)+state_pint(:ncol,k+1)) + state_lnpmid(:ncol,k ) = log(state_pmid(:ncol,k )) - pdel_rf(:ncol,k)=state%pdel(:ncol,k)/pdel_new(:ncol,k) - state%pdel (:ncol,k ) = pdel_new(:ncol,k) - state%rpdel (:ncol,k ) = 1._r8/state%pdel(:ncol,k) + pdel_rf(:ncol,k)=state_pdel(:ncol,k)/pdel_new(:ncol,k) + state_pdel (:ncol,k ) = pdel_new(:ncol,k) + state_rpdel (:ncol,k ) = 1._r8/state_pdel(:ncol,k) end do @@ -294,85 +302,88 @@ subroutine dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & tot_water(:ncol) = 0.0_r8 do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + tot_water(:ncol) = tot_water(:ncol)+state_q(:ncol,k,m) enddo do m=1,pcnst - if (cnst_type(m).eq.'dry') & - state%q(:ncol,k,m) = state%q(:ncol,k,m)/(1._r8-tot_water(:ncol)) + if (cnst_type(m).eq.'dry') then + state_q(:ncol,k,m) = state_q(:ncol,k,m)/(1._r8-tot_water(:ncol)) + end if enddo enddo ! call QNEG3 (cf physics_update) do m = 1, pcnst if (m /= ixnumice .and. m /= ixnumliq .and. & - m /= ixnumrain .and. m /= ixnumsnow ) then - call qneg3('dme_adjust', state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m)) + m /= ixnumrain .and. m /= ixnumsnow ) then + call qneg3('dme_adjust', lchnk, ncol, state_psetcols, pver, m, m, qmin(m:m), state_q(:,1:pver,m:m)) else do k = 1,pver - state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m)) - state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m)) + state_q(:ncol,k,m) = max(1.e-12_r8,state_q(:ncol,k,m)) + state_q(:ncol,k,m) = min(1.e10_r8,state_q(:ncol,k,m)) end do end if enddo if (conserve_dycore) then - call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore, & - to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + call cam_thermo_water_update(state_q(:ncol,:,:), lchnk, ncol, vc_dycore, & + to_dry_factor=state_pdel(:ncol,:)/state_pdeldry(:ncol,:)) ttsc(:ncol,:)=cpm(:ncol,:)/cp_or_cv_dycore(:ncol,:,lchnk) - cpm (:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) + cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) endif call inv_conserved_energy(levels_are_moist & - ,1 ,pver & - ,te(:ncol,:) & - ,cpm(:ncol,:) & - ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,tp(:ncol,:) & - ,flatent=latent(:ncol,:)*0._r8 & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,vcoord=vcoord ,refstate='liq' & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:)) + 1, pver, & + e(:ncol,:), & + cpm(:ncol,:), & + state_q(:ncol,:,:), state_pdel(:ncol,:), & + pdel_new(:ncol,:), tp(:ncol,:), & + flatent=latent(:ncol,:)*0._r8, & + phis=state_phis(:ncol), gph=zm(:ncol,:), & + vcoord=vcoord, refstate='liq', & + U=state_u(:ncol,:), V=state_v(:ncol,:)) if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 + zvirv(:,:) = shr_const_rwv / rairv(:,:,lchnk) - 1._r8 else zvirv(:,:) = zvir endif ! diagnostics: dme T tendency - ttsc(:ncol,:) =(tp(:ncol,:) - state%t(:ncol,:))/dt ! & + ttsc(:ncol,:) = (tp(:ncol,:) - state_t(:ncol,:))/dt ! & ! for tests: correct for effect of cp update on other physics ttend - ! -tend%dtdt(:ncol,:)*(ttsc(:ncol,:)-1._r8) + ! -tend_dtdt(:ncol,:)*(ttsc(:ncol,:)-1._r8) call outfld('PTTEND_DME', ttsc, pcols, lchnk) ! update ttend and T (cf physics_update) - tend%dtdt(:ncol,:) = tend%dtdt(:ncol,:) + (tp(:ncol,:) - state%t(:ncol,:))/dt - state%t (:ncol,:) = tp(:ncol,:) + tend_dtdt(:ncol,:) = tend_dtdt(:ncol,:) + (tp(:ncol,:) - state_t(:ncol,:))/dt + state_t(:ncol,:) = tp(:ncol,:) ! diagnose total internal enthalpy change do k=1,pver - ent_tnd(:ncol) = ent_tnd(:ncol) + state%pdel(:ncol,k)*te(:ncol,k) + ent_tnd(:ncol) = ent_tnd(:ncol) + state_pdel(:ncol,k)*te(:ncol,k) enddo ent_tnd(:ncol) = ent_tnd(:ncol)/dt/gravit call geopotential_t ( & - state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & - state%t , state%q(:,:,:), rairv(:,:,state%lchnk), gravit , zvirv , & - state%zi , state%zm , ncol ) + state_lnpint, state_lnpmid, state_pint , state_pmid , state_pdel , state_rpdel , & + state_t , state_q(:,:,:), rairv(:,:,lchnk), gravit , zvirv , & + state_zi , state_zm , ncol ) ! update original dry static energy do k = 1, pver - state%s(:ncol,k) = state%t(:ncol,k )*cpairv(:ncol,k,lchnk) & - + gravit*state%zm(:ncol,k) + state%phis(:ncol) + state_s(:ncol,k) = state_t(:ncol,k )*cpairv(:ncol,k,lchnk) & + + gravit*state_zm(:ncol,k) + state_phis(:ncol) enddo contains !=============================================================================== - subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq, & - step , eflx_out , mflx_out, ntrnprd, ntsnprd, mflx, eflx) + subroutine dme_bflx(lchnk, ncol& + state-ps, state-pint, state_zm, state_q, state_pdel, state_phis, state_t, & + qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq, & + step, eflx_out , mflx_out, ntrnprd, ntsnprd, mflx, eflx) !----------------------------------------------------------------------- ! @@ -406,28 +417,33 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, ! ! Arguments ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in ) :: tevp(pcols) ! temperature of evaporation at bottom of atmo - real(r8), intent(in ) :: tprc(pcols) ! temperature of precipitation at bottom of atmo - real(r8), intent(in ) :: dt ! model physics timestep - real(r8), intent(out ) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust - real(r8), intent(out ) :: mdq(pcols,pver) ! total water increment for dme_adjust - character(len=*), intent(in) :: step ! which call in physpkg - real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer - real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer - real(r8), intent(in) :: eflx(pcols) ! boundary enthalpy flux - real(r8), intent(in) :: mflx(pcols) ! boundary mass flux + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + real(r8), intent(inout) :: state_ps(:) + real(r8), intent(inout) :: state_pint(:) + real(r8), intent(in) :: state_zm(:,:) + real(r8), intent(in) :: state_q(:,:) + real(r8), intent(in) :: state_pdel(:,:) + real(r8), intent(in) :: state_phis(:) + real(r8), intent(in) :: state_t(:,:) + real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in) :: tevp(pcols) ! temperature of evaporation at bottom of atmo + real(r8), intent(in) :: tprc(pcols) ! temperature of precipitation at bottom of atmo + real(r8), intent(in) :: dt ! model physics timestep + real(r8), intent(out) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust + real(r8), intent(out) :: mdq(pcols,pver) ! total water increment for dme_adjust + character(len=*), intent(in) :: step ! which call in physpkg + real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer + real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8), intent(in) :: eflx(pcols) ! boundary enthalpy flux + real(r8), intent(in) :: mflx(pcols) ! boundary mass flux !---------------------------Local workspace----------------------------- - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns integer :: i,k,m, ixq ! Longitude, level indices integer :: ierr ! error flag real(r8) :: fdq (pcols) ! mass adjustment factor @@ -440,7 +456,6 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) - real(r8) :: tot_water_chg(pcols) ! work array: total water change integer :: m_cnst real(r8) :: ps_old(pcols) ! old surface pressure real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) @@ -473,42 +488,35 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot !----------------------------------------------------------------------- - if (state%psetcols .ne. pcols) then - call endrun('physics_dme_bflx: cannot pass in a state which has sub-columns') - end if - - lchnk = state%lchnk - ncol = state%ncol - ! store old pressure - ps_old (:ncol) = state%ps(:ncol) - pint_old(:ncol,:) = state%pint(:ncol,:) + ps_old (:ncol) = state_ps(:ncol) + pint_old(:ncol,:) = state_pint(:ncol,:) - zm(:ncol,:)=state%zm(:ncol,:) + zm(:ncol,:) = state_zm(:ncol,:) ! get local specific enthalpy, excluding latent heats if (conserve_dycore) then - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cp_or_cv_dycore(:ncol,:,lchnk) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,te(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & - ,vcoord=vc_dycore ,refstate='liq' & - ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + call get_conserved_energy(levels_are_moist, & + 1, pver, & + cp_or_cv_dycore(:ncol,:,lchnk) , & + state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & + pdel_new(:ncol,:) ,te(:ncol,:) , & + qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & + phis=state_phis(:ncol) ,gph=zm(:ncol,:), & + U=state_u(:ncol,:) ,V=state_v(:ncol,:), & + vcoord=vc_dycore ,refstate='liq', & + flatent=dummy, temce=emce, rairv=rairv(:ncol,:,lchnk)) else - call get_conserved_energy(levels_are_moist & - ,1 ,pver & - ,cpairv(:ncol,:,lchnk) & - ,state%t(:ncol,:) ,state%q(:ncol,:,:) ,state%pdel(:ncol,:) & - ,pdel_new(:ncol,:) ,te(:ncol,:) & - ,qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:) & - ,phis=state%phis(:ncol) ,gph=zm(:ncol,:) & - ,U=state%u(:ncol,:) ,V=state%v(:ncol,:) & - ,refstate='liq' & - ,flatent=dummy,temce=emce,rairv=rairv(:ncol,:,lchnk)) + call get_conserved_energy(levels_are_moist, & + 1, pver, & + cpairv(:ncol,:,lchnk) , & + state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & + pdel_new(:ncol,:) ,te(:ncol,:), & + qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & + phis=state_phis(:ncol) ,gph=zm(:ncol,:), & + U=state_u(:ncol,:) ,V=state_v(:ncol,:), & + refstate='liq', & + flatent=dummy, temce=emce, rairv=rairv(:ncol,:,lchnk)) endif call cnst_get_ind('Q', ixq) @@ -525,45 +533,51 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, tot_water(:ncol,2) = 0.0_r8 do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m) + tot_water(:ncol,2) = tot_water(:ncol,2)+state_q(:ncol,k,m) end do mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) - dvap(:ncol,k) = state%q(:ncol,k,ixq) - qini(:ncol,k) + dvap(:ncol,k) = state_q(:ncol,k,ixq) - qini(:ncol,k) dliq(:ncol,k) = -liqini(:ncol,k) do m_cnst=1,thermodynamic_active_species_liq_num m = thermodynamic_active_species_liq_idx(m_cnst) - dliq(:ncol,k) = dliq(:ncol,k)+state%q(:ncol,k,m) + dliq(:ncol,k) = dliq(:ncol,k)+state_q(:ncol,k,m) end do dice(:ncol,k) = -iceini(:ncol,k) do m_cnst=1,thermodynamic_active_species_ice_num m = thermodynamic_active_species_ice_idx(m_cnst) - dice(:ncol,k) = dice(:ncol,k)+state%q(:ncol,k,m) + dice(:ncol,k) = dice(:ncol,k)+state_q(:ncol,k,m) end do - dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state%pdel(:ncol,k)/gravit - dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state%pdel(:ncol,k)/gravit - dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state%pdel(:ncol,k)/gravit - dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state%pdel(:ncol,k)/gravit + dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state_pdel(:ncol,k)/gravit + dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state_pdel(:ncol,k)/gravit + dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state_pdel(:ncol,k)/gravit + dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state_pdel(:ncol,k)/gravit end do is_invalid(:ncol)=0 - if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt).gt.rtiny)) then - k=maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) - if (masterproc.and.logorrhoic) & ! for testing - print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) - endif - where(dcwat(:ncol)*mflx(:ncol).gt.0._r8) - is_invalid(:ncol)=1 + where(dcwat(:ncol)*mflx(:ncol) .gt. 0._r8) + is_invalid(:ncol) = 1 endwhere - if (maxval(is_invalid(:ncol)).gt.0) then - k=maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) - if (abs(eflx(k)).gt.rtiny) then - if (masterproc.and.logorrhoic) & ! for testing - print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) + + ! For testing only + if (logorrhoic) then + if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt) .gt. rtiny)) then + k = maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) + if (masterproc) then + print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) + end if endif - endif + if (maxval(is_invalid(:ncol)) .gt. 0) then + k = maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) + if (abs(eflx(k)).gt.rtiny) then + if (masterproc) then + print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) + end if + endif + endif + end if ! local specific enthalpy if (conserve) then @@ -583,30 +597,30 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) else if (conserve_dycore) then condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq (:ncol,k) + condepss(:ncol,k) = condcp(:ncol,k)*(state_t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state_phis(:ncol))*mdq (:ncol,k) condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) endif if (bndry_flx_surface) then - condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(tprc(:ncol)-t00a )+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntsnprd(:ncol,k) condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state%phis(:ncol)+(cpliq*t00a+h00a)) + condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state_phis(:ncol)+(cpliq*t00a+h00a)) else if (bndry_flx_local) then if (conserve_dycore) then - condepsf(:ncol,k) = -(cpliq*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(state%t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state%phis(:ncol))*ntsnprd(:ncol,k) + condepsf(:ncol,k) = -(cpliq*(state_t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state_phis(:ncol))*ntrnprd(:ncol,k) & + -(cpice*(state_t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state_phis(:ncol))*ntsnprd(:ncol,k) condepsf(:ncol,k) = condepsf(:ncol,k) - & (ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) condepsf(:ncol,k) = condepsf(:ncol,k) + & - mdqr(:ncol,k)*(cpwv*(state%t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state%phis(:ncol)+(cpliq*t00a+h00a)) + mdqr(:ncol,k)*(cpwv*(state_t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state_phis(:ncol)+(cpliq*t00a+h00a)) else if (conserve_physics) then condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) endif endif ! residual column water change: integrates to surface evaporation - dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state_pdel(:ncol,k)/gravit enddo else mdqr (:ncol,:)=mdq (:ncol,:) @@ -618,13 +632,13 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) else if (conserve_dycore ) then condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state%t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state%phis(:ncol))*mdq(:ncol,k) + condepss(:ncol,k) = condcp(:ncol,k)*(state_t(:ncol,k)-t00a) & + +(zm(:ncol,k)*gravit+state_phis(:ncol))*mdq(:ncol,k) condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) endif if (bndry_flx_surface) then condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state%phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) + condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state_phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) else if (bndry_flx_local) then condepsf(:ncol,k) = condepss(:ncol,k) @@ -634,13 +648,12 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, enddo endif - if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR eflx_out(:ncol ) = eflx(:ncol)*dt do k = 1, pver where(is_invalid(:ncol).eq.0) - eflx_out(:ncol) = eflx_out(:ncol) - state%pdel(:ncol,k)/gravit*condepsf(:ncol,k) + eflx_out(:ncol) = eflx_out(:ncol) - state_pdel(:ncol,k)/gravit*condepsf(:ncol,k) elsewhere eflx_out(:ncol) = 0._r8 endwhere @@ -648,7 +661,7 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, dcqm(:ncol)=0._r8 do k=1,pver where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state%pdel(:ncol,k)/gravit + dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state_pdel(:ncol,k)/gravit endwhere enddo where(abs(dcwatr(:ncol)).gt.rtiny) @@ -671,7 +684,7 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, do k = 1, pver where(is_invalid(:ncol).eq.0) ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - mflx_out(:ncol) = mflx_out(:ncol) + state%pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt + mflx_out(:ncol) = mflx_out(:ncol) + state_pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt endwhere enddo @@ -680,7 +693,7 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, do k = 1, pver where(is_invalid(:ncol).eq.0) ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - eflx_out(:ncol) = eflx_out(:ncol) + state%pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt + eflx_out(:ncol) = eflx_out(:ncol) + state_pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt endwhere enddo @@ -692,9 +705,9 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, endif ! new surface pressure - state%ps(:ncol) = state%pint(:ncol,1) + state_ps(:ncol) = state_pint(:ncol,1) do k = 1, pver - state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + state_ps(:ncol) = state_ps(:ncol) + state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) end do ! heat exchange with condensates @@ -705,10 +718,10 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below if (k.eq.1) then condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) + *state_pdel(i,k)/(state_ps(i)-state_pint(i,k)) else condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state%pdel(i,k)/(state%ps(i)-state%pint(i,k)) & + *state_pdel(i,k)/(state_ps(i)-state_pint(i,k)) & +condepsf(i,k-1) endif else @@ -719,16 +732,16 @@ subroutine dme_bflx(state, tend, qini, liqini, iceini, tevp, tprc, dt, htx_cond, +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) enddo - pdel_new(:ncol,k) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + pdel_new(:ncol,k) = state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) ! compute new total pressure variables - state%pint(:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol,k) + state_pint(:ncol,k+1) = state_pint(:ncol,k ) + pdel_new(:ncol,k) end do ! original pressure - state%ps (:ncol) = ps_old (:ncol) - state%pint(:ncol,:) = pint_old(:ncol,:) + state_ps (:ncol) = ps_old (:ncol) + state_pint(:ncol,:) = pint_old(:ncol,:) end subroutine dme_bflx diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index c53fcd0d14..2c2d38f03b 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1403,9 +1403,17 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & real(r8), intent(out) :: pdel_rf(pcols,pver) ! ratio old pdel / new pdel !----------------------------------------------------------------------- - call dme_adjust_camnor_run(state, tend, qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & - ent_tnd, pdel_rf) + if (state%psetcols /= pcols) then + call endrun('physics_dme_adjust_camnor: cannot pass in a state which has sub-columns') + end if + + call dme_adjust_camnor_run(state%lcnhk, state%ncol, & + state%psetcols, state%pint, state%ps, state%phis, state%zm, state%zi, & + state%t, state%u, state%v, state%pdel state%q, state%s, & + tend%dudt, tend%dvdt, tend%dtdt, & + qini, liqini, iceini, dt, & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + ent_tnd, pdel_rf) end subroutine physics_dme_adjust_camnor From 2ecc5100ee74ea27f5799d9369e496fe27ee7801 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 16:56:53 +0200 Subject: [PATCH 26/78] fixed compile problems --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 099071f0cd..878a33ea2f 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -331,7 +331,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) endif - call inv_conserved_energy(levels_are_moist & + call inv_conserved_energy(levels_are_moist, & 1, pver, & e(:ncol,:), & cpm(:ncol,:), & @@ -380,8 +380,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & !=============================================================================== - subroutine dme_bflx(lchnk, ncol& - state-ps, state-pint, state_zm, state_q, state_pdel, state_phis, state_t, & + subroutine dme_bflx(lchnk, ncol, & + state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq, & step, eflx_out , mflx_out, ntrnprd, ntsnprd, mflx, eflx) From 992188bcb693b863a10d3ffd65cc09fd99af9abb Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 17:28:53 +0200 Subject: [PATCH 27/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 878a33ea2f..63f0d0f109 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -144,7 +144,9 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! Diagnose boundary enthalpy flux and local heating rates associated to ! atmospheric moisture change - call dme_bflx(state, tend, qini, liqini, iceini, tevap, tprec, dt, & + call dme_bflx(lchnk, ncol, & + state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & + qini, liqini, iceini, tevap, tprec, dt, & htx_cond, mdq, step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & mflx=mflx, eflx=eflx, eflx_out=eflx_out, mflx_out=mflx_out) From 663b63dfb6c68ac5eb6dbfb27b7b74992c4d0d7b Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 17:32:35 +0200 Subject: [PATCH 28/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 63f0d0f109..0bbb541427 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -126,6 +126,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8) :: mdq(pcols,pver) ! total water tendency logical :: hydrostatic = .true. + logical :: levels_are_moist=.true. ! TODO: put in namelist? ! 5 possibilities (-> = currently reccommended): ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) @@ -422,8 +423,8 @@ subroutine dme_bflx(lchnk, ncol, & integer, intent(in) :: lchnk integer, intent(in) :: ncol real(r8), intent(inout) :: state_ps(:) - real(r8), intent(inout) :: state_pint(:) - real(r8), intent(in) :: state_zm(:,:) + real(r8), intent(inout) :: state_pint(:,:) + real(r8), intent(in) :: state_zm(:) real(r8), intent(in) :: state_q(:,:) real(r8), intent(in) :: state_pdel(:,:) real(r8), intent(in) :: state_phis(:) From 82cc1d3640e8caee5ea328eb6c17a0fdc822cbf6 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 17:35:34 +0200 Subject: [PATCH 29/78] fixed compiler problem --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 0bbb541427..95da2d51d8 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -70,7 +70,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8), intent(inout) :: state_pint(:,:) real(r8), intent(in) :: state_phis(:) real(r8), intent(inout) :: state_ps(:) - real(r8), intent(in) :: state_zm(:) + real(r8), intent(in) :: state_zm(:,:) real(r8), intent(in) :: state_zi(:) real(r8), intent(inout) :: state_t(:,:) real(r8), intent(inout) :: state_u(:,:) @@ -168,7 +168,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ps_old (:ncol) = state_ps(:ncol) state_ps(:ncol) = state_pint(:ncol,1) - zm(:ncol,:)=state_zm(:ncol,:) + zm(:ncol,:) = state_zm(:ncol,:) if (conserve_dycore) then vcoord=vc_dycore @@ -187,11 +187,11 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & cpm(:ncol,:), & state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & pdel_new(:ncol,:) ,state_s(:ncol,:), & - qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & - phis=state_phis(:ncol) ,gph=zm(:ncol,:), & - U=state_u(:ncol,:) ,V=state_v(:ncol,:),rairv=rairv(:ncol,:,lchnk), & + qini=qini(:ncol,:), liqini=liqini(:ncol,:), iceini=iceini(:ncol,:), & + phis=state_phis(:ncol), gph=zm(:ncol,:), & + U=state_u(:ncol,:), V=state_v(:ncol,:), rairv=rairv(:ncol,:,lchnk), & vcoord=vcoord ,refstate='liq', & - flatent=latent(:ncol,:),temce=emce(:ncol,:)) + flatent=latent(:ncol,:), temce=emce(:ncol,:)) do k = 1, pver ! Dp'/Dp From f89650ba205717276a0277f47b5160af0cf2b34c Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 20:07:24 +0200 Subject: [PATCH 30/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 95da2d51d8..85fe0009b4 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -76,7 +76,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8), intent(inout) :: state_u(:,:) real(r8), intent(inout) :: state_v(:,:) real(r8), intent(inout) :: state_pdel(:,:) - real(r8), intent(inout) :: state_q(:,:) + real(r8), intent(inout) :: state_q(:,:,:) real(r8), intent(inout) :: state_s(:,:) real(r8), intent(inout) :: tend_dudt(:,:) real(r8), intent(inout) :: tend_dvdt(:,:) @@ -424,8 +424,8 @@ subroutine dme_bflx(lchnk, ncol, & integer, intent(in) :: ncol real(r8), intent(inout) :: state_ps(:) real(r8), intent(inout) :: state_pint(:,:) - real(r8), intent(in) :: state_zm(:) - real(r8), intent(in) :: state_q(:,:) + real(r8), intent(in) :: state_zm(:,:) + real(r8), intent(in) :: state_q(:,:,:) real(r8), intent(in) :: state_pdel(:,:) real(r8), intent(in) :: state_phis(:) real(r8), intent(in) :: state_t(:,:) @@ -516,7 +516,7 @@ subroutine dme_bflx(lchnk, ncol, & state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & pdel_new(:ncol,:) ,te(:ncol,:), & qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & - phis=state_phis(:ncol) ,gph=zm(:ncol,:), & + phis=state_phis(:ncol), gph=zm(:ncol,:), & U=state_u(:ncol,:) ,V=state_v(:ncol,:), & refstate='liq', & flatent=dummy, temce=emce, rairv=rairv(:ncol,:,lchnk)) From 613958e68db11da42ec5ecbd7392c90c669c5430 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 20:15:08 +0200 Subject: [PATCH 31/78] fixed compiler problem --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 85fe0009b4..b80f7a8f26 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -53,7 +53,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & use air_composition, only: dry_air_species_num use air_composition, only: thermodynamic_active_species_num use air_composItion, only: thermodynamic_active_species_idx - use air_composition, only: cpairv, cp_or_cv_dycore + use air_composition, only: cpairv, rairv, cp_or_cv_dycore use constituents, only: cnst_get_ind, cnst_type use cam_thermo, only: inv_conserved_energy use cam_thermo, only: get_conserved_energy @@ -168,29 +168,29 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ps_old (:ncol) = state_ps(:ncol) state_ps(:ncol) = state_pint(:ncol,1) - zm(:ncol,:) = state_zm(:ncol,:) + zm(:ncol,:) = state_zm(:ncol,:) ! TODO - remoe and use state_zm instead below if (conserve_dycore) then vcoord=vc_dycore - cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) + cpm(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) else vcoord=vc_physics - cpm(:ncol,:)=cpairv(:ncol,:,lchnk) + cpm(:ncol,:) = cpairv(:ncol,:,lchnk) endif do k = 1, pver - tp(:ncol,k) = state_t(:ncol,k) + tp(:ncol,k) = state_t(:ncol,k) ! TODO - remoe and use state_t instead below enddo call get_conserved_energy(levels_are_moist, & - 1 ,pver, & + 1, pver, & cpm(:ncol,:), & - state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & - pdel_new(:ncol,:) ,state_s(:ncol,:), & + state_t(:ncol,:), state_q(:ncol,:,:) ,state_pdel(:ncol,:), & + pdel_new(:ncol,:), state_s(:ncol,:), & qini=qini(:ncol,:), liqini=liqini(:ncol,:), iceini=iceini(:ncol,:), & - phis=state_phis(:ncol), gph=zm(:ncol,:), & + phis=state_phis(:ncol) ,gph=zm(:ncol,:), & U=state_u(:ncol,:), V=state_v(:ncol,:), rairv=rairv(:ncol,:,lchnk), & - vcoord=vcoord ,refstate='liq', & + vcoord=vcoord, refstate='liq', & flatent=latent(:ncol,:), temce=emce(:ncol,:)) do k = 1, pver @@ -211,9 +211,9 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & enddo ! lagrangian & advective pressure change at top interface - pdot (:ncol) = 0._r8 - pdzp (:ncol) = 0._r8 - edot (:ncol) = 0._r8 + pdot(:ncol) = 0._r8 + pdzp(:ncol) = 0._r8 + edot(:ncol) = 0._r8 ! store old enthalpy integral ent_tnd(:ncol)=0._r8 @@ -232,15 +232,15 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) ! this is Dp"/Dp ! wind adjustment increments - uf (:ncol) = 0. - vf (:ncol) = 0. + uf(:ncol) = 0. + vf(:ncol) = 0. ! u,vtmp set to pre-physics u,v from the updated values and the tendencies utmp(:ncol) = state_u(:ncol,k) - dt * tend_dudt(:ncol,k) vtmp(:ncol) = state_v(:ncol,k) - dt * tend_dvdt(:ncol,k) ! adjust specific enthalpy - te (:ncol,k) = 0._r8 + te(:ncol,k) = 0._r8 ! lagrangian pressure change *zi at upper interfac pdzp(:ncol) = pdot(:ncol)*gravit*state_zi(:ncol,k) From 8392aababea3eb4f39d7ebca3f8afad35697e34d Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 21:27:15 +0200 Subject: [PATCH 32/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 9 ++++++--- src/physics/camnor_phys/physics/physics_types.F90 | 3 ++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index b80f7a8f26..607958d45e 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -8,7 +8,8 @@ module dme_adjust_camnor contains subroutine dme_adjust_camnor_run(lchnk, ncol, & - state_psetcols, state_pint, state_ps, state_phis, state_zm, state_zi, & + state_psetcols, state_pint, state_lnpint, state_lnpmid, & + state_ps, state_phis, state_zm, state_zi, & state_t, state_u, state_v, state_pdel, state_q, state_s, & tend_dudt, tend_dvdt, tend_dtdt, & qini, liqini, iceini, dt, & @@ -68,10 +69,12 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & integer, intent(in) :: ncol integer, intent(in) :: state_psetcols real(r8), intent(inout) :: state_pint(:,:) + real(r8), intent(out) :: state_lnpint(:,:) + real(r8), intent(out) :: state_lnpmid(:,:) real(r8), intent(in) :: state_phis(:) real(r8), intent(inout) :: state_ps(:) real(r8), intent(in) :: state_zm(:,:) - real(r8), intent(in) :: state_zi(:) + real(r8), intent(in) :: state_zi(:,:) real(r8), intent(inout) :: state_t(:,:) real(r8), intent(inout) :: state_u(:,:) real(r8), intent(inout) :: state_v(:,:) @@ -416,7 +419,7 @@ subroutine dme_bflx(lchnk, ncol, & use air_composition, only: thermodynamic_active_species_ice_num use air_composition, only: dry_air_species_num use air_composition, only: t00a, h00a - use physconst, only: cpair, cpwv, cpliq, cpice + use physconst, only: cpair, cpwv, cpliq, cpice, gravit ! ! Arguments ! diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 2c2d38f03b..33cce22739 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1408,7 +1408,8 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & end if call dme_adjust_camnor_run(state%lcnhk, state%ncol, & - state%psetcols, state%pint, state%ps, state%phis, state%zm, state%zi, & + state%psetcols, state%pint, state%lnpint, state%lnpmid, & + state%ps, state%phis, state%zm, state%zi, & state%t, state%u, state%v, state%pdel state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & qini, liqini, iceini, dt, & From 6ba79c4df9a0c6fd0c3a756c12a9951513f05e7c Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 21:40:02 +0200 Subject: [PATCH 33/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 7 ++++--- src/physics/camnor_phys/physics/physics_types.F90 | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 607958d45e..13b2cd7a31 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -62,6 +62,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & use dyn_tests_utils, only: vc_dycore, vc_physics use qneg_module, only: qneg3 use cam_history, only: outfld + use physconst, only: cpair, cpwv, cpliq, cpice, gravit ! ! Arguments ! @@ -69,6 +70,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & integer, intent(in) :: ncol integer, intent(in) :: state_psetcols real(r8), intent(inout) :: state_pint(:,:) + real(r8), intent(out) :: state_pmid(:,:) real(r8), intent(out) :: state_lnpint(:,:) real(r8), intent(out) :: state_lnpmid(:,:) real(r8), intent(in) :: state_phis(:) @@ -290,8 +292,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & state_lnpint(:ncol,k+1) = log(state_pint(:ncol,k+1)) ! also update pmid for geopotential - state_pmid (:ncol,k ) = .5_r8*(state_pint(:ncol,k)+state_pint(:ncol,k+1)) - state_lnpmid(:ncol,k ) = log(state_pmid(:ncol,k )) + state_pmid (:ncol,k) = .5_r8*(state_pint(:ncol,k)+state_pint(:ncol,k+1)) + state_lnpmid(:ncol,k) = log(state_pmid(:ncol,k )) pdel_rf(:ncol,k)=state_pdel(:ncol,k)/pdel_new(:ncol,k) state_pdel (:ncol,k ) = pdel_new(:ncol,k) @@ -419,7 +421,6 @@ subroutine dme_bflx(lchnk, ncol, & use air_composition, only: thermodynamic_active_species_ice_num use air_composition, only: dry_air_species_num use air_composition, only: t00a, h00a - use physconst, only: cpair, cpwv, cpliq, cpice, gravit ! ! Arguments ! diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 33cce22739..d1a0468189 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1408,7 +1408,7 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & end if call dme_adjust_camnor_run(state%lcnhk, state%ncol, & - state%psetcols, state%pint, state%lnpint, state%lnpmid, & + state%psetcols, state%pint, state%pmid, state%lnpint, state%lnpmid, & state%ps, state%phis, state%zm, state%zi, & state%t, state%u, state%v, state%pdel state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & From 70e763c75a8c996653caac4b52cf5b90a2b353e8 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 21:44:06 +0200 Subject: [PATCH 34/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 8 +++++--- src/physics/camnor_phys/physics/physics_types.F90 | 3 ++- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 13b2cd7a31..2bd6fc0f94 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -8,9 +8,10 @@ module dme_adjust_camnor contains subroutine dme_adjust_camnor_run(lchnk, ncol, & - state_psetcols, state_pint, state_lnpint, state_lnpmid, & + state_psetcols, state_pint, state_pmid, & + state_pdel, state_rpdel, state_lnpint, state_lnpmid, & state_ps, state_phis, state_zm, state_zi, & - state_t, state_u, state_v, state_pdel, state_q, state_s, & + state_t, state_u, state_v, state_q, state_s, & tend_dudt, tend_dvdt, tend_dtdt, & qini, liqini, iceini, dt, & step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & @@ -71,6 +72,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & integer, intent(in) :: state_psetcols real(r8), intent(inout) :: state_pint(:,:) real(r8), intent(out) :: state_pmid(:,:) + real(r8), intent(inout) :: state_pdel(:,:) + real(r8), intent(out) :: state_rpdel(:,:) real(r8), intent(out) :: state_lnpint(:,:) real(r8), intent(out) :: state_lnpmid(:,:) real(r8), intent(in) :: state_phis(:) @@ -80,7 +83,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8), intent(inout) :: state_t(:,:) real(r8), intent(inout) :: state_u(:,:) real(r8), intent(inout) :: state_v(:,:) - real(r8), intent(inout) :: state_pdel(:,:) real(r8), intent(inout) :: state_q(:,:,:) real(r8), intent(inout) :: state_s(:,:) real(r8), intent(inout) :: tend_dudt(:,:) diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index d1a0468189..7c0774b8fc 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1408,7 +1408,8 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & end if call dme_adjust_camnor_run(state%lcnhk, state%ncol, & - state%psetcols, state%pint, state%pmid, state%lnpint, state%lnpmid, & + state%psetcols, state%pint, state%pmid, & + state%pdel, state%rpdel, state%lnpint, state%lnpmid, & state%ps, state%phis, state%zm, state%zi, & state%t, state%u, state%v, state%pdel state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & From cb2c254a79f028c83aa3bab464606bd8c6e48956 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 21:46:22 +0200 Subject: [PATCH 35/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 3 ++- src/physics/camnor_phys/physics/physics_types.F90 | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 2bd6fc0f94..6174200020 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -9,7 +9,7 @@ module dme_adjust_camnor subroutine dme_adjust_camnor_run(lchnk, ncol, & state_psetcols, state_pint, state_pmid, & - state_pdel, state_rpdel, state_lnpint, state_lnpmid, & + state_pdel, state_rpdel, state_pdeldry, state_lnpint, state_lnpmid, & state_ps, state_phis, state_zm, state_zi, & state_t, state_u, state_v, state_q, state_s, & tend_dudt, tend_dvdt, tend_dtdt, & @@ -74,6 +74,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8), intent(out) :: state_pmid(:,:) real(r8), intent(inout) :: state_pdel(:,:) real(r8), intent(out) :: state_rpdel(:,:) + real(r8), intent(in) :: state_pdeldry(:,:) real(r8), intent(out) :: state_lnpint(:,:) real(r8), intent(out) :: state_lnpmid(:,:) real(r8), intent(in) :: state_phis(:) diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 7c0774b8fc..0426db432c 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1409,7 +1409,7 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & call dme_adjust_camnor_run(state%lcnhk, state%ncol, & state%psetcols, state%pint, state%pmid, & - state%pdel, state%rpdel, state%lnpint, state%lnpmid, & + state%pdel, state%rpdel, state%pdeldry, state%lnpint, state%lnpmid, & state%ps, state%phis, state%zm, state%zi, & state%t, state%u, state%v, state%pdel state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & From 9f4f2832c62c19750620155554c428b7dc4ad62a Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 21:47:58 +0200 Subject: [PATCH 36/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 6174200020..813ca57e2b 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -344,7 +344,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & call inv_conserved_energy(levels_are_moist, & 1, pver, & - e(:ncol,:), & + te(:ncol,:), & cpm(:ncol,:), & state_q(:ncol,:,:), state_pdel(:ncol,:), & pdel_new(:ncol,:), tp(:ncol,:), & From 715155f27c8b3df93ffec3c513cb702a0a88a9ec Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 22:59:57 +0200 Subject: [PATCH 37/78] fixed compiler problem --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 56 ++++++++++--------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 813ca57e2b..36e3f49f38 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -5,6 +5,30 @@ module dme_adjust_camnor public :: dme_adjust_camnor_run + logical :: levels_are_moist=.true. ! TODO: put in namelist? + + ! 5 possibilities (-> = currently reccommended): + ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) + ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) + ! -> 3) conserve_dycore=.true. , bndry_flx_local=.true. (requires fixer to match correct surface fluxes) + ! 4) conserve_physics=.true. , bndry_flx_local=.true. (as 3., plus fixer for atmo energy) + ! 5) conserve_physics=.true. , bndry_flx_surface=.true. (no advantage wrt option 2) + + ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its + ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. + + logical, parameter :: conserve_dycore = .true. + logical, parameter :: bndry_flx_surface = .true. + logical, parameter :: conserve_physics = .not. conserve_dycore + logical, parameter :: bndry_flx_local = .not. bndry_flx_surface + logical, parameter :: conserve = conserve_dycore .or. conserve_physics + + real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) + + ! set to T to use distribute implied heating over column section to the surface + logical, parameter :: l_nolocdcpttend=.true. + logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot + contains subroutine dme_adjust_camnor_run(lchnk, ncol, & @@ -63,7 +87,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & use dyn_tests_utils, only: vc_dycore, vc_physics use qneg_module, only: qneg3 use cam_history, only: outfld - use physconst, only: cpair, cpwv, cpliq, cpice, gravit + use physconst, only: cpair, cpwv, cpliq, cpice, gravit, zvir ! ! Arguments ! @@ -79,8 +103,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8), intent(out) :: state_lnpmid(:,:) real(r8), intent(in) :: state_phis(:) real(r8), intent(inout) :: state_ps(:) - real(r8), intent(in) :: state_zm(:,:) - real(r8), intent(in) :: state_zi(:,:) + real(r8), intent(inout) :: state_zm(:,:) + real(r8), intent(inout) :: state_zi(:,:) real(r8), intent(inout) :: state_t(:,:) real(r8), intent(inout) :: state_u(:,:) real(r8), intent(inout) :: state_v(:,:) @@ -133,22 +157,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" real(r8) :: mdq(pcols,pver) ! total water tendency logical :: hydrostatic = .true. - - logical :: levels_are_moist=.true. ! TODO: put in namelist? - ! 5 possibilities (-> = currently reccommended): - ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) - ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) - ! -> 3) conserve_dycore=.true. , bndry_flx_local=.true. (requires fixer to match correct surface fluxes) - ! 4) conserve_physics=.true. , bndry_flx_local=.true. (as 3., plus fixer for atmo energy) - ! 5) conserve_physics=.true. , bndry_flx_surface=.true. (no advantage wrt option 2) - - ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its - ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. - - logical, parameter :: conserve_dycore = .true. - logical, parameter :: bndry_flx_surface = .true. - logical, parameter :: conserve_physics = .not. conserve_dycore - logical, parameter :: bndry_flx_local = .not. bndry_flx_surface !----------------------------------------------------------------------- ! Diagnose boundary enthalpy flux and local heating rates associated to @@ -490,12 +498,6 @@ subroutine dme_bflx(lchnk, ncol, & real(r8) :: pint_old(pcols,pver+1) ! work array real(r8) :: dummy(pcols,pver) ! work array integer :: is_invalid(pcols) - ! - logical , parameter :: conserve = conserve_dycore .or. conserve_physics - real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) - ! set to T to use distribute implied heating over column section to the surface - logical, parameter :: l_nolocdcpttend=.true. - logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot !----------------------------------------------------------------------- ! store old pressure @@ -603,7 +605,7 @@ subroutine dme_bflx(lchnk, ncol, & dcwatr(:ncol) = 0._r8 do k=1,pver mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change - if (conserve_physics.or..not.l_nolocdcpttend) then + if (conserve_physics .or. .not. l_nolocdcpttend) then condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) else if (conserve_dycore) then condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice @@ -658,7 +660,7 @@ subroutine dme_bflx(lchnk, ncol, & enddo endif - if (conserve .and. present(eflx) .and. present(mflx)) then ! partition arbitrarily based on sign match + if (conserve) then ! partition arbitrarily based on sign match ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR eflx_out(:ncol ) = eflx(:ncol)*dt do k = 1, pver From a99df1f5ab2430e177fb8e6dbe3e03bcc73d3e70 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 23:01:37 +0200 Subject: [PATCH 38/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 36e3f49f38..47432de5cc 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -1,5 +1,7 @@ module dme_adjust_camnor + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none private ! Make default type private to the module @@ -67,7 +69,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! !----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 use constituents, only: pcnst, qmin use cam_logfile, only: iulog use cam_abortutils, only: endrun From e21b13503749705b63988afc0d00c27de8827525 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 1 Oct 2025 23:05:52 +0200 Subject: [PATCH 39/78] fixed compiler problem --- src/physics/camnor_phys/physics/physics_types.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 0426db432c..242b88c04e 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1377,7 +1377,7 @@ end subroutine physics_dme_adjust !=============================================================================== subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) use dme_adjust_camnor, only: dme_adjust_camnor_run @@ -1407,11 +1407,11 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & call endrun('physics_dme_adjust_camnor: cannot pass in a state which has sub-columns') end if - call dme_adjust_camnor_run(state%lcnhk, state%ncol, & + call dme_adjust_camnor_run(state%lchnk, state%ncol, & state%psetcols, state%pint, state%pmid, & state%pdel, state%rpdel, state%pdeldry, state%lnpint, state%lnpmid, & state%ps, state%phis, state%zm, state%zi, & - state%t, state%u, state%v, state%pdel state%q, state%s, & + state%t, state%u, state%v, state%pdel, state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & qini, liqini, iceini, dt, & step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & From 563c237e54ceec771db1032d2906362fb5c71f21 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 2 Oct 2025 13:28:44 +0200 Subject: [PATCH 40/78] add compute_enthalpy_flux correctly to advertise phase --- src/cpl/nuopc/atm_comp_nuopc.F90 | 2 +- src/cpl/nuopc/atm_import_export.F90 | 17 ++++++++++++----- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index a737ad1f68..e60edcb4da 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -320,7 +320,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (isPresent .and. isSet) then read (cvalue,*) mediator_present if (mediator_present) then - call advertise_fields(gcomp, flds_scalar_name, rc) + call advertise_fields(gcomp, flds_scalar_name, compute_enthalpy_flux, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if else diff --git a/src/cpl/nuopc/atm_import_export.F90 b/src/cpl/nuopc/atm_import_export.F90 index c14f41a996..3cc64835e4 100644 --- a/src/cpl/nuopc/atm_import_export.F90 +++ b/src/cpl/nuopc/atm_import_export.F90 @@ -27,7 +27,6 @@ module atm_import_export use atm_stream_ndep , only : ndep_stream_active use chemistry , only : chem_has_ndep_flx use cam_control_mod , only : aqua_planet, simple_phys - use air_composition , only : compute_enthalpy_flux implicit none private ! except @@ -67,6 +66,8 @@ module atm_import_export logical, public :: brf_from_ocn = .false. ! brf is obtained from ocean as atm import data logical, public :: n2o_from_ocn = .false. ! n2o is obtained from ocean as atm import data logical, public :: nh3_from_ocn = .false. ! nh3 is obtained from ocean as atm import data + logical, protected :: compute_enthalpy_flux = .false. + character(*),parameter :: F01 = "('(cam_import_export) ',a,i8,2x,i8,2x,d21.14)" character(*),parameter :: F02 = "('(cam_import_export) ',a,i8,2x,i8,2x,i8,2x,d21.14)" character(*),parameter :: u_FILE_u = __FILE__ @@ -100,11 +101,12 @@ end subroutine read_surface_fields_namelists !----------------------------------------------------------- ! advertise fields !----------------------------------------------------------- - subroutine advertise_fields(gcomp, flds_scalar_name, rc) + subroutine advertise_fields(gcomp, flds_scalar_name, compute_enthalpy_flux_in, rc) ! input/output variables type(ESMF_GridComp) :: gcomp character(len=*) , intent(in) :: flds_scalar_name + logical , intent(in) :: compute_enthalpy_flux_in integer , intent(out) :: rc ! local variables @@ -131,6 +133,9 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) ! determine necessary toggles for below !-------------------------------- + ! Set module variable + compute_enthalpy_flux = compute_enthalpy_flux_in + call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) flds_co2a @@ -304,8 +309,10 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_sen' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lwup' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_evap' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faox_evap' ) - call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_hrof' ) + if (compute_enthalpy_flux) then + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faox_evap' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_hrof' ) + end if ! dust fluxes from land (4 sizes) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Fall_flxdst', ungridded_lbound=1, ungridded_ubound=4) @@ -619,7 +626,7 @@ subroutine import_fields( gcomp, cam_in, restart_init, rc) call state_getfldptr(importState, 'Faxx_evap', fldptr=fldptr_evap, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! ***NOTE:*** if cam_compute_enthalpy_flux is .false. and if in + ! ***NOTE:*** if atm_compute_enthalpy_flux is .false. and if in ! CMEPS med_computes_enthalpy_flux is .true., then the mediator ! will compute it if the ocean requests it and add a correction ! to the sensible heat sent to cam. From 400de7b73338dcd244bea821acdc1a0855caacd6 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 15:42:46 +0200 Subject: [PATCH 41/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 3 ++- src/physics/camnor_phys/physics/physics_types.F90 | 7 +++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 47432de5cc..0177d4df8d 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -401,7 +401,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & !=============================================================================== subroutine dme_bflx(lchnk, ncol, & - state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & + state_ps, state_pint, state_pmid, & + state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq, & step, eflx_out , mflx_out, ntrnprd, ntsnprd, mflx, eflx) diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 index 242b88c04e..797e899361 100644 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ b/src/physics/camnor_phys/physics/physics_types.F90 @@ -1380,6 +1380,9 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) + ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to + ! atmospheric moisture change: Author: Thomas Toniazzo (17.07.21) + use dme_adjust_camnor, only: dme_adjust_camnor_run ! ! Arguments @@ -1411,10 +1414,10 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & state%psetcols, state%pint, state%pmid, & state%pdel, state%rpdel, state%pdeldry, state%lnpint, state%lnpmid, & state%ps, state%phis, state%zm, state%zi, & - state%t, state%u, state%v, state%pdel, state%q, state%s, & + state%t, state%u, state%v, state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) end subroutine physics_dme_adjust_camnor From 11e32b6d715fd7bf2c5601e88023aa1fe7adc0ac Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 15:54:20 +0200 Subject: [PATCH 42/78] fixed compiler problem --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 28 ++++++++----------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 0177d4df8d..4523a9efed 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -163,10 +163,12 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! Diagnose boundary enthalpy flux and local heating rates associated to ! atmospheric moisture change call dme_bflx(lchnk, ncol, & - state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & + state_ps, state_pint, state_pmid, & + state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevap, tprec, dt, & - htx_cond, mdq, step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & - mflx=mflx, eflx=eflx, eflx_out=eflx_out, mflx_out=mflx_out) + step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & + mflx=mflx, eflx=eflx, eflx_out=eflx_out, mflx_out=mflx_out, & + htx_cond=htx_cond, mdq=mdq ) ! Ajust the dry mass in each layer back to the value of physics input state ! Adjust air specific enthalpy accordingly @@ -403,8 +405,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & subroutine dme_bflx(lchnk, ncol, & state_ps, state_pint, state_pmid, & state_zm, state_q, state_pdel, state_phis, state_t, & - qini, liqini, iceini, tevp, tprc, dt, htx_cond, mdq, & - step, eflx_out , mflx_out, ntrnprd, ntsnprd, mflx, eflx) + qini, liqini, iceini, tevp, tprc, dt, & + htx_cond, mdq, step, ntrnprd, ntsnprd, mflx, eflx, eflx_out, mflx_out) !----------------------------------------------------------------------- ! @@ -452,29 +454,26 @@ subroutine dme_bflx(lchnk, ncol, & real(r8), intent(in) :: tevp(pcols) ! temperature of evaporation at bottom of atmo real(r8), intent(in) :: tprc(pcols) ! temperature of precipitation at bottom of atmo real(r8), intent(in) :: dt ! model physics timestep - real(r8), intent(out) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust - real(r8), intent(out) :: mdq(pcols,pver) ! total water increment for dme_adjust character(len=*), intent(in) :: step ! which call in physpkg - real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer real(r8), intent(in) :: eflx(pcols) ! boundary enthalpy flux real(r8), intent(in) :: mflx(pcols) ! boundary mass flux + real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust + real(r8), intent(out) :: mdq(pcols,pver) ! total water increment for dme_adjust !---------------------------Local workspace----------------------------- integer :: i,k,m, ixq ! Longitude, level indices integer :: ierr ! error flag real(r8) :: fdq (pcols) ! mass adjustment factor - real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values real(r8) :: dcvap(pcols) ! total column vapour change real(r8) :: dcliq(pcols) ! total column liquid change real(r8) :: dcice(pcols) ! total column ice change real(r8) :: dcwat(pcols) ! total column water change real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) - real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) integer :: m_cnst real(r8) :: ps_old(pcols) ! old surface pressure @@ -491,12 +490,7 @@ subroutine dme_bflx(lchnk, ncol, & real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes - real(r8) :: condmox_ref(pcols,pver) ! local specific x-momentum of "condensates" (mass source) - real(r8) :: condmox (pcols,pver) ! specific x-momentum of moist reservoir with which q is exchanged - real(r8) :: condmoy_ref(pcols,pver) ! local specific y-momentum of "condensates" (mass source) - real(r8) :: condmoy (pcols,pver) ! specific y-momentum of moist reservoir with which q is exchanged real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp - real(r8) :: uf(pcols), vf(pcols) ! work arrays real(r8) :: pint_old(pcols,pver+1) ! work array real(r8) :: dummy(pcols,pver) ! work array integer :: is_invalid(pcols) From 202df9d932fab9244096d06481a7c6050a38b358 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 15:57:00 +0200 Subject: [PATCH 43/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 4523a9efed..2d7049ffda 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -163,8 +163,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! Diagnose boundary enthalpy flux and local heating rates associated to ! atmospheric moisture change call dme_bflx(lchnk, ncol, & - state_ps, state_pint, state_pmid, & - state_zm, state_q, state_pdel, state_phis, state_t, & + state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevap, tprec, dt, & step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & mflx=mflx, eflx=eflx, eflx_out=eflx_out, mflx_out=mflx_out, & @@ -403,8 +402,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & !=============================================================================== subroutine dme_bflx(lchnk, ncol, & - state_ps, state_pint, state_pmid, & - state_zm, state_q, state_pdel, state_phis, state_t, & + state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevp, tprc, dt, & htx_cond, mdq, step, ntrnprd, ntsnprd, mflx, eflx, eflx_out, mflx_out) @@ -658,7 +656,7 @@ subroutine dme_bflx(lchnk, ncol, & if (conserve) then ! partition arbitrarily based on sign match ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR - eflx_out(:ncol ) = eflx(:ncol)*dt + eflx_out(:ncol) = eflx(:ncol)*dt do k = 1, pver where(is_invalid(:ncol).eq.0) eflx_out(:ncol) = eflx_out(:ncol) - state_pdel(:ncol,k)/gravit*condepsf(:ncol,k) From 8298486cc459ebb541389b2b52685cc72de1d8b7 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 16:31:42 +0200 Subject: [PATCH 44/78] fixed compiler problem --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 2d7049ffda..cc9c082075 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -162,12 +162,12 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! Diagnose boundary enthalpy flux and local heating rates associated to ! atmospheric moisture change + call dme_bflx(lchnk, ncol, & state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevap, tprec, dt, & step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & - mflx=mflx, eflx=eflx, eflx_out=eflx_out, mflx_out=mflx_out, & - htx_cond=htx_cond, mdq=mdq ) + mflx=mflx, eflx=eflx, mflx_out=mflx_out, eflx_out=eflx_out, htx_cond=htx_cond, mdq=mdq ) ! Ajust the dry mass in each layer back to the value of physics input state ! Adjust air specific enthalpy accordingly @@ -404,7 +404,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & subroutine dme_bflx(lchnk, ncol, & state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevp, tprc, dt, & - htx_cond, mdq, step, ntrnprd, ntsnprd, mflx, eflx, eflx_out, mflx_out) + step, ntrnprd, ntsnprd, mflx, eflx, mflx_out, eflx_out, htx_cond, mdq) !----------------------------------------------------------------------- ! @@ -532,6 +532,7 @@ subroutine dme_bflx(lchnk, ncol, & dcliq(:ncol)=0._r8 dcice(:ncol)=0._r8 dcwat(:ncol)=0._r8 + ! heat associated with cp change do k = 1, pver ! mass increments Dp'/Dp @@ -559,7 +560,6 @@ subroutine dme_bflx(lchnk, ncol, & dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state_pdel(:ncol,k)/gravit dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state_pdel(:ncol,k)/gravit dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state_pdel(:ncol,k)/gravit - end do is_invalid(:ncol)=0 @@ -599,7 +599,7 @@ subroutine dme_bflx(lchnk, ncol, & dcwatr(:ncol) = 0._r8 do k=1,pver mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change - if (conserve_physics .or. .not. l_nolocdcpttend) then + if (conserve_physics .or. .not. l_nolocdcpttend) then condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) else if (conserve_dycore) then condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice @@ -607,13 +607,13 @@ subroutine dme_bflx(lchnk, ncol, & +(zm(:ncol,k)*gravit+state_phis(:ncol))*mdq (:ncol,k) condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) endif - if (bndry_flx_surface) then + if (bndry_flx_surface) then condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntrnprd(:ncol,k) & -(cpice*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntsnprd(:ncol,k) condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state_phis(:ncol)+(cpliq*t00a+h00a)) else if (bndry_flx_local) then - if (conserve_dycore) then + if (conserve_dycore) then condepsf(:ncol,k) = -(cpliq*(state_t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state_phis(:ncol))*ntrnprd(:ncol,k) & -(cpice*(state_t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state_phis(:ncol))*ntsnprd(:ncol,k) condepsf(:ncol,k) = condepsf(:ncol,k) - & From 27e626ced319c1cd7debeed293ffe780be8cbd72 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 17:19:35 +0200 Subject: [PATCH 45/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index cc9c082075..eef484b2f8 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -404,7 +404,8 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & subroutine dme_bflx(lchnk, ncol, & state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevp, tprc, dt, & - step, ntrnprd, ntsnprd, mflx, eflx, mflx_out, eflx_out, htx_cond, mdq) + step, ntrnprd, ntsnprd, & + mflx, eflx, mflx_out, eflx_out, htx_cond, mdq) !----------------------------------------------------------------------- ! From 339aaab4d08847a652361224160e2aa7ffffc048 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 17:44:12 +0200 Subject: [PATCH 46/78] fixed compiler problem --- src/physics/cam/check_energy.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 44865abac5..50aea298ca 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -1167,7 +1167,8 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, ! Adjust the dry mass in each layer back to the value of physics input state ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. - call physics_dme_adjust_camnor(state, tend, qini, totliqini, toticeini, ztodt & + ! Author: Thomas Toniazzo (17.07.21) + call physics_dme_adjust_camnor(state, tend, qini, totliqini, toticeini, ztodt, & step='bc+ac', & ntrnprd=rnsrc_tot*ztodt, & ntsnprd=snsrc_tot*ztodt, & From c07771edd765b2dcf103ba71b80bb128abe5f2da Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 3 Oct 2025 22:06:25 +0200 Subject: [PATCH 47/78] fixed compiler problem --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index eef484b2f8..173e03f9bc 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -138,7 +138,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values real(r8) :: te(pcols,pver) ! conserved energy in layer real(r8) :: emce(pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm(pcols,pver) !(phi-phis)/g real(r8) :: cpm(pcols,pver) ! moist air heat capacity real(r8) :: ttsc(pcols,pver) ! moist air heat capacity integer :: vcoord @@ -186,8 +185,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ps_old (:ncol) = state_ps(:ncol) state_ps(:ncol) = state_pint(:ncol,1) - zm(:ncol,:) = state_zm(:ncol,:) ! TODO - remoe and use state_zm instead below - if (conserve_dycore) then vcoord=vc_dycore cpm(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) @@ -206,7 +203,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & state_t(:ncol,:), state_q(:ncol,:,:) ,state_pdel(:ncol,:), & pdel_new(:ncol,:), state_s(:ncol,:), & qini=qini(:ncol,:), liqini=liqini(:ncol,:), iceini=iceini(:ncol,:), & - phis=state_phis(:ncol) ,gph=zm(:ncol,:), & + phis=state_phis(:ncol) ,gph=state_state_zm(:ncol,:), & U=state_u(:ncol,:), V=state_v(:ncol,:), rairv=rairv(:ncol,:,lchnk), & vcoord=vcoord, refstate='liq', & flatent=latent(:ncol,:), temce=emce(:ncol,:)) @@ -359,7 +356,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & state_q(:ncol,:,:), state_pdel(:ncol,:), & pdel_new(:ncol,:), tp(:ncol,:), & flatent=latent(:ncol,:)*0._r8, & - phis=state_phis(:ncol), gph=zm(:ncol,:), & + phis=state_phis(:ncol), gph=state_zm(:ncol,:), & vcoord=vcoord, refstate='liq', & U=state_u(:ncol,:), V=state_v(:ncol,:)) From 3a04ba7545a0d8b91dca5d4c23960e34396e549c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 4 Oct 2025 13:23:27 +0200 Subject: [PATCH 48/78] add compute_enthalpy_flux logical for Faxa_hmat and Faxa_hlat --- src/cpl/nuopc/atm_import_export.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/cpl/nuopc/atm_import_export.F90 b/src/cpl/nuopc/atm_import_export.F90 index 3cc64835e4..8b701cf439 100644 --- a/src/cpl/nuopc/atm_import_export.F90 +++ b/src/cpl/nuopc/atm_import_export.F90 @@ -225,8 +225,10 @@ subroutine advertise_fields(gcomp, flds_scalar_name, compute_enthalpy_flux_in, r call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainl' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowc' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowl' ) - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hmat' ) ! enthalpy flux computed by cam - call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hlat' ) ! var.lat.ht.part + if (compute_enthalpy_flux) then + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hmat' ) ! enthalpy flux computed by cam + call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_hlat' ) ! var.lat.ht.part + end if call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_lwdn' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndr' ) call fldlist_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdr' ) From 8c0f3abd4b712afd80c48fbbfc72bc22710d588a Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 5 Oct 2025 19:27:11 +0200 Subject: [PATCH 49/78] added new if statements for compute_enthalpy_flux --- src/chemistry/oslo_aero | 2 +- src/control/camsrfexch.F90 | 32 ++++++++++----------- src/cpl/nuopc/atm_import_export.F90 | 3 ++ src/utils/cam_thermo.F90 | 43 +++++++++++++++++------------ 4 files changed, 45 insertions(+), 35 deletions(-) diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index 2218bd9bd5..442f15bdfe 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit 2218bd9bd545bc67f68be90f8704fb2d53b02624 +Subproject commit 442f15bdfe85f76d89a29fbeda826acdafed94ed diff --git a/src/control/camsrfexch.F90 b/src/control/camsrfexch.F90 index 512ab818a4..6380d0a79e 100644 --- a/src/control/camsrfexch.F90 +++ b/src/control/camsrfexch.F90 @@ -416,7 +416,7 @@ end subroutine hub2atm_deallocate !====================================================================== -subroutine cam_export(state,cam_in,cam_out,pbuf) +subroutine cam_export(state, cam_out, pbuf, cam_in) ! Transfer atmospheric fields into necessary surface data structures @@ -437,10 +437,10 @@ subroutine cam_export(state,cam_in,cam_out,pbuf) implicit none ! Input arguments - type(physics_state), intent(in) :: state - type (cam_in_t ), intent(in) :: cam_in - type (cam_out_t), intent(inout) :: cam_out - type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_state), intent(in) :: state + type (cam_out_t), intent(inout) :: cam_out + type(physics_buffer_desc), pointer :: pbuf(:) + type (cam_in_t ), optional, intent(in) :: cam_in ! Local variables @@ -513,29 +513,29 @@ subroutine cam_export(state,cam_in,cam_out,pbuf) cam_out%hsnow(:ncol) = -cam_out%hsnow(:ncol) + fice_tot(:ncol)*((h00o-h00a)+(cpliq-cpice)*(t00o-t00a)) ! into ocn; fice_tot is out of atm cam_out%hrain(:ncol) = -cam_out%hrain(:ncol) + fliq_tot(:ncol)* (h00o-h00a)! +0. ! into ocn; fliq_tot is out of atm - ! hevap is one time-step old, consistently with rest of enthalpy_prec_ac - enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP', errcode=i) - if (enthalpy_evop_idx==0) then - call endrun(sub//": pbuf for enthalpy evop not allocated") + if (present(cam_in)) then + ! hevap is one time-step old, consistently with rest of enthalpy_prec_ac + enthalpy_evop_idx = pbuf_get_index('ENTHALPY_EVOP', errcode=i) + if (enthalpy_evop_idx==0) then + call endrun(sub//": pbuf for enthalpy evop not allocated") + end if + call pbuf_get_field(pbuf, enthalpy_evop_idx, hevap_ocn) + cam_out%hevap(:ncol) = -hevap_ocn(:ncol) - cam_in%evap_ocn(:ncol)*((h00o-h00a)+(cpliq-cpwv )*(t00o-t00a)) ! into ocn; cflux is into atm end if - call pbuf_get_field(pbuf, enthalpy_evop_idx, hevap_ocn) - cam_out%hevap(:ncol) = -hevap_ocn(:ncol) - cam_in%evap_ocn(:ncol)*((h00o-h00a)+(cpliq-cpwv )*(t00o-t00a)) ! into ocn; cflux is into atm - - !call outfld("hsnow_liq_ref" , cam_out%hsnow, pcols ,lchnk )! debug - !call outfld("hrain_liq_ref" , cam_out%hrain, pcols ,lchnk )! debug - !call outfld("hevap_liq_ref" , cam_out%hevap, pcols ,lchnk )! debug cam_out%hmat(:ncol) = cam_out%hsnow(:ncol) + cam_out%hrain(:ncol) + cam_out%hevap(:ncol) ! this is into ocean ! variable latent heat component - ! N.B.: approximate due to difference between ts and tbot, also note lagged SST + ! N.B.: approximate due to difference between ts and tbot, also note lagged SST cam_out%hlat(:ncol) = cam_in%evap_ocn(:ncol)*(cpliq-cpwv )*(cam_in%sst(:ncol)-t00a) & -fice_tot (:ncol)*(cpliq-cpice)*(cam_in%sst(:ncol)-t00a) else + call get_prec_vars(ncol,pbuf,& precc_out=cam_out%precc,precl_out=cam_out%precl,& precsc_out=cam_out%precsc,precsl_out=cam_out%precsl) cam_out%hmat(:ncol) = 0._r8 cam_out%hlat(:ncol) = 0._r8 + end if srf_ozone_idx = pbuf_get_index('SRFOZONE', errcode=i) diff --git a/src/cpl/nuopc/atm_import_export.F90 b/src/cpl/nuopc/atm_import_export.F90 index 8b701cf439..011be4e9ef 100644 --- a/src/cpl/nuopc/atm_import_export.F90 +++ b/src/cpl/nuopc/atm_import_export.F90 @@ -135,6 +135,9 @@ subroutine advertise_fields(gcomp, flds_scalar_name, compute_enthalpy_flux_in, r ! Set module variable compute_enthalpy_flux = compute_enthalpy_flux_in + if (masterproc) then + write(iulog,'(2a,l)') trim(subname), 'compute_enthalpy_flux = ',compute_enthalpy_flux + end if call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/utils/cam_thermo.F90 b/src/utils/cam_thermo.F90 index 5a4fe9ee30..8923c5cfcb 100644 --- a/src/utils/cam_thermo.F90 +++ b/src/utils/cam_thermo.F90 @@ -1587,6 +1587,7 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & use physconst, only: rga, latvap, latice use physconst, only: cpliq, cpice, cpwv, tmelt use air_composition, only: t00a, h00a, h00a_vap, h00a_ice + use air_composition, only: compute_enthalpy_flux ! Dummy arguments ! tracer: tracer mixing ratio @@ -1806,28 +1807,34 @@ subroutine get_hydrostatic_energy_1hd(tracer, moist_mixing_ratio, pdel_in, & select case (TRIM(enthalpy_reference_state)) case('ice') te = te + (latsub * wv_vint) + (latice * liq_vint) - if (vcoord .ne. vc_moist_pressure) then - ! add t00 and h00 terms - te = te + wv_vint*(cpice-cpwv )*t00a - te = te + liq_vint*(cpice-cpliq)*t00a - te = te + wtot_vint*h00a_ice - endif + if (compute_enthalpy_flux) then + if (vcoord .ne. vc_moist_pressure) then + ! add t00 and h00 terms + te = te + wv_vint*(cpice-cpwv )*t00a + te = te + liq_vint*(cpice-cpliq)*t00a + te = te + wtot_vint*h00a_ice + endif + end if case('liq') te = te + (latvap * wv_vint) - (latice * ice_vint) - if (vcoord .ne. vc_moist_pressure) then - ! add t00 and h00 terms - te = te + wv_vint*(cpliq-cpwv )*t00a - te = te + ice_vint*(cpliq-cpice)*t00a - te = te + wtot_vint*h00a - endif + if (compute_enthalpy_flux) then + if (vcoord .ne. vc_moist_pressure) then + ! add t00 and h00 terms + te = te + wv_vint*(cpliq-cpwv )*t00a + te = te + ice_vint*(cpliq-cpice)*t00a + te = te + wtot_vint*h00a + endif + end if case('vap') te = te - (latvap * liq_vint) - (latsub * ice_vint) - if(vcoord .ne. vc_moist_pressure) then - ! add t00 and h00 terms - te = te + liq_vint*(cpwv -cpliq)*t00a - te = te + ice_vint*(cpwv -cpice)*t00a - te = te + wtot_vint*h00a_vap - endif + if (compute_enthalpy_flux) then + if (vcoord .ne. vc_moist_pressure) then + ! add t00 and h00 terms + te = te + liq_vint*(cpwv -cpliq)*t00a + te = te + ice_vint*(cpwv -cpice)*t00a + te = te + wtot_vint*h00a_vap + endif + end if case default write(iulog, *) subname, ' enthalpy reference state not ', & 'supported: ', TRIM(enthalpy_reference_state) From a43655c5ab5795c8b24b07e5297019793c5c52ca Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 5 Oct 2025 19:28:56 +0200 Subject: [PATCH 50/78] updated hash for oslo_aero --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 239552841a..2310218749 100644 --- a/.gitmodules +++ b/.gitmodules @@ -77,7 +77,7 @@ [submodule "oslo_aero"] path = src/chemistry/oslo_aero url = https://github.com/mvertens/OSLO_AERO - fxtag = 2218bd9 + fxtag = 442f15b fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/OSLO_AERO.git From a943cb6ef98f6cafcbf30966e6004dcfe6f2a00b Mon Sep 17 00:00:00 2001 From: mvertens Date: Sun, 5 Oct 2025 20:41:28 +0200 Subject: [PATCH 51/78] formatting changes --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 30 +++++++++---------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 173e03f9bc..8dda1a7527 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -470,23 +470,22 @@ subroutine dme_bflx(lchnk, ncol, & real(r8) :: dcice(pcols) ! total column ice change real(r8) :: dcwat(pcols) ! total column water change real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) - real(r8) :: tot_water (pcols,2) ! work array: total water (initial, present) - integer :: m_cnst + real(r8) :: tot_water(pcols,2) ! work array: total water (initial, present) + integer :: m_cnst ! index real(r8) :: ps_old(pcols) ! old surface pressure real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - real(r8) :: dvap (pcols,pver) ! wv mass adjustment - real(r8) :: dliq (pcols,pver) ! liq mass adjustment - real(r8) :: dice (pcols,pver) ! ice mass adjustment - real(r8) :: dprat (pcols) ! Dp'/Dp'' (=1 in lagrangean adj) - real(r8) :: mdqr (pcols,pver) ! residual mass change (work array) - real(r8) :: dcqm (pcols) ! fraction of total/absolute mass change - real(r8) :: te (pcols,pver) ! conserved energy in layer - real(r8) :: emce (pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm (pcols,pver) ! (phi-phis)/g + real(r8) :: dvap(pcols,pver) ! wv mass adjustment + real(r8) :: dliq(pcols,pver) ! liq mass adjustment + real(r8) :: dice(pcols,pver) ! ice mass adjustment + real(r8) :: mdqr(pcols,pver) ! residual mass change (work array) + real(r8) :: dcqm(pcols) ! fraction of total/absolute mass change + real(r8) :: te(pcols,pver) ! conserved energy in layer + real(r8) :: emce(pcols,pver) ! total enthalpy - conserved energy in layer + real(r8) :: zm(pcols,pver) ! (phi-phis)/g real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) - real(r8) :: condepss (pcols,pver) ! specific enthalpy of source reservoir for q changes - real(r8) :: condepsf (pcols,pver) ! specific enthalpy of final reservoir for q changes - real(r8) :: condcp (pcols,pver) ! species-increment-weighted cp + real(r8) :: condepss(pcols,pver) ! specific enthalpy of source reservoir for q changes + real(r8) :: condepsf(pcols,pver) ! specific enthalpy of final reservoir for q changes + real(r8) :: condcp(pcols,pver) ! species-increment-weighted cp real(r8) :: pint_old(pcols,pver+1) ! work array real(r8) :: dummy(pcols,pver) ! work array integer :: is_invalid(pcols) @@ -642,7 +641,8 @@ subroutine dme_bflx(lchnk, ncol, & endif if (bndry_flx_surface) then condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepsf(:ncol,k) = condcp(:ncol,k)*(tprc(:ncol)-t00a)+state_phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) + condepsf(:ncol,k) = condcp(:ncol,k)*& + (tprc(:ncol)-t00a)+state_phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) else if (bndry_flx_local) then condepsf(:ncol,k) = condepss(:ncol,k) From 85c5f698b5db18b38190e7374ba08c2a671b35e4 Mon Sep 17 00:00:00 2001 From: mvertens Date: Sun, 5 Oct 2025 20:42:33 +0200 Subject: [PATCH 52/78] updated oslo_aero --- src/chemistry/oslo_aero | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index 442f15bdfe..2218bd9bd5 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit 442f15bdfe85f76d89a29fbeda826acdafed94ed +Subproject commit 2218bd9bd545bc67f68be90f8704fb2d53b02624 From 105c879f37870d4924402a9dfcb6774c0e872733 Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 6 Oct 2025 13:01:02 +0200 Subject: [PATCH 53/78] updated oslo_aero --- src/chemistry/oslo_aero | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index 2218bd9bd5..442f15bdfe 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit 2218bd9bd545bc67f68be90f8704fb2d53b02624 +Subproject commit 442f15bdfe85f76d89a29fbeda826acdafed94ed From c35650fb88621183e6ba7b447fc3c7fcc26e9854 Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 6 Oct 2025 13:10:19 +0200 Subject: [PATCH 54/78] udpated oslo_aero --- src/chemistry/oslo_aero | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index 2218bd9bd5..442f15bdfe 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit 2218bd9bd545bc67f68be90f8704fb2d53b02624 +Subproject commit 442f15bdfe85f76d89a29fbeda826acdafed94ed From d39769519eb296b4d24a08ff5806a2baead0e631 Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 6 Oct 2025 13:12:46 +0200 Subject: [PATCH 55/78] updated .gitmodules --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 239552841a..2310218749 100644 --- a/.gitmodules +++ b/.gitmodules @@ -77,7 +77,7 @@ [submodule "oslo_aero"] path = src/chemistry/oslo_aero url = https://github.com/mvertens/OSLO_AERO - fxtag = 2218bd9 + fxtag = 442f15b fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/OSLO_AERO.git From eea0435127d63e075aee45a4048eed77b6524f9d Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 6 Oct 2025 13:20:21 +0200 Subject: [PATCH 56/78] moved physics_types.F90 out of physics/camnor_phys/physics --- src/physics/cam/physics_types.F90 | 271 ++- .../camnor_phys/physics/physics_types.F90 | 2166 ----------------- 2 files changed, 199 insertions(+), 2238 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/physics_types.F90 diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90 index 9fddfdd811..797e899361 100644 --- a/src/physics/cam/physics_types.F90 +++ b/src/physics/cam/physics_types.F90 @@ -7,6 +7,7 @@ module physics_types use ppgrid, only: pcols, pver use constituents, only: pcnst, qmin, cnst_name, cnst_get_ind use geopotential, only: geopotential_t + use physconst, only: cpliq, cpwv use physconst, only: zvir, gravit, cpair, rair use air_composition, only: cpairv, rairv use phys_grid, only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p @@ -14,6 +15,7 @@ module physics_types use cam_abortutils, only: endrun use phys_control, only: waccmx_is use shr_const_mod, only: shr_const_rwv + use spmd_utils, only: masterproc implicit none private ! Make default type private to the module @@ -32,6 +34,7 @@ module physics_types public physics_ptend_init public physics_state_set_grid public physics_dme_adjust ! adjust dry mass and energy for change in water + public physics_dme_adjust_camnor ! adjust dry mass and energy for change in water public physics_state_copy ! copy a physics_state object public physics_ptend_copy ! copy a physics_ptend object public physics_ptend_sum ! accumulate physics_ptend objects @@ -53,7 +56,14 @@ module physics_types public physics_cnst_limit ! apply limiters to constituents (waccmx) !------------------------------------------------------------------------------- integer, parameter, public :: phys_te_idx = 1 - integer ,parameter, public :: dyn_te_idx = 2 + integer, parameter, public :: dyn_te_idx = 2 + + integer, parameter, public :: num_hflx = 4 + + integer, parameter, public :: ihrain = 1 ! index for enthalpy flux associated with liquid precipitation + integer, parameter, public :: ihsnow = 2 ! index for enthalpy flux associated with frozen precipiation + integer, parameter, public :: ifrain = 3 ! index for flux of liquid precipitation + integer, parameter, public :: ifsnow = 4 ! index for flux of frozen precipitation type physics_state integer :: & @@ -101,7 +111,7 @@ module physics_types ! (dyn_te_idx) dycore total energy computed in physics te_ini, &! vertically integrated total (kinetic + static) energy of initial state te_cur ! vertically integrated total (kinetic + static) energy of current state - real(r8), dimension(:), allocatable :: & + real(r8), dimension(: ),allocatable :: & tw_ini, &! vertically integrated total water of initial state tw_cur ! vertically integrated total water of new state real(r8), dimension(:,:),allocatable :: & @@ -123,9 +133,11 @@ module physics_types integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols real(r8), dimension(:,:),allocatable :: dtdt, dudt, dvdt + real(r8), dimension(:,:),allocatable :: s_dme, qt_dme real(r8), dimension(:), allocatable :: flx_net real(r8), dimension(:), allocatable :: & te_tnd, &! cumulative boundary flux of total energy + te_sen, &! cumulative sensible heat flux tw_tnd ! cumulative boundary flux of total water end type physics_tend @@ -169,6 +181,7 @@ module physics_types end type physics_ptend + logical :: levels_are_moist=.true. ! TODO: put in namelist? !=============================================================================== contains @@ -204,14 +217,17 @@ subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcol end subroutine physics_type_alloc !=============================================================================== - subroutine physics_update(state, ptend, dt, tend) + subroutine physics_update(state, ptend, dt, tend ) !----------------------------------------------------------------------- ! Update the state and or tendency structure with the parameterization tendencies !----------------------------------------------------------------------- use scamMod, only: scm_crm_mode, single_column use phys_control, only: phys_getopts - use cam_thermo, only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X) - use air_composition, only: dry_air_species_num, thermodynamic_active_species_num, thermodynamic_active_species_idx + use cam_thermo, only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X) + use cam_thermo, only: get_conserved_energy, inv_conserved_energy + use air_composition, only: dry_air_species_num + use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx + use air_composition, only: compute_enthalpy_flux use qneg_module , only: qneg3 !------------------------------Arguments-------------------------------- @@ -233,6 +249,8 @@ subroutine physics_update(state, ptend, dt, tend) integer :: ixh, ixh2 ! constituent indices for H, H2 logical :: derive_new_geopotential ! derive new geopotential fields? + real(r8) :: te(state%psetcols,pver),t_tmp(state%psetcols,pver),pdel(state%psetcols,pver) + real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer real(r8),allocatable :: cpairv_loc(:,:) @@ -411,16 +429,53 @@ subroutine physics_update(state, ptend, dt, tend) !------------------------------------------------------------------------------------------------------------- ! Update temperature from dry static energy (moved from above for WACCM-X so updating after cpairv_loc update) !------------------------------------------------------------------------------------------------------------- - if(ptend%ls) then - do k = ptend%top_level, ptend%bot_level - state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) + + if(compute_enthalpy_flux) then + !use conserved energy + call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & + , cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & + , pdel(:ncol,:), te(:ncol,:)) + te(:ncol,ptend%top_level:ptend%bot_level)=te(:ncol,ptend%top_level:ptend%bot_level) & + +ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt + call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & + , te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & + , pdel(:ncol,:), t_tmp(:ncol,:)) if (present(tend)) & - tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) - end do + tend%dtdt(:ncol,ptend%top_level:ptend%bot_level)=tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & + (T_tmp(:ncol,ptend%top_level:ptend%bot_level) & + -state%t(:ncol,ptend%top_level:ptend%bot_level))/dt + state%T(:ncol,ptend%top_level:ptend%bot_level)=T_tmp(:ncol,ptend%top_level:ptend%bot_level) + end if + + ! if(compute_enthalpy_flux) then + ! !use conserved energy + ! call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & + ! cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & + ! pdel(:ncol,:), te(:ncol,:)) + ! te(:ncol,ptend%top_level:ptend%bot_level) = te(:ncol,ptend%top_level:ptend%bot_level) + & + ! ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt + ! call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & + ! te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & + ! pdel(:ncol,:), t_tmp(:ncol,:)) + ! if (present(tend)) then + ! tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) = tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & + ! (T_tmp(:ncol,ptend%top_level:ptend%bot_level) - & + ! state%t(:ncol,ptend%top_level:ptend%bot_level))/dt + ! end if + ! state%T(:ncol,ptend%top_level:ptend%bot_level) = T_tmp(:ncol,ptend%top_level:ptend%bot_level) + ! else + ! do k = ptend%top_level, ptend%bot_level + ! state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) + ! if (present(tend)) then + ! tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) + ! end if + ! end do + ! endif + end if - ! Derive new geopotential fields if heating or water species tendency not 0. + ! Derive new geopotential fields if heating or water tendency not 0. derive_new_geopotential = .false. if(ptend%ls) then ! Heating tendency not 0 @@ -552,9 +607,9 @@ subroutine physics_state_check(state, name) varname="state%te_ini", msg=msg) call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., & varname="state%te_cur", msg=msg) - call shr_assert_in_domain(state%tw_ini(:ncol), is_nan=.false., & + call shr_assert_in_domain(state%tw_ini(:ncol ), is_nan=.false., & varname="state%tw_ini", msg=msg) - call shr_assert_in_domain(state%tw_cur(:ncol), is_nan=.false., & + call shr_assert_in_domain(state%tw_cur(:ncol ), is_nan=.false., & varname="state%tw_cur", msg=msg) call shr_assert_in_domain(state%temp_ini(:ncol,:), is_nan=.false., & varname="state%temp_ini", msg=msg) @@ -630,9 +685,9 @@ subroutine physics_state_check(state, name) varname="state%te_ini", msg=msg) call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, & varname="state%te_cur", msg=msg) - call shr_assert_in_domain(state%tw_ini(:ncol), lt=posinf_r8, gt=neginf_r8, & + call shr_assert_in_domain(state%tw_ini(:ncol ), lt=posinf_r8, gt=neginf_r8, & varname="state%tw_ini", msg=msg) - call shr_assert_in_domain(state%tw_cur(:ncol), lt=posinf_r8, gt=neginf_r8, & + call shr_assert_in_domain(state%tw_cur(:ncol ), lt=posinf_r8, gt=neginf_r8, & varname="state%tw_cur", msg=msg) call shr_assert_in_domain(state%temp_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & varname="state%temp_ini", msg=msg) @@ -1319,9 +1374,57 @@ subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt) end subroutine physics_dme_adjust -!----------------------------------------------------------------------- +!=============================================================================== + + subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & + ent_tnd, pdel_rf) + + ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to + ! atmospheric moisture change: Author: Thomas Toniazzo (17.07.21) + + use dme_adjust_camnor, only: dme_adjust_camnor_run + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid + real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice + real(r8), intent(in) :: dt + character(len=*), intent(in) :: step ! which call in physpkg + real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer + real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation + real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation + real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy + real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy + real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) + real(r8), intent(out) :: ent_tnd(pcols) ! column-integrated enthalpy tendency + real(r8), intent(out) :: pdel_rf(pcols,pver) ! ratio old pdel / new pdel + !----------------------------------------------------------------------- + + if (state%psetcols /= pcols) then + call endrun('physics_dme_adjust_camnor: cannot pass in a state which has sub-columns') + end if + + call dme_adjust_camnor_run(state%lchnk, state%ncol, & + state%psetcols, state%pint, state%pmid, & + state%pdel, state%rpdel, state%pdeldry, state%lnpint, state%lnpmid, & + state%ps, state%phis, state%zm, state%zi, & + state%t, state%u, state%v, state%q, state%s, & + tend%dudt, tend%dvdt, tend%dtdt, & + qini, liqini, iceini, dt, & + step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & + ent_tnd, pdel_rf) + + end subroutine physics_dme_adjust_camnor !=============================================================================== + + subroutine physics_state_copy(state_in, state_out) use ppgrid, only: pver, pverp @@ -1357,10 +1460,10 @@ subroutine physics_state_copy(state_in, state_out) state_out%ps(i) = state_in%ps(i) state_out%phis(i) = state_in%phis(i) end do - state_out%te_ini(:ncol,:) = state_in%te_ini(:ncol,:) - state_out%te_cur(:ncol,:) = state_in%te_cur(:ncol,:) - state_out%tw_ini(:ncol) = state_in%tw_ini(:ncol) - state_out%tw_cur(:ncol) = state_in%tw_cur(:ncol) + state_out%te_ini (:ncol,:) = state_in%te_ini (:ncol,:) + state_out%te_cur (:ncol,:) = state_in%te_cur (:ncol,:) + state_out%tw_ini (:ncol ) = state_in%tw_ini (:ncol ) + state_out%tw_cur (:ncol ) = state_in%tw_cur (:ncol ) do k = 1, pver do i = 1, ncol @@ -1435,27 +1538,35 @@ subroutine physics_tend_init(tend) call endrun('physics_tend_init: tend must be allocated before it can be initialized') end if + tend%s_dme = 0._r8!+tht + tend%qt_dme = 0._r8!+tht tend%dtdt = 0._r8 tend%dudt = 0._r8 tend%dvdt = 0._r8 tend%flx_net = 0._r8 tend%te_tnd = 0._r8 + tend%te_sen = 0._r8 + !tend%te_lat = 0._r8 tend%tw_tnd = 0._r8 end subroutine physics_tend_init !=============================================================================== - +! this routine only considers wv as not massless (FV and EUL) subroutine set_state_pdry (state,pdeld_calc) use ppgrid, only: pver + use air_composition, only: dry_air_species_num,thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx implicit none type(physics_state), intent(inout) :: state logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default] ! .false. don't calculate pdeld + + real(r8) :: tot_water (pcols) ! total td'ly active water integer ncol - integer k + integer k, m, m_cnst logical do_pdeld_calc if ( present(pdeld_calc) ) then @@ -1471,10 +1582,16 @@ subroutine set_state_pdry (state,pdeld_calc) state%pintdry(:ncol,1) = state%pint(:ncol,1) if (do_pdeld_calc) then - do k = 1, pver - state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-state%q(:ncol,k,1)) - end do + do k = 1, pver + tot_water(:ncol) = 0.0_r8 + do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num + m = thermodynamic_active_species_idx(m_cnst) + tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) + end do + state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-tot_water(:ncol)) + end do endif + do k = 1, pver state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k) state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8 @@ -1489,72 +1606,56 @@ end subroutine set_state_pdry !=============================================================================== -subroutine set_wet_to_dry(state, convert_cnst_type) - - ! Convert mixing ratios from a wet to dry basis for constituents of type - ! convert_cnst_type. Constituents are given a type when they are added - ! to the constituent array by a call to cnst_add during the register - ! phase of initialization. There are two constituent types: 'wet' for - ! water species and 'dry' for non-water species. +subroutine set_wet_to_dry (state, convert_cnst_type) use constituents, only: pcnst, cnst_type type(physics_state), intent(inout) :: state - character(len=3), intent(in) :: convert_cnst_type + character(len=3), intent(in), optional :: convert_cnst_type + character(len=3) :: convert_type - ! local variables integer m, ncol - character(len=*), parameter :: sub = 'set_wet_to_dry' - !----------------------------------------------------------------------------- - ! check input - if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then - write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type - call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type) - end if +if (present(convert_cnst_type)) then + convert_type=convert_cnst_type +else + convert_type='dry' +endif ncol = state%ncol - do m = 1, pcnst - if (cnst_type(m) == convert_cnst_type) then + do m = 1,pcnst + if (cnst_type(m).eq.convert_type) then state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:) - end if + endif end do end subroutine set_wet_to_dry !=============================================================================== -subroutine set_dry_to_wet(state, convert_cnst_type) - - ! Convert mixing ratios from a dry to wet basis for constituents of type - ! convert_cnst_type. Constituents are given a type when they are added - ! to the constituent array by a call to cnst_add during the register - ! phase of initialization. There are two constituent types: 'wet' for - ! water species and 'dry' for non-water species. +subroutine set_dry_to_wet (state, convert_cnst_type) use constituents, only: pcnst, cnst_type type(physics_state), intent(inout) :: state - character(len=3), intent(in) :: convert_cnst_type + character(len=3), intent(in), optional :: convert_cnst_type + character(len=3) :: convert_type - ! local variables integer m, ncol - character(len=*), parameter :: sub = 'set_dry_to_wet' - !----------------------------------------------------------------------------- - ! check input - if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then - write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type - call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type) - end if +if (present(convert_cnst_type)) then + convert_type=convert_cnst_type +else + convert_type='dry' +endif ncol = state%ncol - do m = 1, pcnst - if (cnst_type(m) == convert_cnst_type) then + do m = 1,pcnst + if (cnst_type(m).eq.convert_type) then state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:) - end if + endif end do end subroutine set_dry_to_wet @@ -1675,10 +1776,10 @@ subroutine physics_state_alloc(state,lchnk,psetcols) allocate(state%te_cur(psetcols,2), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur') - allocate(state%tw_ini(psetcols), stat=ierr) + allocate(state%tw_ini(psetcols ), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini') - allocate(state%tw_cur(psetcols), stat=ierr) + allocate(state%tw_cur(psetcols ), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur') allocate(state%temp_ini(psetcols,pver), stat=ierr) @@ -1726,12 +1827,12 @@ subroutine physics_state_alloc(state,lchnk,psetcols) state%lnpintdry(:,:) = inf state%zi(:,:) = inf - state%te_ini(:,:) = inf - state%te_cur(:,:) = inf - state%tw_ini(:) = inf - state%tw_cur(:) = inf + state%te_ini (:,:) = inf + state%te_cur (:,:) = inf + state%tw_ini (: ) = inf + state%tw_cur (: ) = inf state%temp_ini(:,:) = inf - state%z_ini(:,:) = inf + state%z_ini (:,:) = inf end subroutine physics_state_alloc @@ -1871,7 +1972,12 @@ subroutine physics_tend_alloc(tend,psetcols) integer :: ierr = 0 tend%psetcols = psetcols - +!+tht + allocate(tend%s_dme(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%s_dme') + allocate(tend%qt_dme(psetcols,pver), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%qt_dme') +!-tht allocate(tend%dtdt(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt') @@ -1887,14 +1993,24 @@ subroutine physics_tend_alloc(tend,psetcols) allocate(tend%te_tnd(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_tnd') + allocate(tend%te_sen(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_sen') + + !allocate(tend%te_lat(psetcols), stat=ierr) + !if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_lat') + allocate(tend%tw_tnd(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd') + tend%s_dme (:,:)= inf !+tht + tend%qt_dme(:,:)= inf !+tht tend%dtdt(:,:) = inf tend%dudt(:,:) = inf tend%dvdt(:,:) = inf tend%flx_net(:) = inf tend%te_tnd(:) = inf + tend%te_sen(:) = inf + !tend%te_lat(:) = inf tend%tw_tnd(:) = inf end subroutine physics_tend_alloc @@ -1907,7 +2023,12 @@ subroutine physics_tend_dealloc(tend) type(physics_tend), intent(inout) :: tend integer :: ierr = 0 - +!+tht + deallocate(tend%s_dme, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%s_dme') + deallocate(tend%qt_dme, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%qt_dme') +!-tht deallocate(tend%dtdt, stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt') @@ -1923,6 +2044,12 @@ subroutine physics_tend_dealloc(tend) deallocate(tend%te_tnd, stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_tnd') + deallocate(tend%te_sen, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_sen') + + !deallocate(tend%te_lat, stat=ierr) + !if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_lat') + deallocate(tend%tw_tnd, stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%tw_tnd') end subroutine physics_tend_dealloc diff --git a/src/physics/camnor_phys/physics/physics_types.F90 b/src/physics/camnor_phys/physics/physics_types.F90 deleted file mode 100644 index 797e899361..0000000000 --- a/src/physics/camnor_phys/physics/physics_types.F90 +++ /dev/null @@ -1,2166 +0,0 @@ -!------------------------------------------------------------------------------- -!physics data types module -!------------------------------------------------------------------------------- -module physics_types - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver - use constituents, only: pcnst, qmin, cnst_name, cnst_get_ind - use geopotential, only: geopotential_t - use physconst, only: cpliq, cpwv - use physconst, only: zvir, gravit, cpair, rair - use air_composition, only: cpairv, rairv - use phys_grid, only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - use phys_control, only: waccmx_is - use shr_const_mod, only: shr_const_rwv - use spmd_utils, only: masterproc - - implicit none - private ! Make default type private to the module - -! Public types: - - public physics_state - public physics_tend - public physics_ptend - -! Public interfaces - - public physics_update - public physics_state_check ! Check state object for invalid data. - public physics_ptend_reset - public physics_ptend_init - public physics_state_set_grid - public physics_dme_adjust ! adjust dry mass and energy for change in water - public physics_dme_adjust_camnor ! adjust dry mass and energy for change in water - public physics_state_copy ! copy a physics_state object - public physics_ptend_copy ! copy a physics_ptend object - public physics_ptend_sum ! accumulate physics_ptend objects - public physics_ptend_scale ! Multiply physics_ptend objects by a constant factor. - public physics_tend_init ! initialize a physics_tend object - - public set_state_pdry ! calculate dry air masses in state variable - public set_wet_to_dry - public set_dry_to_wet - public physics_type_alloc - - public physics_state_alloc ! allocate individual components within state - public physics_state_dealloc ! deallocate individual components within state - public physics_tend_alloc ! allocate individual components within tend - public physics_tend_dealloc ! deallocate individual components within tend - public physics_ptend_alloc ! allocate individual components within tend - public physics_ptend_dealloc ! deallocate individual components within tend - - public physics_cnst_limit ! apply limiters to constituents (waccmx) -!------------------------------------------------------------------------------- - integer, parameter, public :: phys_te_idx = 1 - integer, parameter, public :: dyn_te_idx = 2 - - integer, parameter, public :: num_hflx = 4 - - integer, parameter, public :: ihrain = 1 ! index for enthalpy flux associated with liquid precipitation - integer, parameter, public :: ihsnow = 2 ! index for enthalpy flux associated with frozen precipiation - integer, parameter, public :: ifrain = 3 ! index for flux of liquid precipitation - integer, parameter, public :: ifsnow = 4 ! index for flux of frozen precipitation - - type physics_state - integer :: & - lchnk, &! chunk index - ngrdcol, &! -- Grid -- number of active columns (on the grid) - psetcols=0, &! -- -- max number of columns set - if subcols = pcols*psubcols, else = pcols - ncol=0 ! -- -- sum of nsubcol for all ngrdcols - number of active columns - real(r8), dimension(:), allocatable :: & - lat, &! latitude (radians) - lon, &! longitude (radians) - ps, &! surface pressure - psdry, &! dry surface pressure - phis, &! surface geopotential - ulat, &! unique latitudes (radians) - ulon ! unique longitudes (radians) - real(r8), dimension(:,:),allocatable :: & - t, &! temperature (K) - u, &! zonal wind (m/s) - v, &! meridional wind (m/s) - s, &! dry static energy - omega, &! vertical pressure velocity (Pa/s) - pmid, &! midpoint pressure (Pa) - pmiddry, &! midpoint pressure dry (Pa) - pdel, &! layer thickness (Pa) - pdeldry, &! layer thickness dry (Pa) - rpdel, &! reciprocal of layer thickness (Pa) - rpdeldry,&! recipricol layer thickness dry (Pa) - lnpmid, &! ln(pmid) - lnpmiddry,&! log midpoint pressure dry (Pa) - exner, &! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp) - zm ! geopotential height above surface at midpoints (m) - - real(r8), dimension(:,:,:),allocatable :: & - q ! constituent mixing ratio (kg/kg moist or dry air depending on type) - - real(r8), dimension(:,:),allocatable :: & - pint, &! interface pressure (Pa) - pintdry, &! interface pressure dry (Pa) - lnpint, &! ln(pint) - lnpintdry,&! log interface pressure dry (Pa) - zi ! geopotential height above surface at interfaces (m) - - real(r8), dimension(:,:),allocatable :: & - ! Second dimension is (phys_te_idx) CAM physics total energy and - ! (dyn_te_idx) dycore total energy computed in physics - te_ini, &! vertically integrated total (kinetic + static) energy of initial state - te_cur ! vertically integrated total (kinetic + static) energy of current state - real(r8), dimension(: ),allocatable :: & - tw_ini, &! vertically integrated total water of initial state - tw_cur ! vertically integrated total water of new state - real(r8), dimension(:,:),allocatable :: & - temp_ini, &! Temperature of initial state (used for energy computations) - z_ini ! Height of initial state (used for energy computations) - integer :: count ! count of values with significant energy or water imbalances - integer, dimension(:),allocatable :: & - latmapback, &! map from column to unique lat for that column - lonmapback, &! map from column to unique lon for that column - cid ! unique column id - integer :: ulatcnt, &! number of unique lats in chunk - uloncnt ! number of unique lons in chunk - - end type physics_state - -!------------------------------------------------------------------------------- - type physics_tend - - integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols - - real(r8), dimension(:,:),allocatable :: dtdt, dudt, dvdt - real(r8), dimension(:,:),allocatable :: s_dme, qt_dme - real(r8), dimension(:), allocatable :: flx_net - real(r8), dimension(:), allocatable :: & - te_tnd, &! cumulative boundary flux of total energy - te_sen, &! cumulative sensible heat flux - tw_tnd ! cumulative boundary flux of total water - end type physics_tend - -!------------------------------------------------------------------------------- -! This is for tendencies returned from individual parameterizations - type physics_ptend - - integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols - - character*24 :: name ! name of parameterization which produced tendencies. - - logical :: & - ls = .false., &! true if dsdt is returned - lu = .false., &! true if dudt is returned - lv = .false. ! true if dvdt is returned - - logical,dimension(pcnst) :: lq = .false. ! true if dqdt() is returned - - integer :: & - top_level, &! top level index for which nonzero tendencies have been set - bot_level ! bottom level index for which nonzero tendencies have been set - - real(r8), dimension(:,:),allocatable :: & - s, &! heating rate (J/kg/s) - u, &! u momentum tendency (m/s/s) - v ! v momentum tendency (m/s/s) - real(r8), dimension(:,:,:),allocatable :: & - q ! consituent tendencies (kg/kg/s) - -! boundary fluxes - real(r8), dimension(:),allocatable ::& - hflux_srf, &! net heat flux at surface (W/m2) - hflux_top, &! net heat flux at top of model (W/m2) - taux_srf, &! net zonal stress at surface (Pa) - taux_top, &! net zonal stress at top of model (Pa) - tauy_srf, &! net meridional stress at surface (Pa) - tauy_top ! net meridional stress at top of model (Pa) - real(r8), dimension(:,:),allocatable ::& - cflx_srf, &! constituent flux at surface (kg/m2/s) - cflx_top ! constituent flux top of model (kg/m2/s) - - end type physics_ptend - - logical :: levels_are_moist=.true. ! TODO: put in namelist? - -!=============================================================================== -contains -!=============================================================================== - subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcols) - implicit none - type(physics_state), pointer :: phys_state(:) - type(physics_tend), pointer :: phys_tend(:) - integer, intent(in) :: begchunk, endchunk - integer, intent(in) :: psetcols - - integer :: ierr=0, lchnk - - allocate(phys_state(begchunk:endchunk), stat=ierr) - if( ierr /= 0 ) then - write(iulog,*) 'physics_types: phys_state allocation error = ',ierr - call endrun('physics_types: failed to allocate physics_state array') - end if - - do lchnk=begchunk,endchunk - call physics_state_alloc(phys_state(lchnk),lchnk,pcols) - end do - - allocate(phys_tend(begchunk:endchunk), stat=ierr) - if( ierr /= 0 ) then - write(iulog,*) 'physics_types: phys_tend allocation error = ',ierr - call endrun('physics_types: failed to allocate physics_tend array') - end if - - do lchnk=begchunk,endchunk - call physics_tend_alloc(phys_tend(lchnk),phys_state(lchnk)%psetcols) - end do - - end subroutine physics_type_alloc -!=============================================================================== - subroutine physics_update(state, ptend, dt, tend ) -!----------------------------------------------------------------------- -! Update the state and or tendency structure with the parameterization tendencies -!----------------------------------------------------------------------- - use scamMod, only: scm_crm_mode, single_column - use phys_control, only: phys_getopts - use cam_thermo, only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X) - use cam_thermo, only: get_conserved_energy, inv_conserved_energy - use air_composition, only: dry_air_species_num - use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx - use air_composition, only: compute_enthalpy_flux - use qneg_module , only: qneg3 - -!------------------------------Arguments-------------------------------- - type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies - - type(physics_state), intent(inout) :: state ! Physics state variables - - real(r8), intent(in) :: dt ! time step - - type(physics_tend ), intent(inout), optional :: tend ! Physics tendencies over timestep - ! tend is usually only needed by calls from physpkg. -! -!---------------------------Local storage------------------------------- - integer :: k,m ! column,level,constituent indices - integer :: ixcldice, ixcldliq ! indices for CLDICE and CLDLIQ - integer :: ixnumice, ixnumliq - integer :: ixnumsnow, ixnumrain - integer :: ncol ! number of columns - integer :: ixh, ixh2 ! constituent indices for H, H2 - logical :: derive_new_geopotential ! derive new geopotential fields? - - real(r8) :: te(state%psetcols,pver),t_tmp(state%psetcols,pver),pdel(state%psetcols,pver) - - real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer - - real(r8),allocatable :: cpairv_loc(:,:) - real(r8),allocatable :: rairv_loc(:,:) - - ! PERGRO limits cldliq/ice for macro/microphysics: - character(len=24), parameter :: pergro_cldlim_names(4) = & - (/ "stratiform", "cldwat ", "micro_mg ", "macro_park" /) - - ! cldliq/ice limits that are always on. - character(len=24), parameter :: cldlim_names(2) = & - (/ "convect_deep", "zm_conv_tend" /) - - ! Whether to do validation of state on each call. - logical :: state_debug_checks - - !----------------------------------------------------------------------- - - ! The column radiation model does not update the state - if(single_column.and.scm_crm_mode) return - - - !----------------------------------------------------------------------- - ! If no fields are set, then return - if (.not. (any(ptend%lq(:)) .or. ptend%ls .or. ptend%lu .or. ptend%lv)) then - ptend%name = "none" - ptend%psetcols = 0 - return - end if - - !----------------------------------------------------------------------- - ! Check that the state/tend/ptend are all dimensioned with the same number of columns - if (state%psetcols /= ptend%psetcols) then - call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) & - //': state and ptend must have the same number of psetcols.') - end if - - if (present(tend)) then - if (state%psetcols /= tend%psetcols) then - call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) & - //': state and tend must have the same number of psetcols.') - end if - end if - - - !----------------------------------------------------------------------- - call phys_getopts(state_debug_checks_out=state_debug_checks) - - ncol = state%ncol - - ! Update u,v fields - if(ptend%lu) then - do k = ptend%top_level, ptend%bot_level - state%u (:ncol,k) = state%u (:ncol,k) + ptend%u(:ncol,k) * dt - if (present(tend)) & - tend%dudt(:ncol,k) = tend%dudt(:ncol,k) + ptend%u(:ncol,k) - end do - end if - - if(ptend%lv) then - do k = ptend%top_level, ptend%bot_level - state%v (:ncol,k) = state%v (:ncol,k) + ptend%v(:ncol,k) * dt - if (present(tend)) & - tend%dvdt(:ncol,k) = tend%dvdt(:ncol,k) + ptend%v(:ncol,k) - end do - end if - - ! Update constituents, all schemes use time split q: no tendency kept - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - ! Check for number concentration of cloud liquid and cloud ice (if not present - ! the indices will be set to -1) - call cnst_get_ind('NUMICE', ixnumice, abort=.false.) - call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) - call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) - call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) - - do m = 1, pcnst - if(ptend%lq(m)) then - do k = ptend%top_level, ptend%bot_level - state%q(:ncol,k,m) = state%q(:ncol,k,m) + ptend%q(:ncol,k,m) * dt - end do - - ! now test for mixing ratios which are too small - ! don't call qneg3 for number concentration variables - if (m /= ixnumice .and. m /= ixnumliq .and. & - m /= ixnumrain .and. m /= ixnumsnow ) then - call qneg3(trim(ptend%name), state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m)) - else - do k = ptend%top_level, ptend%bot_level - ! checks for number concentration - state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m)) - state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m)) - end do - end if - - end if - - end do - - !------------------------------------------------------------------------ - ! This is a temporary fix for the large H, H2 in WACCM-X - ! Well, it was supposed to be temporary, but it has been here - ! for a while now. - !------------------------------------------------------------------------ - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call cnst_get_ind('H', ixh) - do k = ptend%top_level, ptend%bot_level - state%q(:ncol,k,ixh) = min(state%q(:ncol,k,ixh), 0.01_r8) - end do - - call cnst_get_ind('H2', ixh2) - do k = ptend%top_level, ptend%bot_level - state%q(:ncol,k,ixh2) = min(state%q(:ncol,k,ixh2), 6.e-5_r8) - end do - endif - - ! Special tests for cloud liquid and ice: - ! Enforce a minimum non-zero value. - if (ixcldliq > 1) then - if(ptend%lq(ixcldliq)) then -#ifdef PERGRO - if ( any(ptend%name == pergro_cldlim_names) ) & - call state_cnst_min_nz(1.e-12_r8, ixcldliq, ixnumliq) -#endif - if ( any(ptend%name == cldlim_names) ) & - call state_cnst_min_nz(1.e-36_r8, ixcldliq, ixnumliq) - end if - end if - - if (ixcldice > 1) then - if(ptend%lq(ixcldice)) then -#ifdef PERGRO - if ( any(ptend%name == pergro_cldlim_names) ) & - call state_cnst_min_nz(1.e-12_r8, ixcldice, ixnumice) -#endif - if ( any(ptend%name == cldlim_names) ) & - call state_cnst_min_nz(1.e-36_r8, ixcldice, ixnumice) - end if - end if - - !------------------------------------------------------------------------ - ! Get indices for molecular weights and call WACCM-X cam_thermo_update - !------------------------------------------------------------------------ - if (dry_air_species_num>0) then - call cam_thermo_dry_air_update(state%q, state%t, state%lchnk, state%ncol) - endif - - !----------------------------------------------------------------------- - ! cpairv_loc and rairv_loc need to be allocated to a size which matches state and ptend - ! If psetcols == pcols, the cpairv is the correct size and just copy - ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair - allocate(cpairv_loc(state%psetcols,pver)) - if (state%psetcols == pcols) then - cpairv_loc(:,:) = cpairv(:,:,state%lchnk) - else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then - cpairv_loc(:,:) = cpair - else - call endrun('physics_update: cpairv is not allowed to vary when subcolumns are turned on') - end if - allocate(rairv_loc(state%psetcols,pver)) - if (state%psetcols == pcols) then - rairv_loc(:,:) = rairv(:,:,state%lchnk) - else if (state%psetcols > pcols .and. all(rairv(:,:,:) == rair)) then - rairv_loc(:,:) = rair - else - call endrun('physics_update: rairv_loc is not allowed to vary when subcolumns are turned on') - end if - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - zvirv(:,:) = shr_const_rwv / rairv_loc(:,:) - 1._r8 - else - zvirv(:,:) = zvir - endif - - !------------------------------------------------------------------------------------------------------------- - ! Update temperature from dry static energy (moved from above for WACCM-X so updating after cpairv_loc update) - !------------------------------------------------------------------------------------------------------------- - if(ptend%ls) then - - if(compute_enthalpy_flux) then - !use conserved energy - call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & - , cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & - , pdel(:ncol,:), te(:ncol,:)) - te(:ncol,ptend%top_level:ptend%bot_level)=te(:ncol,ptend%top_level:ptend%bot_level) & - +ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt - call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & - , te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & - , pdel(:ncol,:), t_tmp(:ncol,:)) - if (present(tend)) & - tend%dtdt(:ncol,ptend%top_level:ptend%bot_level)=tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & - (T_tmp(:ncol,ptend%top_level:ptend%bot_level) & - -state%t(:ncol,ptend%top_level:ptend%bot_level))/dt - state%T(:ncol,ptend%top_level:ptend%bot_level)=T_tmp(:ncol,ptend%top_level:ptend%bot_level) - end if - - ! if(compute_enthalpy_flux) then - ! !use conserved energy - ! call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & - ! cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & - ! pdel(:ncol,:), te(:ncol,:)) - ! te(:ncol,ptend%top_level:ptend%bot_level) = te(:ncol,ptend%top_level:ptend%bot_level) + & - ! ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt - ! call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & - ! te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & - ! pdel(:ncol,:), t_tmp(:ncol,:)) - ! if (present(tend)) then - ! tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) = tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & - ! (T_tmp(:ncol,ptend%top_level:ptend%bot_level) - & - ! state%t(:ncol,ptend%top_level:ptend%bot_level))/dt - ! end if - ! state%T(:ncol,ptend%top_level:ptend%bot_level) = T_tmp(:ncol,ptend%top_level:ptend%bot_level) - ! else - ! do k = ptend%top_level, ptend%bot_level - ! state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) - ! if (present(tend)) then - ! tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) - ! end if - ! end do - ! endif - - end if - - ! Derive new geopotential fields if heating or water tendency not 0. - derive_new_geopotential = .false. - if(ptend%ls) then - ! Heating tendency not 0 - derive_new_geopotential = .true. - else - ! Check all water species and if there are nonzero tendencies - const_water_loop: do m = dry_air_species_num + 1, thermodynamic_active_species_num - if(ptend%lq(thermodynamic_active_species_idx(m))) then - ! does water species have tendency? - derive_new_geopotential = .true. - exit const_water_loop - endif - enddo const_water_loop - endif - - if (derive_new_geopotential) then - call geopotential_t ( & - state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & - state%t , state%q(:,:,:), rairv_loc(:,:), gravit , zvirv , & - state%zi , state%zm , ncol ) - ! update dry static energy for use in next process - do k = ptend%top_level, ptend%bot_level - state%s(:ncol,k) = state%t(:ncol,k)*cpairv_loc(:ncol,k) & - + gravit*state%zm(:ncol,k) + state%phis(:ncol) - end do - end if - - if (state_debug_checks) call physics_state_check(state, ptend%name) - - deallocate(cpairv_loc, rairv_loc) - - ! Deallocate ptend - call physics_ptend_dealloc(ptend) - - ptend%name = "none" - ptend%lq(:) = .false. - ptend%ls = .false. - ptend%lu = .false. - ptend%lv = .false. - ptend%psetcols = 0 - - contains - - subroutine state_cnst_min_nz(lim, qix, numix) - ! Small utility function for setting minimum nonzero - ! constituent concentrations. - - ! Lower limit and constituent index - real(r8), intent(in) :: lim - integer, intent(in) :: qix - ! Number concentration that goes with qix. - ! Ignored if <= 0 (and therefore constituent is not present). - integer, intent(in) :: numix - - if (numix > 0) then - ! Where q is too small, zero mass and number - ! concentration. - where (state%q(:ncol,:,qix) < lim) - state%q(:ncol,:,qix) = 0._r8 - state%q(:ncol,:,numix) = 0._r8 - end where - else - ! If no number index, just do mass. - where (state%q(:ncol,:,qix) < lim) - state%q(:ncol,:,qix) = 0._r8 - end where - end if - - end subroutine state_cnst_min_nz - - - end subroutine physics_update - -!=============================================================================== - - subroutine physics_state_check(state, name) -!----------------------------------------------------------------------- -! Check a physics_state object for invalid data (e.g NaNs, negative -! temperatures). -!----------------------------------------------------------------------- - use shr_infnan_mod, only: assignment(=), & - shr_infnan_posinf, shr_infnan_neginf - use shr_assert_mod, only: shr_assert_in_domain - use constituents, only: pcnst - -!------------------------------Arguments-------------------------------- - ! State to check. - type(physics_state), intent(in) :: state - ! Name of the package responsible for this state. - character(len=*), intent(in), optional :: name - -!---------------------------Local storage------------------------------- - ! Shortened name for ncol. - integer :: ncol - ! Double precision positive/negative infinity. - real(r8) :: posinf_r8, neginf_r8 - ! Canned message. - character(len=64) :: msg - ! Constituent index - integer :: m - -!----------------------------------------------------------------------- - - ncol = state%ncol - - posinf_r8 = shr_infnan_posinf - neginf_r8 = shr_infnan_neginf - - ! It may be reasonable to check some of the integer components of the - ! state as well, but this is not yet implemented. - - ! Check for NaN first to avoid any IEEE exceptions. - - if (present(name)) then - msg = "NaN produced in physics_state by package "// & - trim(name)//"." - else - msg = "NaN found in physics_state." - end if - - ! 1-D variables - call shr_assert_in_domain(state%ps(:ncol), is_nan=.false., & - varname="state%ps", msg=msg) - call shr_assert_in_domain(state%psdry(:ncol), is_nan=.false., & - varname="state%psdry", msg=msg) - call shr_assert_in_domain(state%phis(:ncol), is_nan=.false., & - varname="state%phis", msg=msg) - call shr_assert_in_domain(state%te_ini(:ncol,:), is_nan=.false., & - varname="state%te_ini", msg=msg) - call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., & - varname="state%te_cur", msg=msg) - call shr_assert_in_domain(state%tw_ini(:ncol ), is_nan=.false., & - varname="state%tw_ini", msg=msg) - call shr_assert_in_domain(state%tw_cur(:ncol ), is_nan=.false., & - varname="state%tw_cur", msg=msg) - call shr_assert_in_domain(state%temp_ini(:ncol,:), is_nan=.false., & - varname="state%temp_ini", msg=msg) - call shr_assert_in_domain(state%z_ini(:ncol,:), is_nan=.false., & - varname="state%z_ini", msg=msg) - - ! 2-D variables (at midpoints) - call shr_assert_in_domain(state%t(:ncol,:), is_nan=.false., & - varname="state%t", msg=msg) - call shr_assert_in_domain(state%u(:ncol,:), is_nan=.false., & - varname="state%u", msg=msg) - call shr_assert_in_domain(state%v(:ncol,:), is_nan=.false., & - varname="state%v", msg=msg) - call shr_assert_in_domain(state%s(:ncol,:), is_nan=.false., & - varname="state%s", msg=msg) - call shr_assert_in_domain(state%omega(:ncol,:), is_nan=.false., & - varname="state%omega", msg=msg) - call shr_assert_in_domain(state%pmid(:ncol,:), is_nan=.false., & - varname="state%pmid", msg=msg) - call shr_assert_in_domain(state%pmiddry(:ncol,:), is_nan=.false., & - varname="state%pmiddry", msg=msg) - call shr_assert_in_domain(state%pdel(:ncol,:), is_nan=.false., & - varname="state%pdel", msg=msg) - call shr_assert_in_domain(state%pdeldry(:ncol,:), is_nan=.false., & - varname="state%pdeldry", msg=msg) - call shr_assert_in_domain(state%rpdel(:ncol,:), is_nan=.false., & - varname="state%rpdel", msg=msg) - call shr_assert_in_domain(state%rpdeldry(:ncol,:), is_nan=.false., & - varname="state%rpdeldry", msg=msg) - call shr_assert_in_domain(state%lnpmid(:ncol,:), is_nan=.false., & - varname="state%lnpmid", msg=msg) - call shr_assert_in_domain(state%lnpmiddry(:ncol,:), is_nan=.false., & - varname="state%lnpmiddry", msg=msg) - call shr_assert_in_domain(state%exner(:ncol,:), is_nan=.false., & - varname="state%exner", msg=msg) - call shr_assert_in_domain(state%zm(:ncol,:), is_nan=.false., & - varname="state%zm", msg=msg) - - ! 2-D variables (at interfaces) - call shr_assert_in_domain(state%pint(:ncol,:), is_nan=.false., & - varname="state%pint", msg=msg) - call shr_assert_in_domain(state%pintdry(:ncol,:), is_nan=.false., & - varname="state%pintdry", msg=msg) - call shr_assert_in_domain(state%lnpint(:ncol,:), is_nan=.false., & - varname="state%lnpint", msg=msg) - call shr_assert_in_domain(state%lnpintdry(:ncol,:), is_nan=.false., & - varname="state%lnpintdry", msg=msg) - call shr_assert_in_domain(state%zi(:ncol,:), is_nan=.false., & - varname="state%zi", msg=msg) - - ! 3-D variables - call shr_assert_in_domain(state%q(:ncol,:,:), is_nan=.false., & - varname="state%q", msg=msg) - - ! Now run other checks (i.e. values are finite and within a range that - ! is physically meaningful). - - if (present(name)) then - msg = "Invalid value produced in physics_state by package "// & - trim(name)//"." - else - msg = "Invalid value found in physics_state." - end if - - ! 1-D variables - call shr_assert_in_domain(state%ps(:ncol), lt=posinf_r8, gt=0._r8, & - varname="state%ps", msg=msg) - call shr_assert_in_domain(state%psdry(:ncol), lt=posinf_r8, gt=0._r8, & - varname="state%psdry", msg=msg) - call shr_assert_in_domain(state%phis(:ncol), lt=posinf_r8, gt=neginf_r8, & - varname="state%phis", msg=msg) - call shr_assert_in_domain(state%te_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%te_ini", msg=msg) - call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%te_cur", msg=msg) - call shr_assert_in_domain(state%tw_ini(:ncol ), lt=posinf_r8, gt=neginf_r8, & - varname="state%tw_ini", msg=msg) - call shr_assert_in_domain(state%tw_cur(:ncol ), lt=posinf_r8, gt=neginf_r8, & - varname="state%tw_cur", msg=msg) - call shr_assert_in_domain(state%temp_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%temp_ini", msg=msg) - call shr_assert_in_domain(state%z_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%z_ini", msg=msg) - - ! 2-D variables (at midpoints) - call shr_assert_in_domain(state%t(:ncol,:), lt=posinf_r8, gt=0._r8, & - varname="state%t", msg=msg) - call shr_assert_in_domain(state%u(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%u", msg=msg) - call shr_assert_in_domain(state%v(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%v", msg=msg) - call shr_assert_in_domain(state%s(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%s", msg=msg) - call shr_assert_in_domain(state%omega(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%omega", msg=msg) - call shr_assert_in_domain(state%pmid(:ncol,:), lt=posinf_r8, gt=0._r8, & - varname="state%pmid", msg=msg) - call shr_assert_in_domain(state%pmiddry(:ncol,:), lt=posinf_r8, gt=0._r8, & - varname="state%pmiddry", msg=msg) - call shr_assert_in_domain(state%pdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%pdel", msg=msg) - call shr_assert_in_domain(state%pdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%pdeldry", msg=msg) - call shr_assert_in_domain(state%rpdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%rpdel", msg=msg) - call shr_assert_in_domain(state%rpdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%rpdeldry", msg=msg) - call shr_assert_in_domain(state%lnpmid(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%lnpmid", msg=msg) - call shr_assert_in_domain(state%lnpmiddry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%lnpmiddry", msg=msg) - call shr_assert_in_domain(state%exner(:ncol,:), lt=posinf_r8, gt=0._r8, & - varname="state%exner", msg=msg) - call shr_assert_in_domain(state%zm(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%zm", msg=msg) - - ! 2-D variables (at interfaces) - call shr_assert_in_domain(state%pint(:ncol,:), lt=posinf_r8, gt=0._r8, & - varname="state%pint", msg=msg) - call shr_assert_in_domain(state%pintdry(:ncol,:), lt=posinf_r8, gt=0._r8, & - varname="state%pintdry", msg=msg) - call shr_assert_in_domain(state%lnpint(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%lnpint", msg=msg) - call shr_assert_in_domain(state%lnpintdry(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%lnpintdry", msg=msg) - call shr_assert_in_domain(state%zi(:ncol,:), lt=posinf_r8, gt=neginf_r8, & - varname="state%zi", msg=msg) - - ! 3-D variables - do m = 1,pcnst - call shr_assert_in_domain(state%q(:ncol,:,m), lt=posinf_r8, gt=neginf_r8, & - varname="state%q ("//trim(cnst_name(m))//")", msg=msg) - end do - - end subroutine physics_state_check - -!=============================================================================== - - subroutine physics_ptend_sum(ptend, ptend_sum, ncol) -!----------------------------------------------------------------------- -! Add ptend fields to ptend_sum for ptend logical flags = .true. -! Where ptend logical flags = .false, don't change ptend_sum -!----------------------------------------------------------------------- - -!------------------------------Arguments-------------------------------- - type(physics_ptend), intent(in) :: ptend ! New parameterization tendencies - type(physics_ptend), intent(inout) :: ptend_sum ! Sum of incoming ptend_sum and ptend - integer, intent(in) :: ncol ! number of columns - -!---------------------------Local storage------------------------------- - integer :: i,k,m ! column,level,constituent indices - integer :: psetcols ! maximum number of columns - integer :: ierr = 0 - -!----------------------------------------------------------------------- - if (ptend%psetcols /= ptend_sum%psetcols) then - call endrun('physics_ptend_sum error: ptend and ptend_sum must have the same value for psetcols') - end if - - if (ncol > ptend_sum%psetcols) then - call endrun('physics_ptend_sum error: ncol must be less than or equal to psetcols') - end if - - psetcols = ptend_sum%psetcols - - ptend_sum%top_level = ptend%top_level - ptend_sum%bot_level = ptend%bot_level - -! Update u,v fields - if(ptend%lu) then - if (.not. allocated(ptend_sum%u)) then - allocate(ptend_sum%u(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%u') - ptend_sum%u=0.0_r8 - - allocate(ptend_sum%taux_srf(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_srf') - ptend_sum%taux_srf=0.0_r8 - - allocate(ptend_sum%taux_top(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_top') - ptend_sum%taux_top=0.0_r8 - end if - ptend_sum%lu = .true. - - do k = ptend%top_level, ptend%bot_level - do i = 1, ncol - ptend_sum%u(i,k) = ptend_sum%u(i,k) + ptend%u(i,k) - end do - end do - do i = 1, ncol - ptend_sum%taux_srf(i) = ptend_sum%taux_srf(i) + ptend%taux_srf(i) - ptend_sum%taux_top(i) = ptend_sum%taux_top(i) + ptend%taux_top(i) - end do - end if - - if(ptend%lv) then - if (.not. allocated(ptend_sum%v)) then - allocate(ptend_sum%v(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%v') - ptend_sum%v=0.0_r8 - - allocate(ptend_sum%tauy_srf(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_srf') - ptend_sum%tauy_srf=0.0_r8 - - allocate(ptend_sum%tauy_top(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_top') - ptend_sum%tauy_top=0.0_r8 - end if - ptend_sum%lv = .true. - - do k = ptend%top_level, ptend%bot_level - do i = 1, ncol - ptend_sum%v(i,k) = ptend_sum%v(i,k) + ptend%v(i,k) - end do - end do - do i = 1, ncol - ptend_sum%tauy_srf(i) = ptend_sum%tauy_srf(i) + ptend%tauy_srf(i) - ptend_sum%tauy_top(i) = ptend_sum%tauy_top(i) + ptend%tauy_top(i) - end do - end if - - - if(ptend%ls) then - if (.not. allocated(ptend_sum%s)) then - allocate(ptend_sum%s(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%s') - ptend_sum%s=0.0_r8 - - allocate(ptend_sum%hflux_srf(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_srf') - ptend_sum%hflux_srf=0.0_r8 - - allocate(ptend_sum%hflux_top(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_top') - ptend_sum%hflux_top=0.0_r8 - end if - ptend_sum%ls = .true. - - do k = ptend%top_level, ptend%bot_level - do i = 1, ncol - ptend_sum%s(i,k) = ptend_sum%s(i,k) + ptend%s(i,k) - end do - end do - do i = 1, ncol - ptend_sum%hflux_srf(i) = ptend_sum%hflux_srf(i) + ptend%hflux_srf(i) - ptend_sum%hflux_top(i) = ptend_sum%hflux_top(i) + ptend%hflux_top(i) - end do - end if - - if (any(ptend%lq(:))) then - - if (.not. allocated(ptend_sum%q)) then - allocate(ptend_sum%q(psetcols,pver,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%q') - ptend_sum%q=0.0_r8 - - allocate(ptend_sum%cflx_srf(psetcols,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_srf') - ptend_sum%cflx_srf=0.0_r8 - - allocate(ptend_sum%cflx_top(psetcols,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_top') - ptend_sum%cflx_top=0.0_r8 - end if - - do m = 1, pcnst - if(ptend%lq(m)) then - ptend_sum%lq(m) = .true. - do k = ptend%top_level, ptend%bot_level - do i = 1,ncol - ptend_sum%q(i,k,m) = ptend_sum%q(i,k,m) + ptend%q(i,k,m) - end do - end do - do i = 1,ncol - ptend_sum%cflx_srf(i,m) = ptend_sum%cflx_srf(i,m) + ptend%cflx_srf(i,m) - ptend_sum%cflx_top(i,m) = ptend_sum%cflx_top(i,m) + ptend%cflx_top(i,m) - end do - end if - end do - - end if - - end subroutine physics_ptend_sum - -!=============================================================================== - - subroutine physics_ptend_scale(ptend, fac, ncol) -!----------------------------------------------------------------------- -! Scale ptend fields for ptend logical flags = .true. -! Where ptend logical flags = .false, don't change ptend. -! -! Assumes that input ptend is valid (e.g. that -! ptend%lu .eqv. allocated(ptend%u)), and therefore -! does not check allocation status of individual arrays. -!----------------------------------------------------------------------- - -!------------------------------Arguments-------------------------------- - type(physics_ptend), intent(inout) :: ptend ! Incoming ptend - real(r8), intent(in) :: fac ! Factor to multiply ptend by. - integer, intent(in) :: ncol ! number of columns - -!---------------------------Local storage------------------------------- - integer :: m ! constituent index - -!----------------------------------------------------------------------- - -! Update u,v fields - if (ptend%lu) & - call multiply_tendency(ptend%u, & - ptend%taux_srf, ptend%taux_top) - - if (ptend%lv) & - call multiply_tendency(ptend%v, & - ptend%tauy_srf, ptend%tauy_top) - -! Heat - if (ptend%ls) & - call multiply_tendency(ptend%s, & - ptend%hflux_srf, ptend%hflux_top) - -! Update constituents - do m = 1, pcnst - if (ptend%lq(m)) & - call multiply_tendency(ptend%q(:,:,m), & - ptend%cflx_srf(:,m), ptend%cflx_top(:,m)) - end do - - - contains - - subroutine multiply_tendency(tend_arr, flx_srf, flx_top) - real(r8), intent(inout) :: tend_arr(:,:) ! Tendency array (pcols, plev) - real(r8), intent(inout) :: flx_srf(:) ! Surface flux (or stress) - real(r8), intent(inout) :: flx_top(:) ! Top-of-model flux (or stress) - - integer :: k - - do k = ptend%top_level, ptend%bot_level - tend_arr(:ncol,k) = tend_arr(:ncol,k) * fac - end do - flx_srf(:ncol) = flx_srf(:ncol) * fac - flx_top(:ncol) = flx_top(:ncol) * fac - - end subroutine multiply_tendency - - end subroutine physics_ptend_scale - -!=============================================================================== - -subroutine physics_ptend_copy(ptend, ptend_cp) - - !----------------------------------------------------------------------- - ! Copy a physics_ptend object. Allocate ptend_cp internally before copy. - !----------------------------------------------------------------------- - - type(physics_ptend), intent(in) :: ptend ! ptend source - type(physics_ptend), intent(out) :: ptend_cp ! copy of ptend - - !----------------------------------------------------------------------- - - ptend_cp%name = ptend%name - - ptend_cp%ls = ptend%ls - ptend_cp%lu = ptend%lu - ptend_cp%lv = ptend%lv - ptend_cp%lq = ptend%lq - - call physics_ptend_alloc(ptend_cp, ptend%psetcols) - - ptend_cp%top_level = ptend%top_level - ptend_cp%bot_level = ptend%bot_level - - if (ptend_cp%ls) then - ptend_cp%s = ptend%s - ptend_cp%hflux_srf = ptend%hflux_srf - ptend_cp%hflux_top = ptend%hflux_top - end if - - if (ptend_cp%lu) then - ptend_cp%u = ptend%u - ptend_cp%taux_srf = ptend%taux_srf - ptend_cp%taux_top = ptend%taux_top - end if - - if (ptend_cp%lv) then - ptend_cp%v = ptend%v - ptend_cp%tauy_srf = ptend%tauy_srf - ptend_cp%tauy_top = ptend%tauy_top - end if - - if (any(ptend_cp%lq(:))) then - ptend_cp%q = ptend%q - ptend_cp%cflx_srf = ptend%cflx_srf - ptend_cp%cflx_top = ptend%cflx_top - end if - -end subroutine physics_ptend_copy - -!=============================================================================== - - subroutine physics_ptend_reset(ptend) -!----------------------------------------------------------------------- -! Reset the parameterization tendency structure to "empty" -!----------------------------------------------------------------------- - -!------------------------------Arguments-------------------------------- - type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies -!----------------------------------------------------------------------- - - if(ptend%ls) then - ptend%s = 0._r8 - ptend%hflux_srf = 0._r8 - ptend%hflux_top = 0._r8 - endif - if(ptend%lu) then - ptend%u = 0._r8 - ptend%taux_srf = 0._r8 - ptend%taux_top = 0._r8 - endif - if(ptend%lv) then - ptend%v = 0._r8 - ptend%tauy_srf = 0._r8 - ptend%tauy_top = 0._r8 - endif - if(any (ptend%lq(:))) then - ptend%q = 0._r8 - ptend%cflx_srf = 0._r8 - ptend%cflx_top = 0._r8 - end if - - ptend%top_level = 1 - ptend%bot_level = pver - - return - end subroutine physics_ptend_reset - -!=============================================================================== - subroutine physics_ptend_init(ptend, psetcols, name, ls, lu, lv, lq) -!----------------------------------------------------------------------- -! Allocate the fields in the structure which are specified. -! Initialize the parameterization tendency structure to "empty" -!----------------------------------------------------------------------- - -!------------------------------Arguments-------------------------------- - type(physics_ptend), intent(out) :: ptend ! Parameterization tendencies - integer, intent(in) :: psetcols ! maximum number of columns - character(len=*) :: name ! optional name of parameterization which produced tendencies. - logical, optional :: ls ! if true, then fields to support dsdt are allocated - logical, optional :: lu ! if true, then fields to support dudt are allocated - logical, optional :: lv ! if true, then fields to support dvdt are allocated - logical, dimension(pcnst),optional :: lq ! if true, then fields to support dqdt are allocated - -!----------------------------------------------------------------------- - - if (allocated(ptend%s)) then - call endrun(' physics_ptend_init: ptend should not be allocated before calling this routine') - end if - - ptend%name = name - ptend%psetcols = psetcols - - ! If no fields being stored, initialize all values to appropriate nulls and return - if (.not. present(ls) .and. .not. present(lu) .and. .not. present(lv) .and. .not. present(lq) ) then - ptend%ls = .false. - ptend%lu = .false. - ptend%lv = .false. - ptend%lq(:) = .false. - ptend%top_level = 1 - ptend%bot_level = pver - return - end if - - if (present(ls)) then - ptend%ls = ls - else - ptend%ls = .false. - end if - - if (present(lu)) then - ptend%lu = lu - else - ptend%lu = .false. - end if - - if (present(lv)) then - ptend%lv = lv - else - ptend%lv = .false. - end if - - if (present(lq)) then - ptend%lq(:) = lq(:) - else - ptend%lq(:) = .false. - end if - - call physics_ptend_alloc(ptend, psetcols) - - call physics_ptend_reset(ptend) - - return - end subroutine physics_ptend_init - -!=============================================================================== - - subroutine physics_state_set_grid(lchnk, phys_state) -!----------------------------------------------------------------------- -! Set the grid components of the physics_state object -!----------------------------------------------------------------------- - - integer, intent(in) :: lchnk - type(physics_state), intent(inout) :: phys_state - - ! local variables - integer :: i, ncol - real(r8) :: rlon(pcols) - real(r8) :: rlat(pcols) - - !----------------------------------------------------------------------- - ! get_ncols_p requires a state which does not have sub-columns - if (phys_state%psetcols .ne. pcols) then - call endrun('physics_state_set_grid: cannot pass in a state which has sub-columns') - end if - - ncol = get_ncols_p(lchnk) - - if(ncol<=0) then - write(iulog,*) lchnk, ncol - call endrun('physics_state_set_grid') - end if - - call get_rlon_all_p(lchnk, ncol, rlon) - call get_rlat_all_p(lchnk, ncol, rlat) - phys_state%ncol = ncol - phys_state%lchnk = lchnk - do i=1,ncol - phys_state%lat(i) = rlat(i) - phys_state%lon(i) = rlon(i) - end do - call init_geo_unique(phys_state,ncol) - - end subroutine physics_state_set_grid - - - subroutine init_geo_unique(phys_state,ncol) - integer, intent(in) :: ncol - type(physics_state), intent(inout) :: phys_state - logical :: match - integer :: i, j, ulatcnt, uloncnt - - phys_state%ulat=-999._r8 - phys_state%ulon=-999._r8 - phys_state%latmapback=0 - phys_state%lonmapback=0 - match=.false. - ulatcnt=0 - uloncnt=0 - match=.false. - do i=1,ncol - do j=1,ulatcnt - if(phys_state%lat(i) .eq. phys_state%ulat(j)) then - match=.true. - phys_state%latmapback(i)=j - end if - end do - if(.not. match) then - ulatcnt=ulatcnt+1 - phys_state%ulat(ulatcnt)=phys_state%lat(i) - phys_state%latmapback(i)=ulatcnt - end if - - match=.false. - do j=1,uloncnt - if(phys_state%lon(i) .eq. phys_state%ulon(j)) then - match=.true. - phys_state%lonmapback(i)=j - end if - end do - if(.not. match) then - uloncnt=uloncnt+1 - phys_state%ulon(uloncnt)=phys_state%lon(i) - phys_state%lonmapback(i)=uloncnt - end if - match=.false. - - end do - phys_state%uloncnt=uloncnt - phys_state%ulatcnt=ulatcnt - - call get_gcol_all_p(phys_state%lchnk,pcols,phys_state%cid) - - - end subroutine init_geo_unique - -!=============================================================================== - subroutine physics_cnst_limit(state) - type(physics_state), intent(inout) :: state - - integer :: i,k, ncol - - real(r8) :: mmrSum_O_O2_H ! Sum of mass mixing ratios for O, O2, and H - real(r8), parameter :: mmrMin=1.e-20_r8 ! lower limit of o2, o, and h mixing ratios - real(r8), parameter :: N2mmrMin=1.e-6_r8 ! lower limit of N2 mass mixing ratio - real(r8), parameter :: H2lim=6.e-5_r8 ! H2 limiter: 10x global H2 MMR (Roble, 1995) - integer :: ixo, ixo2, ixh, ixh2 - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call cnst_get_ind('O', ixo) - call cnst_get_ind('O2', ixo2) - call cnst_get_ind('H', ixh) - call cnst_get_ind('H2', ixh2) - - ncol = state%ncol - - !------------------------------------------------------------ - ! Ensure N2 = 1-(O2 + O + H) mmr is greater than 0 - ! Check for unusually large H2 values and set to lower value. - !------------------------------------------------------------ - - do k=1,pver - do i=1,ncol - - if (state%q(i,k,ixo) < mmrMin) state%q(i,k,ixo) = mmrMin - if (state%q(i,k,ixo2) < mmrMin) state%q(i,k,ixo2) = mmrMin - - mmrSum_O_O2_H = state%q(i,k,ixo)+state%q(i,k,ixo2)+state%q(i,k,ixh) - - if ((1._r8-mmrMin-mmrSum_O_O2_H) < 0._r8) then - - state%q(i,k,ixo) = state%q(i,k,ixo) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H - - state%q(i,k,ixo2) = state%q(i,k,ixo2) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H - - state%q(i,k,ixh) = state%q(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H - - endif - - if(state%q(i,k,ixh2) > H2lim) then - state%q(i,k,ixh2) = H2lim - endif - - end do - end do - - end if - end subroutine physics_cnst_limit - -!=============================================================================== - subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt) - use air_composition, only: dry_air_species_num,thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx - use dycore, only: dycore_is - use dme_adjust, only: dme_adjust_run - use ccpp_constituent_prop_mod, only: ccpp_const_props - !----------------------------------------------------------------------- - ! - ! Purpose: Adjust the dry mass in each layer back to the value of physics input state - ! - ! Method: Conserve the integrated mass, momentum and total energy in each layer - ! by scaling the specific mass of consituents, specific momentum (velocity) - ! and specific total energy by the relative change in layer mass. Solve for - ! the new temperature by subtracting the new kinetic energy from total energy - ! and inverting the hydrostatic equation - ! - ! The mass in each layer is modified, changing the relationship of the layer - ! interfaces and midpoints to the surface pressure. The result is no longer in - ! the original hybrid coordinate. - ! - ! Author: Byron Boville - - ! !REVISION HISTORY: - ! 03.03.28 Boville Created, partly from code by Lin in p_d_adjust - ! - !----------------------------------------------------------------------- - - implicit none - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in ) :: dt ! model physics timestep - ! - !---------------------------Local workspace----------------------------- - ! - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: k,m ! Longitude, level indices - real(r8) :: fdq(pcols) ! mass adjustment factor - real(r8) :: te(pcols) ! total energy in a layer - real(r8) :: utmp(pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values - - real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - - real(r8) :: tot_water (pcols,2) ! total water (initial, present) - real(r8) :: tot_water_chg(pcols) ! total water change - - - real(r8),allocatable :: cpairv_loc(:,:) - integer :: m_cnst - - logical :: is_dycore_moist - - character(len=512) :: errmsg - integer :: errflg - - ! - !----------------------------------------------------------------------- - - if (state%psetcols .ne. pcols) then - call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') - end if - - lchnk = state%lchnk - ncol = state%ncol - - ! - ! original code for backwards compatability with FV - ! - if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then - do k = 1, pver - - ! adjust dry mass in each layer back to input value, while conserving - ! constituents, momentum, and total energy - state%ps(:ncol) = state%pint(:ncol,1) - - ! adjusment factor is just change in water vapor - fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k) - - ! adjust constituents to conserve mass in each layer - do m = 1, pcnst - state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) - end do - ! compute new total pressure variables - state%pdel (:ncol,k ) = state%pdel(:ncol,k ) * fdq(:ncol) - state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k) - state%pint (:ncol,k+1) = state%pint(:ncol,k ) + state%pdel(:ncol,k) - state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) - state%rpdel (:ncol,k ) = 1._r8/ state%pdel(:ncol,k ) - end do - else - is_dycore_moist = .true. - call dme_adjust_run (state%ncol, pver, pcnst, state%ps(:ncol), state%pint(:ncol,:), state%pdel(:ncol,:), & - state%lnpint(:ncol,:), state%rpdel(:ncol,:), & - ccpp_const_props, state%q(:ncol,:,:), qini(:ncol,:), liqini(:ncol,:), iceini(:ncol,:), & - is_dycore_moist, errmsg, errflg) - if (errflg /= 0) then - call endrun('physics_dme_adjust: '//errmsg) - end if - endif - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 - else - zvirv(:,:) = zvir - endif - - end subroutine physics_dme_adjust - -!=============================================================================== - - subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & - ent_tnd, pdel_rf) - - ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to - ! atmospheric moisture change: Author: Thomas Toniazzo (17.07.21) - - use dme_adjust_camnor, only: dme_adjust_camnor_run - ! - ! Arguments - ! - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in) :: dt - character(len=*), intent(in) :: step ! which call in physpkg - real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer - real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer - real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation - real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation - real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy - real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy - real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out) :: ent_tnd(pcols) ! column-integrated enthalpy tendency - real(r8), intent(out) :: pdel_rf(pcols,pver) ! ratio old pdel / new pdel - !----------------------------------------------------------------------- - - if (state%psetcols /= pcols) then - call endrun('physics_dme_adjust_camnor: cannot pass in a state which has sub-columns') - end if - - call dme_adjust_camnor_run(state%lchnk, state%ncol, & - state%psetcols, state%pint, state%pmid, & - state%pdel, state%rpdel, state%pdeldry, state%lnpint, state%lnpmid, & - state%ps, state%phis, state%zm, state%zi, & - state%t, state%u, state%v, state%q, state%s, & - tend%dudt, tend%dvdt, tend%dtdt, & - qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & - ent_tnd, pdel_rf) - - end subroutine physics_dme_adjust_camnor - -!=============================================================================== - - - subroutine physics_state_copy(state_in, state_out) - - use ppgrid, only: pver, pverp - use constituents, only: pcnst - - implicit none - - ! - ! Arguments - ! - type(physics_state), intent(in) :: state_in - type(physics_state), intent(out) :: state_out - - ! - ! Local variables - ! - integer i, k, m, ncol - - ! Allocate state_out with same subcol dimension as state_in - call physics_state_alloc ( state_out, state_in%lchnk, state_in%psetcols) - - ncol = state_in%ncol - - state_out%psetcols = state_in%psetcols - state_out%ngrdcol = state_in%ngrdcol - state_out%lchnk = state_in%lchnk - state_out%ncol = state_in%ncol - state_out%count = state_in%count - - do i = 1, ncol - state_out%lat(i) = state_in%lat(i) - state_out%lon(i) = state_in%lon(i) - state_out%ps(i) = state_in%ps(i) - state_out%phis(i) = state_in%phis(i) - end do - state_out%te_ini (:ncol,:) = state_in%te_ini (:ncol,:) - state_out%te_cur (:ncol,:) = state_in%te_cur (:ncol,:) - state_out%tw_ini (:ncol ) = state_in%tw_ini (:ncol ) - state_out%tw_cur (:ncol ) = state_in%tw_cur (:ncol ) - - do k = 1, pver - do i = 1, ncol - state_out%temp_ini(i,k) = state_in%temp_ini(i,k) - state_out%z_ini(i,k) = state_in%z_ini(i,k) - state_out%t(i,k) = state_in%t(i,k) - state_out%u(i,k) = state_in%u(i,k) - state_out%v(i,k) = state_in%v(i,k) - state_out%s(i,k) = state_in%s(i,k) - state_out%omega(i,k) = state_in%omega(i,k) - state_out%pmid(i,k) = state_in%pmid(i,k) - state_out%pdel(i,k) = state_in%pdel(i,k) - state_out%rpdel(i,k) = state_in%rpdel(i,k) - state_out%lnpmid(i,k) = state_in%lnpmid(i,k) - state_out%exner(i,k) = state_in%exner(i,k) - state_out%zm(i,k) = state_in%zm(i,k) - end do - end do - - do k = 1, pverp - do i = 1, ncol - state_out%pint(i,k) = state_in%pint(i,k) - state_out%lnpint(i,k) = state_in%lnpint(i,k) - state_out%zi(i,k) = state_in% zi(i,k) - end do - end do - - - do i = 1, ncol - state_out%psdry(i) = state_in%psdry(i) - end do - do k = 1, pver - do i = 1, ncol - state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k) - state_out%pmiddry(i,k) = state_in%pmiddry(i,k) - state_out%pdeldry(i,k) = state_in%pdeldry(i,k) - state_out%rpdeldry(i,k) = state_in%rpdeldry(i,k) - end do - end do - do k = 1, pverp - do i = 1, ncol - state_out%pintdry(i,k) = state_in%pintdry(i,k) - state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k) - end do - end do - - do m = 1, pcnst - do k = 1, pver - do i = 1, ncol - state_out%q(i,k,m) = state_in%q(i,k,m) - end do - end do - end do - - end subroutine physics_state_copy -!=============================================================================== - - subroutine physics_tend_init(tend) - - implicit none - - ! - ! Arguments - ! - type(physics_tend), intent(inout) :: tend - - ! - ! Local variables - ! - - if (.not. allocated(tend%dtdt)) then - call endrun('physics_tend_init: tend must be allocated before it can be initialized') - end if - - tend%s_dme = 0._r8!+tht - tend%qt_dme = 0._r8!+tht - tend%dtdt = 0._r8 - tend%dudt = 0._r8 - tend%dvdt = 0._r8 - tend%flx_net = 0._r8 - tend%te_tnd = 0._r8 - tend%te_sen = 0._r8 - !tend%te_lat = 0._r8 - tend%tw_tnd = 0._r8 - -end subroutine physics_tend_init - -!=============================================================================== -! this routine only considers wv as not massless (FV and EUL) -subroutine set_state_pdry (state,pdeld_calc) - - use ppgrid, only: pver - use air_composition, only: dry_air_species_num,thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx - implicit none - - type(physics_state), intent(inout) :: state - logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default] - ! .false. don't calculate pdeld - - real(r8) :: tot_water (pcols) ! total td'ly active water - integer ncol - integer k, m, m_cnst - logical do_pdeld_calc - - if ( present(pdeld_calc) ) then - do_pdeld_calc = pdeld_calc - else - do_pdeld_calc = .true. - endif - - ncol = state%ncol - - - state%psdry(:ncol) = state%pint(:ncol,1) - state%pintdry(:ncol,1) = state%pint(:ncol,1) - - if (do_pdeld_calc) then - do k = 1, pver - tot_water(:ncol) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) - end do - state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-tot_water(:ncol)) - end do - endif - - do k = 1, pver - state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k) - state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8 - state%psdry(:ncol) = state%psdry(:ncol) + state%pdeldry(:ncol,k) - end do - - state%rpdeldry(:ncol,:) = 1._r8/state%pdeldry(:ncol,:) - state%lnpmiddry(:ncol,:) = log(state%pmiddry(:ncol,:)) - state%lnpintdry(:ncol,:) = log(state%pintdry(:ncol,:)) - -end subroutine set_state_pdry - -!=============================================================================== - -subroutine set_wet_to_dry (state, convert_cnst_type) - - use constituents, only: pcnst, cnst_type - - type(physics_state), intent(inout) :: state - character(len=3), intent(in), optional :: convert_cnst_type - character(len=3) :: convert_type - - integer m, ncol - -if (present(convert_cnst_type)) then - convert_type=convert_cnst_type -else - convert_type='dry' -endif - - ncol = state%ncol - - do m = 1,pcnst - if (cnst_type(m).eq.convert_type) then - state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:) - endif - end do - -end subroutine set_wet_to_dry - -!=============================================================================== - -subroutine set_dry_to_wet (state, convert_cnst_type) - - use constituents, only: pcnst, cnst_type - - type(physics_state), intent(inout) :: state - character(len=3), intent(in), optional :: convert_cnst_type - character(len=3) :: convert_type - - integer m, ncol - -if (present(convert_cnst_type)) then - convert_type=convert_cnst_type -else - convert_type='dry' -endif - - ncol = state%ncol - - do m = 1,pcnst - if (cnst_type(m).eq.convert_type) then - state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:) - endif - end do - -end subroutine set_dry_to_wet - -!=============================================================================== - -subroutine physics_state_alloc(state,lchnk,psetcols) - - use infnan, only: inf, assignment(=) - -! allocate the individual state components - - type(physics_state), intent(inout) :: state - integer,intent(in) :: lchnk - - integer, intent(in) :: psetcols - - integer :: ierr=0 - - state%lchnk = lchnk - state%psetcols = psetcols - state%ngrdcol = get_ncols_p(lchnk) ! Number of grid columns - - !---------------------------------- - ! Following variables will be overwritten by sub-column generator, if sub-columns are being used - - ! state%ncol - is initialized in physics_state_set_grid, if not using sub-columns - - !---------------------------------- - - allocate(state%lat(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lat') - - allocate(state%lon(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lon') - - allocate(state%ps(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ps') - - allocate(state%psdry(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%psdry') - - allocate(state%phis(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%phis') - - allocate(state%ulat(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulat') - - allocate(state%ulon(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulon') - - allocate(state%t(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%t') - - allocate(state%u(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%u') - - allocate(state%v(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%v') - - allocate(state%s(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%s') - - allocate(state%omega(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%omega') - - allocate(state%pmid(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmid') - - allocate(state%pmiddry(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmiddry') - - allocate(state%pdel(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdel') - - allocate(state%pdeldry(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdeldry') - - allocate(state%rpdel(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdel') - - allocate(state%rpdeldry(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdeldry') - - allocate(state%lnpmid(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmid') - - allocate(state%lnpmiddry(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmiddry') - - allocate(state%exner(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%exner') - - allocate(state%zm(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zm') - - allocate(state%q(psetcols,pver,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%q') - - allocate(state%pint(psetcols,pver+1), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pint') - - allocate(state%pintdry(psetcols,pver+1), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pintdry') - - allocate(state%lnpint(psetcols,pver+1), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpint') - - allocate(state%lnpintdry(psetcols,pver+1), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpintdry') - - allocate(state%zi(psetcols,pver+1), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zi') - - allocate(state%te_ini(psetcols,2), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_ini') - - allocate(state%te_cur(psetcols,2), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur') - - allocate(state%tw_ini(psetcols ), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini') - - allocate(state%tw_cur(psetcols ), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur') - - allocate(state%temp_ini(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%temp_ini') - - allocate(state%z_ini(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%z_ini') - - allocate(state%latmapback(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%latmapback') - - allocate(state%lonmapback(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lonmapback') - - allocate(state%cid(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid') - - state%lat(:) = inf - state%lon(:) = inf - state%ulat(:) = inf - state%ulon(:) = inf - state%ps(:) = inf - state%psdry(:) = inf - state%phis(:) = inf - state%t(:,:) = inf - state%u(:,:) = inf - state%v(:,:) = inf - state%s(:,:) = inf - state%omega(:,:) = inf - state%pmid(:,:) = inf - state%pmiddry(:,:) = inf - state%pdel(:,:) = inf - state%pdeldry(:,:) = inf - state%rpdel(:,:) = inf - state%rpdeldry(:,:) = inf - state%lnpmid(:,:) = inf - state%lnpmiddry(:,:) = inf - state%exner(:,:) = inf - state%zm(:,:) = inf - state%q(:,:,:) = inf - - state%pint(:,:) = inf - state%pintdry(:,:) = inf - state%lnpint(:,:) = inf - state%lnpintdry(:,:) = inf - state%zi(:,:) = inf - - state%te_ini (:,:) = inf - state%te_cur (:,:) = inf - state%tw_ini (: ) = inf - state%tw_cur (: ) = inf - state%temp_ini(:,:) = inf - state%z_ini (:,:) = inf - -end subroutine physics_state_alloc - -!=============================================================================== - -subroutine physics_state_dealloc(state) - -! deallocate the individual state components - - type(physics_state), intent(inout) :: state - integer :: ierr = 0 - - deallocate(state%lat, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lat') - - deallocate(state%lon, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lon') - - deallocate(state%ps, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ps') - - deallocate(state%psdry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%psdry') - - deallocate(state%phis, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%phis') - - deallocate(state%ulat, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulat') - - deallocate(state%ulon, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulon') - - deallocate(state%t, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%t') - - deallocate(state%u, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%u') - - deallocate(state%v, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%v') - - deallocate(state%s, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%s') - - deallocate(state%omega, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%omega') - - deallocate(state%pmid, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmid') - - deallocate(state%pmiddry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmiddry') - - deallocate(state%pdel, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdel') - - deallocate(state%pdeldry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdeldry') - - deallocate(state%rpdel, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdel') - - deallocate(state%rpdeldry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdeldry') - - deallocate(state%lnpmid, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmid') - - deallocate(state%lnpmiddry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmiddry') - - deallocate(state%exner, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%exner') - - deallocate(state%zm, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zm') - - deallocate(state%q, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%q') - - deallocate(state%pint, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pint') - - deallocate(state%pintdry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pintdry') - - deallocate(state%lnpint, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpint') - - deallocate(state%lnpintdry, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpintdry') - - deallocate(state%zi, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zi') - - deallocate(state%te_ini, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_ini') - - deallocate(state%te_cur, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur') - - deallocate(state%tw_ini, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini') - - deallocate(state%tw_cur, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_cur') - - deallocate(state%temp_ini, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%temp_ini') - - deallocate(state%z_ini, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%z_ini') - - deallocate(state%latmapback, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%latmapback') - - deallocate(state%lonmapback, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback') - - deallocate(state%cid, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%cid') - -end subroutine physics_state_dealloc - -!=============================================================================== - -subroutine physics_tend_alloc(tend,psetcols) - - use infnan, only : inf, assignment(=) -! allocate the individual tend components - - type(physics_tend), intent(inout) :: tend - - integer, intent(in) :: psetcols - - integer :: ierr = 0 - - tend%psetcols = psetcols -!+tht - allocate(tend%s_dme(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%s_dme') - allocate(tend%qt_dme(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%qt_dme') -!-tht - allocate(tend%dtdt(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt') - - allocate(tend%dudt(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dudt') - - allocate(tend%dvdt(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dvdt') - - allocate(tend%flx_net(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%flx_net') - - allocate(tend%te_tnd(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_tnd') - - allocate(tend%te_sen(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_sen') - - !allocate(tend%te_lat(psetcols), stat=ierr) - !if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_lat') - - allocate(tend%tw_tnd(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd') - - tend%s_dme (:,:)= inf !+tht - tend%qt_dme(:,:)= inf !+tht - tend%dtdt(:,:) = inf - tend%dudt(:,:) = inf - tend%dvdt(:,:) = inf - tend%flx_net(:) = inf - tend%te_tnd(:) = inf - tend%te_sen(:) = inf - !tend%te_lat(:) = inf - tend%tw_tnd(:) = inf - -end subroutine physics_tend_alloc - -!=============================================================================== - -subroutine physics_tend_dealloc(tend) - -! deallocate the individual tend components - - type(physics_tend), intent(inout) :: tend - integer :: ierr = 0 -!+tht - deallocate(tend%s_dme, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%s_dme') - deallocate(tend%qt_dme, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%qt_dme') -!-tht - deallocate(tend%dtdt, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt') - - deallocate(tend%dudt, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dudt') - - deallocate(tend%dvdt, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dvdt') - - deallocate(tend%flx_net, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%flx_net') - - deallocate(tend%te_tnd, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_tnd') - - deallocate(tend%te_sen, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_sen') - - !deallocate(tend%te_lat, stat=ierr) - !if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_lat') - - deallocate(tend%tw_tnd, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%tw_tnd') -end subroutine physics_tend_dealloc - -!=============================================================================== - -subroutine physics_ptend_alloc(ptend,psetcols) - -! allocate the individual ptend components - - type(physics_ptend), intent(inout) :: ptend - - integer, intent(in) :: psetcols - - integer :: ierr = 0 - - ptend%psetcols = psetcols - - if (ptend%ls) then - allocate(ptend%s(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%s') - - allocate(ptend%hflux_srf(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_srf') - - allocate(ptend%hflux_top(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_top') - end if - - if (ptend%lu) then - allocate(ptend%u(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%u') - - allocate(ptend%taux_srf(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_srf') - - allocate(ptend%taux_top(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_top') - end if - - if (ptend%lv) then - allocate(ptend%v(psetcols,pver), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%v') - - allocate(ptend%tauy_srf(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_srf') - - allocate(ptend%tauy_top(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_top') - end if - - if (any(ptend%lq)) then - allocate(ptend%q(psetcols,pver,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%q') - - allocate(ptend%cflx_srf(psetcols,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_srf') - - allocate(ptend%cflx_top(psetcols,pcnst), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_top') - end if - -end subroutine physics_ptend_alloc - -!=============================================================================== - -subroutine physics_ptend_dealloc(ptend) - -! deallocate the individual ptend components - - type(physics_ptend), intent(inout) :: ptend - integer :: ierr = 0 - - ptend%psetcols = 0 - - if (allocated(ptend%s)) deallocate(ptend%s, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%s') - - if (allocated(ptend%hflux_srf)) deallocate(ptend%hflux_srf, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_srf') - - if (allocated(ptend%hflux_top)) deallocate(ptend%hflux_top, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_top') - - if (allocated(ptend%u)) deallocate(ptend%u, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%u') - - if (allocated(ptend%taux_srf)) deallocate(ptend%taux_srf, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_srf') - - if (allocated(ptend%taux_top)) deallocate(ptend%taux_top, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_top') - - if (allocated(ptend%v)) deallocate(ptend%v, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%v') - - if (allocated(ptend%tauy_srf)) deallocate(ptend%tauy_srf, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_srf') - - if (allocated(ptend%tauy_top)) deallocate(ptend%tauy_top, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_top') - - if (allocated(ptend%q)) deallocate(ptend%q, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%q') - - if (allocated(ptend%cflx_srf)) deallocate(ptend%cflx_srf, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_srf') - - if(allocated(ptend%cflx_top)) deallocate(ptend%cflx_top, stat=ierr) - if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_top') - -end subroutine physics_ptend_dealloc - -end module physics_types From 1dc40b0280479a73a2b475ad9e8d0c72ac87ed5f Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 6 Oct 2025 13:36:51 +0200 Subject: [PATCH 57/78] some minor cleanup --- .../camnor_phys/physics/dme_adjust_camnor.F90 | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 8dda1a7527..5ef20f6453 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -31,6 +31,8 @@ module dme_adjust_camnor logical, parameter :: l_nolocdcpttend=.true. logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot + logical :: hydrostatic = .true. + contains subroutine dme_adjust_camnor_run(lchnk, ncol, & @@ -156,7 +158,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & integer :: ixnumsnow, ixnumrain real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" real(r8) :: mdq(pcols,pver) ! total water tendency - logical :: hydrostatic = .true. !----------------------------------------------------------------------- ! Diagnose boundary enthalpy flux and local heating rates associated to @@ -244,13 +245,15 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! new Dp (=:Dp") pdel_new(:ncol,k) = state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) ! this is Dp"/Dp + + ! compute Dp"/Dp + fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) ! wind adjustment increments uf(:ncol) = 0. vf(:ncol) = 0. - ! u,vtmp set to pre-physics u,v from the updated values and the tendencies + ! set utmp and vtmp pre-physics u,v from the updated values and the tendencies utmp(:ncol) = state_u(:ncol,k) - dt * tend_dudt(:ncol,k) vtmp(:ncol) = state_v(:ncol,k) - dt * tend_dvdt(:ncol,k) @@ -258,10 +261,12 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & te(:ncol,k) = 0._r8 ! lagrangian pressure change *zi at upper interfac - pdzp(:ncol) = pdot(:ncol)*gravit*state_zi(:ncol,k) + pdzp(:ncol) = pdot(:ncol)*gravit*state_zi(:ncol,k) ! lagrangian pressure change at next interface - if(hydrostatic)pdot(:ncol) = pdot(:ncol) + state_pdel(:ncol,k)*mdq(:ncol,k) + if (hydrostatic) then + pdot(:ncol) = pdot(:ncol) + state_pdel(:ncol,k)*mdq(:ncol,k) + end if ! layer increment = work (~alpha*dp) pdzp(:ncol) = (pdot(:ncol)*gravit*state_zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) @@ -282,6 +287,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! store unadjusted q for use in next k state_q(:ncol,k,m) = state_q(:ncol,k,m) / fdq(:ncol) end do + ! adjust L-dependent part of local total enthalpy accordingly latent(:ncol,k) = latent(:ncol,k)/fdq(:ncol) @@ -596,6 +602,7 @@ subroutine dme_bflx(lchnk, ncol, & dcwatr(:ncol) = 0._r8 do k=1,pver mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change + if (conserve_physics .or. .not. l_nolocdcpttend) then condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) else if (conserve_dycore) then @@ -604,6 +611,7 @@ subroutine dme_bflx(lchnk, ncol, & +(zm(:ncol,k)*gravit+state_phis(:ncol))*mdq (:ncol,k) condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) endif + if (bndry_flx_surface) then condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntrnprd(:ncol,k) & -(cpice*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntsnprd(:ncol,k) @@ -622,6 +630,7 @@ subroutine dme_bflx(lchnk, ncol, & condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) endif endif + ! residual column water change: integrates to surface evaporation dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state_pdel(:ncol,k)/gravit enddo From c2aca9e1417a575d4b007810ea8a9945ca61f521 Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 6 Oct 2025 13:48:42 +0200 Subject: [PATCH 58/78] removed write statements from within dme_adjust_camnor.F90 --- src/physics/cam/check_energy.F90 | 1 - src/physics/cam/physics_types.F90 | 5 +-- .../camnor_phys/physics/dme_adjust_camnor.F90 | 37 +++---------------- 3 files changed, 7 insertions(+), 36 deletions(-) diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 50aea298ca..741bd7e1b2 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -1169,7 +1169,6 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. ! Author: Thomas Toniazzo (17.07.21) call physics_dme_adjust_camnor(state, tend, qini, totliqini, toticeini, ztodt, & - step='bc+ac', & ntrnprd=rnsrc_tot*ztodt, & ntsnprd=snsrc_tot*ztodt, & tevap=tevp, & diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90 index 797e899361..41d8af20d1 100644 --- a/src/physics/cam/physics_types.F90 +++ b/src/physics/cam/physics_types.F90 @@ -1377,7 +1377,7 @@ end subroutine physics_dme_adjust !=============================================================================== subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & + ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to @@ -1393,7 +1393,6 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice real(r8), intent(in) :: dt - character(len=*), intent(in) :: step ! which call in physpkg real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation @@ -1417,7 +1416,7 @@ subroutine physics_dme_adjust_camnor(state, tend, qini, liqini, iceini, dt, & state%t, state%u, state%v, state%q, state%s, & tend%dudt, tend%dvdt, tend%dtdt, & qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & + ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) end subroutine physics_dme_adjust_camnor diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 5ef20f6453..93861f5d37 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -29,7 +29,6 @@ module dme_adjust_camnor ! set to T to use distribute implied heating over column section to the surface logical, parameter :: l_nolocdcpttend=.true. - logical, parameter :: logorrhoic=.false. ! T -> talk to log, a lot logical :: hydrostatic = .true. @@ -42,7 +41,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & state_t, state_u, state_v, state_q, state_s, & tend_dudt, tend_dvdt, tend_dtdt, & qini, liqini, iceini, dt, & - step, ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & + ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & ent_tnd, pdel_rf) !----------------------------------------------------------------------- @@ -72,9 +71,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & !----------------------------------------------------------------------- use constituents, only: pcnst, qmin - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - use spmd_utils, only: masterproc use shr_const_mod, only: shr_const_rwv use ppgrid, only: pcols, pver use geopotential, only: geopotential_t @@ -120,7 +116,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice real(r8), intent(in) :: dt - character(len=*), intent(in) :: step ! which call in physpkg real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation @@ -166,7 +161,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & call dme_bflx(lchnk, ncol, & state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevap, tprec, dt, & - step, ntrnprd=ntrnprd, ntsnprd=ntsnprd, & + ntrnprd=ntrnprd, ntsnprd=ntsnprd, & mflx=mflx, eflx=eflx, mflx_out=mflx_out, eflx_out=eflx_out, htx_cond=htx_cond, mdq=mdq ) ! Ajust the dry mass in each layer back to the value of physics input state @@ -375,9 +370,6 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! diagnostics: dme T tendency ttsc(:ncol,:) = (tp(:ncol,:) - state_t(:ncol,:))/dt ! & - ! for tests: correct for effect of cp update on other physics ttend - ! -tend_dtdt(:ncol,:)*(ttsc(:ncol,:)-1._r8) - call outfld('PTTEND_DME', ttsc, pcols, lchnk) ! update ttend and T (cf physics_update) @@ -407,7 +399,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & subroutine dme_bflx(lchnk, ncol, & state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & qini, liqini, iceini, tevp, tprc, dt, & - step, ntrnprd, ntsnprd, & + ntrnprd, ntsnprd, & mflx, eflx, mflx_out, eflx_out, htx_cond, mdq) !----------------------------------------------------------------------- @@ -456,7 +448,6 @@ subroutine dme_bflx(lchnk, ncol, & real(r8), intent(in) :: tevp(pcols) ! temperature of evaporation at bottom of atmo real(r8), intent(in) :: tprc(pcols) ! temperature of precipitation at bottom of atmo real(r8), intent(in) :: dt ! model physics timestep - character(len=*), intent(in) :: step ! which call in physpkg real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer real(r8), intent(in) :: eflx(pcols) ! boundary enthalpy flux @@ -570,24 +561,6 @@ subroutine dme_bflx(lchnk, ncol, & is_invalid(:ncol) = 1 endwhere - ! For testing only - if (logorrhoic) then - if (any(abs(mflx(:ncol)+dcwat(:ncol)/dt) .gt. rtiny)) then - k = maxloc(abs(mflx(:ncol)*dt+dcwat(:ncol)),1) - if (masterproc) then - print*,'bad water in, change ('//trim(step)//'): ',-mflx(k)*dt,dcwat(k) - end if - endif - if (maxval(is_invalid(:ncol)) .gt. 0) then - k = maxloc(abs(is_invalid(:ncol)*eflx(:ncol)),1) - if (abs(eflx(k)).gt.rtiny) then - if (masterproc) then - print*,'ignored eflx ('//trim(step)//'): ',k,eflx(k) - end if - endif - endif - end if - ! local specific enthalpy if (conserve) then do k = 1, pver @@ -693,11 +666,11 @@ subroutine dme_bflx(lchnk, ncol, & endif ! boundary flux of energy due to mass sources (diagnostic) - mflx_out(:ncol ) = 0._r8 + mflx_out(:ncol) = 0._r8 do k = 1, pver where(is_invalid(:ncol).eq.0) ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - mflx_out(:ncol) = mflx_out(:ncol) + state_pdel(:ncol,k)/gravit*mdq (:ncol,k)/dt + mflx_out(:ncol) = mflx_out(:ncol) + state_pdel(:ncol,k)/gravit*mdq(:ncol,k)/dt endwhere enddo From 72fc2a3e217a272390f9ef4b867ef802ebd19573 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 6 Oct 2025 15:08:56 +0200 Subject: [PATCH 59/78] fixed compiler issue --- src/physics/camnor_phys/physics/dme_adjust_camnor.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 index 93861f5d37..c90fbdb4af 100644 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 @@ -78,7 +78,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & use air_composition, only: dry_air_species_num use air_composition, only: thermodynamic_active_species_num use air_composItion, only: thermodynamic_active_species_idx - use air_composition, only: cpairv, rairv, cp_or_cv_dycore + use air_composition, only: cpairv, rairv, cp_or_cv_dycore use constituents, only: cnst_get_ind, cnst_type use cam_thermo, only: inv_conserved_energy use cam_thermo, only: get_conserved_energy @@ -199,7 +199,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & state_t(:ncol,:), state_q(:ncol,:,:) ,state_pdel(:ncol,:), & pdel_new(:ncol,:), state_s(:ncol,:), & qini=qini(:ncol,:), liqini=liqini(:ncol,:), iceini=iceini(:ncol,:), & - phis=state_phis(:ncol) ,gph=state_state_zm(:ncol,:), & + phis=state_phis(:ncol), gph=state_zm(:ncol,:), & U=state_u(:ncol,:), V=state_v(:ncol,:), rairv=rairv(:ncol,:,lchnk), & vcoord=vcoord, refstate='liq', & flatent=latent(:ncol,:), temce=emce(:ncol,:)) @@ -242,7 +242,7 @@ subroutine dme_adjust_camnor_run(lchnk, ncol, & ! compute Dp"/Dp - fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) + fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) ! wind adjustment increments uf(:ncol) = 0. From fd1de7acd676c9ab14b3a28883f44bf18506113b Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 6 Oct 2025 15:22:04 +0200 Subject: [PATCH 60/78] moved dme_adjust_camnor.F90 from camnor/physics to atmos_phys/ --- src/atmos_phys | 2 +- .../camnor_phys/physics/dme_adjust_camnor.F90 | 736 ------------------ 2 files changed, 1 insertion(+), 737 deletions(-) delete mode 100644 src/physics/camnor_phys/physics/dme_adjust_camnor.F90 diff --git a/src/atmos_phys b/src/atmos_phys index 3b9898008c..d7d28adfb4 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 3b9898008cc3bf580403c674a92ed48509de7d0e +Subproject commit d7d28adfb4540e6c053124ede93257743e90c032 diff --git a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 b/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 deleted file mode 100644 index c90fbdb4af..0000000000 --- a/src/physics/camnor_phys/physics/dme_adjust_camnor.F90 +++ /dev/null @@ -1,736 +0,0 @@ -module dme_adjust_camnor - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private ! Make default type private to the module - - public :: dme_adjust_camnor_run - - logical :: levels_are_moist=.true. ! TODO: put in namelist? - - ! 5 possibilities (-> = currently reccommended): - ! 1) conserve_dycore=.false. , conserve_physics=.false. (no conservation = current CAM) - ! 2) conserve_dycore=.true. , bndry_flx_surface=.true. (full conservation, bad climatology) - ! -> 3) conserve_dycore=.true. , bndry_flx_local=.true. (requires fixer to match correct surface fluxes) - ! 4) conserve_physics=.true. , bndry_flx_local=.true. (as 3., plus fixer for atmo energy) - ! 5) conserve_physics=.true. , bndry_flx_surface=.true. (no advantage wrt option 2) - - ! N.B. old case CONDEPSF=CONDEPS_REF (with CONDEPSS consistent with dycore) not allowed here, since its - ! rationale isn't clear. For FV, only three of these options (e.g. 1,2,3) are distinct. - - logical, parameter :: conserve_dycore = .true. - logical, parameter :: bndry_flx_surface = .true. - logical, parameter :: conserve_physics = .not. conserve_dycore - logical, parameter :: bndry_flx_local = .not. bndry_flx_surface - logical, parameter :: conserve = conserve_dycore .or. conserve_physics - - real(r8), parameter :: rtiny = 1e-14_r8 ! a small number (relative to total q change) - - ! set to T to use distribute implied heating over column section to the surface - logical, parameter :: l_nolocdcpttend=.true. - - logical :: hydrostatic = .true. - -contains - - subroutine dme_adjust_camnor_run(lchnk, ncol, & - state_psetcols, state_pint, state_pmid, & - state_pdel, state_rpdel, state_pdeldry, state_lnpint, state_lnpmid, & - state_ps, state_phis, state_zm, state_zi, & - state_t, state_u, state_v, state_q, state_s, & - tend_dudt, tend_dvdt, tend_dtdt, & - qini, liqini, iceini, dt, & - ntrnprd, ntsnprd, tevap, tprec, mflx, eflx, eflx_out, mflx_out, & - ent_tnd, pdel_rf) - - !----------------------------------------------------------------------- - ! - ! Purpose: Adjust the dry mass in each layer back to the value of physics input state - ! Adjust air specific enthalpy accordingly. Diagnose boundary enthalpy flux. - ! - ! Method - ! Revised adjustment towards consistency with local energy conservation. - ! Hydrostatic pressure work, de = alpha * dp, where alpha is the specific volume - ! pressure adjustment, is added locally as an source of enthalpy. An enthalpy of - ! mass (water) exchange with the surface is also defined, which should be passed - ! to the surface model components (ocean/land/ice etc). - ! If moist thermodynamics where handled correctly in CAM, the two terms would - ! match, guaranteeing local energy conservation. - ! With the present CAM formulation (constant dry heat capacity, constant latent - ! heat of condensation valid for 0 degree C), consistency demands one of these - ! choices: - ! 1. no pressure work and no boundary enthalpy flux (CESM) - ! 2. correct local pressure work and boundary enthalpy flux equal to (S dp/g) - ! where S=local *dry* static energy of air - ! The boundary enthalpy flux is at present not passed to other model components, - ! so it is treated as internal CAM non-conservation and folded into fix_energy. - ! - ! Author: Thomas Toniazzo (17.07.21) - ! - !----------------------------------------------------------------------- - - use constituents, only: pcnst, qmin - use shr_const_mod, only: shr_const_rwv - use ppgrid, only: pcols, pver - use geopotential, only: geopotential_t - use phys_control, only: waccmx_is - use air_composition, only: dry_air_species_num - use air_composition, only: thermodynamic_active_species_num - use air_composItion, only: thermodynamic_active_species_idx - use air_composition, only: cpairv, rairv, cp_or_cv_dycore - use constituents, only: cnst_get_ind, cnst_type - use cam_thermo, only: inv_conserved_energy - use cam_thermo, only: get_conserved_energy - use cam_thermo, only: cam_thermo_water_update - use dyn_tests_utils, only: vc_dycore, vc_physics - use qneg_module, only: qneg3 - use cam_history, only: outfld - use physconst, only: cpair, cpwv, cpliq, cpice, gravit, zvir - ! - ! Arguments - ! - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: state_psetcols - real(r8), intent(inout) :: state_pint(:,:) - real(r8), intent(out) :: state_pmid(:,:) - real(r8), intent(inout) :: state_pdel(:,:) - real(r8), intent(out) :: state_rpdel(:,:) - real(r8), intent(in) :: state_pdeldry(:,:) - real(r8), intent(out) :: state_lnpint(:,:) - real(r8), intent(out) :: state_lnpmid(:,:) - real(r8), intent(in) :: state_phis(:) - real(r8), intent(inout) :: state_ps(:) - real(r8), intent(inout) :: state_zm(:,:) - real(r8), intent(inout) :: state_zi(:,:) - real(r8), intent(inout) :: state_t(:,:) - real(r8), intent(inout) :: state_u(:,:) - real(r8), intent(inout) :: state_v(:,:) - real(r8), intent(inout) :: state_q(:,:,:) - real(r8), intent(inout) :: state_s(:,:) - real(r8), intent(inout) :: tend_dudt(:,:) - real(r8), intent(inout) :: tend_dvdt(:,:) - real(r8), intent(inout) :: tend_dtdt(:,:) - real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in) :: dt - real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer - real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer - real(r8), intent(in) :: tevap(pcols) ! temperature of surface evaporation - real(r8), intent(in) :: tprec(pcols) ! temperature of surface precipitation - real(r8), intent(in) :: mflx(pcols) ! mass flux for use in check_energy - real(r8), intent(in) :: eflx(pcols) ! energy flux for use in check_energy - real(r8), intent(out) :: mflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out) :: eflx_out(pcols) ! column (surfce) enthalpy flux from bflx (sanity check) - real(r8), intent(out) :: ent_tnd (pcols) ! column-integrated enthalpy tendency - real(r8), intent(out) :: pdel_rf (pcols,pver) ! ratio old pdel / new pdel - ! - !---------------------------Local workspace----------------------------- - ! - integer :: i,k,m ! Longitude, level indices - real(r8) :: fdq(pcols) ! mass adjustment factor - real(r8) :: utmp(pcols) ! temp variable for recalculating the initial u values - real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values - real(r8) :: te(pcols,pver) ! conserved energy in layer - real(r8) :: emce(pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: cpm(pcols,pver) ! moist air heat capacity - real(r8) :: ttsc(pcols,pver) ! moist air heat capacity - integer :: vcoord - real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - real(r8) :: tot_water(pcols ) ! total water (initial, present) - integer :: m_cnst - real(r8) :: ps_old(pcols) ! old surface pressure - real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - real(r8) :: pdot(pcols) ! total(lagrangian) pressure adjustment - real(r8) :: pdzp(pcols) ! pressure work term in press adjustment - real(r8) :: edot(pcols) ! advective pressure adjustment - real(r8) :: uf(pcols), vf(pcols) ! work arrays - real(r8) :: tp(pcols,pver) ! work array for T/Tv - real(r8) :: latent(pcols,pver) ! work array for Lq - integer :: ixnumice, ixnumliq - integer :: ixnumsnow, ixnumrain - real(r8) :: htx_cond(pcols,pver) ! enthalpy tendency due to heat exchange with "condensates" - real(r8) :: mdq(pcols,pver) ! total water tendency - !----------------------------------------------------------------------- - - ! Diagnose boundary enthalpy flux and local heating rates associated to - ! atmospheric moisture change - - call dme_bflx(lchnk, ncol, & - state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & - qini, liqini, iceini, tevap, tprec, dt, & - ntrnprd=ntrnprd, ntsnprd=ntsnprd, & - mflx=mflx, eflx=eflx, mflx_out=mflx_out, eflx_out=eflx_out, htx_cond=htx_cond, mdq=mdq ) - - ! Ajust the dry mass in each layer back to the value of physics input state - ! Adjust air specific enthalpy accordingly - ! Diagnose boundary enthalpy flux - - call cnst_get_ind('NUMICE', ixnumice, abort=.false.) - call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) - call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) - call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) - - !------------------------------------ - ! initialise adjustment loop - !------------------------------------ - - ! old surface pressure - ps_old (:ncol) = state_ps(:ncol) - state_ps(:ncol) = state_pint(:ncol,1) - - if (conserve_dycore) then - vcoord=vc_dycore - cpm(:ncol,:) = cp_or_cv_dycore(:ncol,:,lchnk) - else - vcoord=vc_physics - cpm(:ncol,:) = cpairv(:ncol,:,lchnk) - endif - - do k = 1, pver - tp(:ncol,k) = state_t(:ncol,k) ! TODO - remoe and use state_t instead below - enddo - - call get_conserved_energy(levels_are_moist, & - 1, pver, & - cpm(:ncol,:), & - state_t(:ncol,:), state_q(:ncol,:,:) ,state_pdel(:ncol,:), & - pdel_new(:ncol,:), state_s(:ncol,:), & - qini=qini(:ncol,:), liqini=liqini(:ncol,:), iceini=iceini(:ncol,:), & - phis=state_phis(:ncol), gph=state_zm(:ncol,:), & - U=state_u(:ncol,:), V=state_v(:ncol,:), rairv=rairv(:ncol,:,lchnk), & - vcoord=vcoord, refstate='liq', & - flatent=latent(:ncol,:), temce=emce(:ncol,:)) - - do k = 1, pver - ! Dp'/Dp - tot_water(:ncol) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state_q(:ncol,k,m) - enddo - ! new surface pressure - state_ps(:ncol) = state_ps(:ncol) + state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - ! make all tracers wet - do m=1,pcnst - if (cnst_type(m).eq.'dry') then - state_q(:ncol,k,m) = state_q(:ncol,k,m)*(1._r8-tot_water(:ncol)) - end if - enddo - enddo - - ! lagrangian & advective pressure change at top interface - pdot(:ncol) = 0._r8 - pdzp(:ncol) = 0._r8 - edot(:ncol) = 0._r8 - - ! store old enthalpy integral - ent_tnd(:ncol)=0._r8 - do k = 1,pver - ent_tnd(:ncol) = ent_tnd(:ncol) - state_pdel(:ncol,k)*state_s(:ncol,k) - enddo - - !------------------------------------ - ! start adjustment loop - !------------------------------------ - do k = 1, pver - - ! new Dp (=:Dp") - pdel_new(:ncol,k) = state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - - - ! compute Dp"/Dp - fdq(:ncol) = pdel_new(:ncol,k)/state_pdel(:ncol,k) - - ! wind adjustment increments - uf(:ncol) = 0. - vf(:ncol) = 0. - - ! set utmp and vtmp pre-physics u,v from the updated values and the tendencies - utmp(:ncol) = state_u(:ncol,k) - dt * tend_dudt(:ncol,k) - vtmp(:ncol) = state_v(:ncol,k) - dt * tend_dvdt(:ncol,k) - - ! adjust specific enthalpy - te(:ncol,k) = 0._r8 - - ! lagrangian pressure change *zi at upper interfac - pdzp(:ncol) = pdot(:ncol)*gravit*state_zi(:ncol,k) - - ! lagrangian pressure change at next interface - if (hydrostatic) then - pdot(:ncol) = pdot(:ncol) + state_pdel(:ncol,k)*mdq(:ncol,k) - end if - - ! layer increment = work (~alpha*dp) - pdzp(:ncol) = (pdot(:ncol)*gravit*state_zi(:ncol,k+1)-pdzp(:ncol))/pdel_new(:ncol,k) - - ! enthalpy change due to mass loss and to hydrost. pressure work in full adjustment - te(:ncol,k) = te(:ncol,k) & - + state_s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") - + emce(:ncol,k)*mdq(:ncol,k)/fdq(:ncol) & ! (phi-phis)*dq*(Dp/Dp") - - pdzp(:ncol) & ! del(g*zm*dp) - + htx_cond(:ncol,k) ! EFLX - - ! momentum - uf(:ncol) = uf(:ncol) +state_u(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) - vf(:ncol) = vf(:ncol) +state_v(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) - - ! adjust constituents to conserve mass in each layer - do m = 1, pcnst - ! store unadjusted q for use in next k - state_q(:ncol,k,m) = state_q(:ncol,k,m) / fdq(:ncol) - end do - - ! adjust L-dependent part of local total enthalpy accordingly - latent(:ncol,k) = latent(:ncol,k)/fdq(:ncol) - - ! adjusted u,v tendencies - tend_dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt - tend_dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt - - ! store unadjusted u,v for use in next k - utmp(:ncol) = state_u(:ncol,k) - vtmp(:ncol) = state_v(:ncol,k) - - ! write adjusted u,v - state_u(:ncol,k) = uf(:ncol) - state_v(:ncol,k) = vf(:ncol) - - ! compute new total pressure variables - state_pint (:ncol,k+1) = state_pint(:ncol,k ) + pdel_new(:ncol,k) - state_lnpint(:ncol,k+1) = log(state_pint(:ncol,k+1)) - - ! also update pmid for geopotential - state_pmid (:ncol,k) = .5_r8*(state_pint(:ncol,k)+state_pint(:ncol,k+1)) - state_lnpmid(:ncol,k) = log(state_pmid(:ncol,k )) - - pdel_rf(:ncol,k)=state_pdel(:ncol,k)/pdel_new(:ncol,k) - state_pdel (:ncol,k ) = pdel_new(:ncol,k) - state_rpdel (:ncol,k ) = 1._r8/state_pdel(:ncol,k) - - end do - - !------------------------------------ - ! end adjustment loop - !------------------------------------ - - ! make dry tracers dry again - do k = 1, pver - tot_water(:ncol) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state_q(:ncol,k,m) - enddo - do m=1,pcnst - if (cnst_type(m).eq.'dry') then - state_q(:ncol,k,m) = state_q(:ncol,k,m)/(1._r8-tot_water(:ncol)) - end if - enddo - enddo - - ! call QNEG3 (cf physics_update) - do m = 1, pcnst - if (m /= ixnumice .and. m /= ixnumliq .and. & - m /= ixnumrain .and. m /= ixnumsnow ) then - call qneg3('dme_adjust', lchnk, ncol, state_psetcols, pver, m, m, qmin(m:m), state_q(:,1:pver,m:m)) - else - do k = 1,pver - state_q(:ncol,k,m) = max(1.e-12_r8,state_q(:ncol,k,m)) - state_q(:ncol,k,m) = min(1.e10_r8,state_q(:ncol,k,m)) - end do - end if - enddo - - if (conserve_dycore) then - call cam_thermo_water_update(state_q(:ncol,:,:), lchnk, ncol, vc_dycore, & - to_dry_factor=state_pdel(:ncol,:)/state_pdeldry(:ncol,:)) - ttsc(:ncol,:)=cpm(:ncol,:)/cp_or_cv_dycore(:ncol,:,lchnk) - cpm(:ncol,:)=cp_or_cv_dycore(:ncol,:,lchnk) - endif - - call inv_conserved_energy(levels_are_moist, & - 1, pver, & - te(:ncol,:), & - cpm(:ncol,:), & - state_q(:ncol,:,:), state_pdel(:ncol,:), & - pdel_new(:ncol,:), tp(:ncol,:), & - flatent=latent(:ncol,:)*0._r8, & - phis=state_phis(:ncol), gph=state_zm(:ncol,:), & - vcoord=vcoord, refstate='liq', & - U=state_u(:ncol,:), V=state_v(:ncol,:)) - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - zvirv(:,:) = shr_const_rwv / rairv(:,:,lchnk) - 1._r8 - else - zvirv(:,:) = zvir - endif - - ! diagnostics: dme T tendency - ttsc(:ncol,:) = (tp(:ncol,:) - state_t(:ncol,:))/dt ! & - - call outfld('PTTEND_DME', ttsc, pcols, lchnk) - - ! update ttend and T (cf physics_update) - tend_dtdt(:ncol,:) = tend_dtdt(:ncol,:) + (tp(:ncol,:) - state_t(:ncol,:))/dt - state_t(:ncol,:) = tp(:ncol,:) - - ! diagnose total internal enthalpy change - do k=1,pver - ent_tnd(:ncol) = ent_tnd(:ncol) + state_pdel(:ncol,k)*te(:ncol,k) - enddo - ent_tnd(:ncol) = ent_tnd(:ncol)/dt/gravit - call geopotential_t ( & - state_lnpint, state_lnpmid, state_pint , state_pmid , state_pdel , state_rpdel , & - state_t , state_q(:,:,:), rairv(:,:,lchnk), gravit , zvirv , & - state_zi , state_zm , ncol ) - - ! update original dry static energy - do k = 1, pver - state_s(:ncol,k) = state_t(:ncol,k )*cpairv(:ncol,k,lchnk) & - + gravit*state_zm(:ncol,k) + state_phis(:ncol) - enddo - - contains - - !=============================================================================== - - subroutine dme_bflx(lchnk, ncol, & - state_ps, state_pint, state_zm, state_q, state_pdel, state_phis, state_t, & - qini, liqini, iceini, tevp, tprc, dt, & - ntrnprd, ntsnprd, & - mflx, eflx, mflx_out, eflx_out, htx_cond, mdq) - - !----------------------------------------------------------------------- - ! - ! Purpose: Diagnose boundary enthalpy flux and local heating rates associated to - ! atmospheric moisture change - ! - ! Method - ! 1. boundary enthalpy flux is *local* total enthalpy (\epsilon dp/g) - ! 2. same as 1., but with different specific enthalpy of boundary mass exchange, - ! CONDEPS, and a matching heat exchange betweeen air and condensated - ! = (\epsilon - CONDEPS) dp/g (sign is for a heat source for air). - ! Choice 2. is taken with dme_ ohf_adjust=.true. For CONDEPS then the following - ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS - ! cpcond is a parameter representing the heat capacity of the condensate phase. - ! The heating rates and enthalpy boundary fluxes are not applied here, - ! they are intended to be passed to dme_adjust. - ! - ! Author: Thomas Toniazzo (17.07.21) - ! - !----------------------------------------------------------------------- - - use air_composition, only: thermodynamic_active_species_idx - use air_composition, only: thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_ice_idx - use air_composition, only: thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_liq_num - use air_composition, only: thermodynamic_active_species_ice_num - use air_composition, only: dry_air_species_num - use air_composition, only: t00a, h00a - ! - ! Arguments - ! - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - real(r8), intent(inout) :: state_ps(:) - real(r8), intent(inout) :: state_pint(:,:) - real(r8), intent(in) :: state_zm(:,:) - real(r8), intent(in) :: state_q(:,:,:) - real(r8), intent(in) :: state_pdel(:,:) - real(r8), intent(in) :: state_phis(:) - real(r8), intent(in) :: state_t(:,:) - real(r8), intent(in) :: qini(pcols,pver) ! initial specific humidity - real(r8), intent(in) :: liqini(pcols,pver) ! initial total liquid - real(r8), intent(in) :: iceini(pcols,pver) ! initial total ice - real(r8), intent(in) :: tevp(pcols) ! temperature of evaporation at bottom of atmo - real(r8), intent(in) :: tprc(pcols) ! temperature of precipitation at bottom of atmo - real(r8), intent(in) :: dt ! model physics timestep - real(r8), intent(in) :: ntrnprd(pcols,pver) ! net precip (liq+ice) production in layer - real(r8), intent(in) :: ntsnprd(pcols,pver) ! net snow production in layer - real(r8), intent(in) :: eflx(pcols) ! boundary enthalpy flux - real(r8), intent(in) :: mflx(pcols) ! boundary mass flux - real(r8), intent(out) :: eflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: mflx_out(pcols) ! diagnostic: boundary enthalpy flux - real(r8), intent(out) :: htx_cond(pcols,pver) ! exchange enthalpy increment for dme_adjust - real(r8), intent(out) :: mdq(pcols,pver) ! total water increment for dme_adjust - - !---------------------------Local workspace----------------------------- - - integer :: i,k,m, ixq ! Longitude, level indices - integer :: ierr ! error flag - real(r8) :: fdq (pcols) ! mass adjustment factor - real(r8) :: dcvap(pcols) ! total column vapour change - real(r8) :: dcliq(pcols) ! total column liquid change - real(r8) :: dcice(pcols) ! total column ice change - real(r8) :: dcwat(pcols) ! total column water change - real(r8) :: dcwatr(pcols) ! residual column water change (in excess of surface flux) - real(r8) :: tot_water(pcols,2) ! work array: total water (initial, present) - integer :: m_cnst ! index - real(r8) :: ps_old(pcols) ! old surface pressure - real(r8) :: pdel_new(pcols,pver) ! Layer thickness (pint(k+1) - pint(k)) - real(r8) :: dvap(pcols,pver) ! wv mass adjustment - real(r8) :: dliq(pcols,pver) ! liq mass adjustment - real(r8) :: dice(pcols,pver) ! ice mass adjustment - real(r8) :: mdqr(pcols,pver) ! residual mass change (work array) - real(r8) :: dcqm(pcols) ! fraction of total/absolute mass change - real(r8) :: te(pcols,pver) ! conserved energy in layer - real(r8) :: emce(pcols,pver) ! total enthalpy - conserved energy in layer - real(r8) :: zm(pcols,pver) ! (phi-phis)/g - real(r8) :: condeps_ref(pcols,pver) ! local specific enthalpy of "condensates" (mass source) - real(r8) :: condepss(pcols,pver) ! specific enthalpy of source reservoir for q changes - real(r8) :: condepsf(pcols,pver) ! specific enthalpy of final reservoir for q changes - real(r8) :: condcp(pcols,pver) ! species-increment-weighted cp - real(r8) :: pint_old(pcols,pver+1) ! work array - real(r8) :: dummy(pcols,pver) ! work array - integer :: is_invalid(pcols) - !----------------------------------------------------------------------- - - ! store old pressure - ps_old (:ncol) = state_ps(:ncol) - pint_old(:ncol,:) = state_pint(:ncol,:) - - zm(:ncol,:) = state_zm(:ncol,:) - - ! get local specific enthalpy, excluding latent heats - if (conserve_dycore) then - call get_conserved_energy(levels_are_moist, & - 1, pver, & - cp_or_cv_dycore(:ncol,:,lchnk) , & - state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & - pdel_new(:ncol,:) ,te(:ncol,:) , & - qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & - phis=state_phis(:ncol) ,gph=zm(:ncol,:), & - U=state_u(:ncol,:) ,V=state_v(:ncol,:), & - vcoord=vc_dycore ,refstate='liq', & - flatent=dummy, temce=emce, rairv=rairv(:ncol,:,lchnk)) - else - call get_conserved_energy(levels_are_moist, & - 1, pver, & - cpairv(:ncol,:,lchnk) , & - state_t(:ncol,:) ,state_q(:ncol,:,:) ,state_pdel(:ncol,:), & - pdel_new(:ncol,:) ,te(:ncol,:), & - qini=qini(:ncol,:),liqini=liqini(:ncol,:),iceini=iceini(:ncol,:), & - phis=state_phis(:ncol), gph=zm(:ncol,:), & - U=state_u(:ncol,:) ,V=state_v(:ncol,:), & - refstate='liq', & - flatent=dummy, temce=emce, rairv=rairv(:ncol,:,lchnk)) - endif - - call cnst_get_ind('Q', ixq) - - ! change in water - dcvap(:ncol)=0._r8 - dcliq(:ncol)=0._r8 - dcice(:ncol)=0._r8 - dcwat(:ncol)=0._r8 - - ! heat associated with cp change - do k = 1, pver - ! mass increments Dp'/Dp - tot_water(:ncol,1) = qini(:ncol,k)+liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O - tot_water(:ncol,2) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol,2) = tot_water(:ncol,2)+state_q(:ncol,k,m) - end do - mdq(:ncol,k)=(tot_water(:ncol,2)-tot_water(:ncol,1)) - - dvap(:ncol,k) = state_q(:ncol,k,ixq) - qini(:ncol,k) - dliq(:ncol,k) = -liqini(:ncol,k) - do m_cnst=1,thermodynamic_active_species_liq_num - m = thermodynamic_active_species_liq_idx(m_cnst) - dliq(:ncol,k) = dliq(:ncol,k)+state_q(:ncol,k,m) - end do - dice(:ncol,k) = -iceini(:ncol,k) - do m_cnst=1,thermodynamic_active_species_ice_num - m = thermodynamic_active_species_ice_idx(m_cnst) - dice(:ncol,k) = dice(:ncol,k)+state_q(:ncol,k,m) - end do - - dcvap(:ncol)=dcvap(:ncol)+dvap(:ncol,k)*state_pdel(:ncol,k)/gravit - dcliq(:ncol)=dcliq(:ncol)+dliq(:ncol,k)*state_pdel(:ncol,k)/gravit - dcice(:ncol)=dcice(:ncol)+dice(:ncol,k)*state_pdel(:ncol,k)/gravit - dcwat(:ncol)=dcwat(:ncol)+ mdq(:ncol,k)*state_pdel(:ncol,k)/gravit - end do - - is_invalid(:ncol)=0 - where(dcwat(:ncol)*mflx(:ncol) .gt. 0._r8) - is_invalid(:ncol) = 1 - endwhere - - ! local specific enthalpy - if (conserve) then - do k = 1, pver - condeps_ref(:ncol,k) = te(:ncol,k) +emce(:ncol,k) - enddo - else - condeps_ref(:ncol,:) = 0._r8 - endif - - ! exchange specific enthalpies, incremental - if (conserve) then ! we can partition between source and destination - dcwatr(:ncol) = 0._r8 - do k=1,pver - mdqr(:ncol,k)=mdq(:ncol,k)+ntrnprd(:ncol,k)+ntsnprd(:ncol,k) ! residual: integrates to vapour change - - if (conserve_physics .or. .not. l_nolocdcpttend) then - condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq (:ncol,k) - else if (conserve_dycore) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq (:ncol,k)*cpliq+dice (:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state_t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state_phis(:ncol))*mdq (:ncol,k) - condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq (:ncol,k) - endif - - if (bndry_flx_surface) then - condepsf(:ncol,k) =-(cpliq*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(tprc(:ncol)-t00a )+state_phis(:ncol))*ntsnprd(:ncol,k) - condepsf(:ncol,k) = condepsf(:ncol,k)-(ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k)+mdqr(:ncol,k)*(cpwv*(tevp(:ncol)-t00a)+state_phis(:ncol)+(cpliq*t00a+h00a)) - else if (bndry_flx_local) then - if (conserve_dycore) then - condepsf(:ncol,k) = -(cpliq*(state_t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state_phis(:ncol))*ntrnprd(:ncol,k) & - -(cpice*(state_t(:ncol,k)-t00a )+zm(:ncol,k)*gravit+state_phis(:ncol))*ntsnprd(:ncol,k) - condepsf(:ncol,k) = condepsf(:ncol,k) - & - (ntrnprd(:ncol,k)+ntsnprd(:ncol,k))*(cpliq*t00a+h00a) - condepsf(:ncol,k) = condepsf(:ncol,k) + & - mdqr(:ncol,k)*(cpwv*(state_t(:ncol,k)-t00a)+zm(:ncol,k)*gravit+state_phis(:ncol)+(cpliq*t00a+h00a)) - else if (conserve_physics) then - condepsf(:ncol,k) =-condeps_ref(:ncol,k)*(ntrnprd(:ncol,k)+ntsnprd(:ncol,k)) - condepsf(:ncol,k) = condepsf(:ncol,k)+condeps_ref(:ncol,k)*mdqr(:ncol,k) - endif - endif - - ! residual column water change: integrates to surface evaporation - dcwatr (:ncol) = dcwatr(:ncol) + mdqr(:ncol,k)*state_pdel(:ncol,k)/gravit - enddo - else - mdqr (:ncol,:)=mdq (:ncol,:) - dcwatr (:ncol) =dcwat(:ncol) - condepsf(:ncol,:)=0._r8 - condepss(:ncol,:)=0._r8 - do k=1,pver - if (conserve_physics.or..not.l_nolocdcpttend) then - condepss(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) - else if (conserve_dycore ) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepss(:ncol,k) = condcp(:ncol,k)*(state_t(:ncol,k)-t00a) & - +(zm(:ncol,k)*gravit+state_phis(:ncol))*mdq(:ncol,k) - condepss(:ncol,k) = condepss(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) - endif - if (bndry_flx_surface) then - condcp (:ncol,k) = dvap (:ncol,k)*cpwv +dliq(:ncol,k)*cpliq+dice(:ncol,k)*cpice - condepsf(:ncol,k) = condcp(:ncol,k)*& - (tprc(:ncol)-t00a)+state_phis(:ncol)*mdq(:ncol,k)+dvap(:ncol,k)*cpwv*(tevp(:ncol)-tprc(:ncol)) - condepsf(:ncol,k) = condepsf(:ncol,k)+(cpliq*t00a+h00a)*mdq(:ncol,k) - else if (bndry_flx_local) then - condepsf(:ncol,k) = condepss(:ncol,k) - if (conserve_dycore .and.l_nolocdcpttend) & - condepsf(:ncol,k) = condepsf(:ncol,k)+((cpliq-cpair)*t00a+h00a)*mdq(:ncol,k) - endif - enddo - endif - - if (conserve) then ! partition arbitrarily based on sign match - ! EFLX_OUT here: work array for part of input EFLX not accounted for by NTSN/RNPR - eflx_out(:ncol) = eflx(:ncol)*dt - do k = 1, pver - where(is_invalid(:ncol).eq.0) - eflx_out(:ncol) = eflx_out(:ncol) - state_pdel(:ncol,k)/gravit*condepsf(:ncol,k) - elsewhere - eflx_out(:ncol) = 0._r8 - endwhere - enddo - dcqm(:ncol)=0._r8 - do k=1,pver - where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - dcqm(:ncol)=dcqm(:ncol)+mdqr(:ncol,k)*state_pdel(:ncol,k)/gravit - endwhere - enddo - where(abs(dcwatr(:ncol)).gt.rtiny) - dcqm(:ncol)=dcwatr(:ncol)/dcqm(:ncol) - elsewhere - dcqm(:ncol)=0._r8 - endwhere - do k=1,pver - where(mdqr(:ncol,k)*dcwatr(:ncol).gt.0._r8) - condepsf(:ncol,k) = condepsf(:ncol,k)+eflx_out(:ncol)/dcwatr(:ncol)*mdqr(:ncol,k)*dcqm(:ncol) - endwhere - where(is_invalid(:ncol).eq.1) - condepsf(:ncol,k) = 0._r8 - endwhere - enddo - endif - - ! boundary flux of energy due to mass sources (diagnostic) - mflx_out(:ncol) = 0._r8 - do k = 1, pver - where(is_invalid(:ncol).eq.0) - ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - mflx_out(:ncol) = mflx_out(:ncol) + state_pdel(:ncol,k)/gravit*mdq(:ncol,k)/dt - endwhere - enddo - - ! boundary flux of energy due to mass sources (diagnostic) - eflx_out(:ncol ) = 0._r8 - do k = 1, pver - where(is_invalid(:ncol).eq.0) - ! boundary-flux diagnostic associated with water exchanged (column water gained/lost) - eflx_out(:ncol) = eflx_out(:ncol) + state_pdel(:ncol,k)/gravit*condepsf(:ncol,k)/dt - endwhere - enddo - - ! make local specific enthalpy incremental - if (conserve) then - do k = 1, pver - condeps_ref(:ncol,k) = condeps_ref(:ncol,k)*mdq(:ncol,k) - enddo - endif - - ! new surface pressure - state_ps(:ncol) = state_pint(:ncol,1) - do k = 1, pver - state_ps(:ncol) = state_ps(:ncol) + state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - end do - - ! heat exchange with condensates - htx_cond(:ncol,:) = 0._r8 - do k = 1, pver - do i=1,ncol - if(l_nolocdcpttend)then - ! diff. between destination enthalpy and LOCAL enthalpy (or zero) is distributed in column below - if (k.eq.1) then - condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state_pdel(i,k)/(state_ps(i)-state_pint(i,k)) - else - condepsf(i,k)=(condepsf(i,k)-condepss(i,k)) & - *state_pdel(i,k)/(state_ps(i)-state_pint(i,k)) & - +condepsf(i,k-1) - endif - else - condepsf(i,k)=(condepsf(i,k)-condepss(i,k))/(1._r8+mdq(i,k)) - endif - htx_cond(i,k) = condepsf(i,k) & - ! diff. between LOCAL enthalpy and reference enthalpy is applied locally - +(condepss(i,k)-condeps_ref(i,k))/(1._r8 + mdq(i,k)) - enddo - - pdel_new(:ncol,k) = state_pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) - - ! compute new total pressure variables - state_pint(:ncol,k+1) = state_pint(:ncol,k ) + pdel_new(:ncol,k) - - end do - - ! original pressure - state_ps (:ncol) = ps_old (:ncol) - state_pint(:ncol,:) = pint_old(:ncol,:) - - end subroutine dme_bflx - - end subroutine dme_adjust_camnor_run - -end module dme_adjust_camnor From 009567527a7dfe8820c16074d31595c8e1d9c007 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 6 Oct 2025 15:23:41 +0200 Subject: [PATCH 61/78] udpated .gitmodules --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 2310218749..5eee066ddf 100644 --- a/.gitmodules +++ b/.gitmodules @@ -32,8 +32,8 @@ [submodule "atmos_phys"] path = src/atmos_phys - url = https://github.com/NorESMhub/atmospheric_physics - fxtag = atmos_phys0_14_001_noresm_v0 + url = https://github.com/mvertens/atmospheric_physics + fxtag = d7d28ad fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/atmospheric_physics From 2214fa17f1b731be5500aea0a53ecb5524f67973 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 7 Oct 2025 09:22:27 +0200 Subject: [PATCH 62/78] added a new conditional for compute_enthalpy_flux --- src/physics/cam/cam_diagnostics.F90 | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index e10d0b32ce..6f4d425528 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -227,9 +227,9 @@ subroutine diag_init_dry(pbuf2d) call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') - call addfld('EBREAK' , horiz_only, 'A','W/m2', & - 'Global-mean energy-nonconservation (W/m2)' ) if (compute_enthalpy_flux) then + call addfld('EBREAK' , horiz_only, 'A','W/m2', & + 'Global-mean energy-nonconservation (W/m2)' ) call addfld('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & 'T-tendency due to water fluxes (end of tphysac)' ) call addfld('IETEND_DME', horiz_only, 'A','W/m2 ', & @@ -2119,11 +2119,17 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) ! Total physics tendency for Temperature ! (remove global fixer tendency from total for FV and SE dycores) - call check_energy_get_integrals(heat_glob_out=heat_glob,tedif_glob_out=tedif_glob) !+tedif - ftem2(:ncol) = tedif_glob/ztodt - call outfld('EBREAK', ftem2, pcols, lchnk) - ftem2(:ncol) = heat_glob/cpair - call outfld('TFIX', ftem2, pcols, lchnk) + if (compute_enthalpy_flux) then + call check_energy_get_integrals(heat_glob_out=heat_glob, tedif_glob_out=tedif_glob) + ftem2(:ncol) = tedif_glob/ztodt + call outfld('EBREAK', ftem2, pcols, lchnk) + ftem2(:ncol) = heat_glob/cpair + call outfld('TFIX', ftem2, pcols, lchnk) + else + call check_energy_get_integrals( heat_glob_out=heat_glob ) + ftem2(:ncol) = heat_glob/cpair + call outfld('TFIX', ftem2, pcols, lchnk) + end if ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair call outfld('PTTEND',ftem3, pcols, lchnk ) From d0bfbceb939c5fabe0ba94c7a5087adeb02514d4 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 7 Oct 2025 09:23:18 +0200 Subject: [PATCH 63/78] updated submodule atmos_phys --- src/atmos_phys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/atmos_phys b/src/atmos_phys index d7d28adfb4..ed27140499 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit d7d28adfb4540e6c053124ede93257743e90c032 +Subproject commit ed271404999d1df4d89b8535b4dd14dd0dc0e8d4 From 07ba8c8b35a3c8b6b3a58483ae30c929dc6982da Mon Sep 17 00:00:00 2001 From: mvertens Date: Tue, 7 Oct 2025 11:20:20 +0200 Subject: [PATCH 64/78] more isolation of compute_enthalpy_flux --- .gitmodules | 2 +- src/utils/air_composition.F90 | 86 ++++++++++++++++------------------- src/utils/cam_thermo.F90 | 1 + 3 files changed, 42 insertions(+), 47 deletions(-) diff --git a/.gitmodules b/.gitmodules index 5eee066ddf..98e900fd7e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -33,7 +33,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/mvertens/atmospheric_physics - fxtag = d7d28ad + fxtag = ed27140 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/atmospheric_physics diff --git a/src/utils/air_composition.F90 b/src/utils/air_composition.F90 index 8203959f07..88f368dfb6 100644 --- a/src/utils/air_composition.F90 +++ b/src/utils/air_composition.F90 @@ -97,12 +97,13 @@ module air_composition real(r8), public, protected :: mbar = unsetr ! Mean mass at mid level ! explicitly declare reference enthalpies and temperatures for atmosphere and ocean - real(r8), public, protected :: t00o ! Water enthalpy reference temperature, ocean (K) - real(r8), public, protected :: t00a ! Water enthalpy reference temperature, atmosphere (K) - real(r8), public, protected :: h00o ! Material enthalpy zero, liquid reference state, ocean water (J/kg) - real(r8), public, protected :: h00a ! Material enthalpy zero, liquid reference state, atmos water (J/kg) - real(r8), public, protected :: h00a_vap ! Material enthalpy zero, vapor reference state, atmos (J/kg) - real(r8), public, protected :: h00a_ice ! Material enthalpy zero, vapor reference state, atmos (J/kg) + ! only used if compute_enthalpy_flux is true + real(r8), public, protected :: t00o = unsetr ! Water enthalpy reference temperature, ocean (K) + real(r8), public, protected :: t00a = unsetr ! Water enthalpy reference temperature, atmosphere (K) + real(r8), public, protected :: h00o = unsetr ! Material enthalpy zero, liquid reference state, ocean water (J/kg) + real(r8), public, protected :: h00a = unsetr ! Material enthalpy zero, liquid reference state, atmos water (J/kg) + real(r8), public, protected :: h00a_vap = unsetr ! Material enthalpy zero, vapor reference state, atmos (J/kg) + real(r8), public, protected :: h00a_ice = unsetr ! Material enthalpy zero, vapor reference state, atmos (J/kg) ! coefficients in expressions for molecular diffusion coefficients ! kv1,..,kv3 are coefficients for kmvis calculation @@ -667,55 +668,48 @@ subroutine air_composition_init() call endrun(subname//': water_species_in_air_num /= 1+liq_num+ice_num') end if - ! hard-wiring here - enthalpy_reference_state = 'ice' - if (masterproc) then - write(iulog,'(a)')'Enthalpy reference state : '//trim(enthalpy_reference_state) - end if + if (compute_enthalpy_fluxes) then - ! Initialising t00's, h00's here - ! N.B. latent heats should be adjusted to t00a, but unless t00a=tmelt, - ! this will break all physics - ! physics and SE dycore make different, mutually inconsistent, - ! hard-wired assumptions on t00 and h00: - ! physics : t00=tmelt, h00(ice)=L(ice; liq, T=tmelt) - ! dynamics (SE): t00=0, h00=0 - ! As a result, any water non-conservation in the dycore results in fixer - ! increments, proportional to h00a as set below. - - ! ocean choice for enthalpy at T=0 (liquid reference phase) - t00o = tmelt - h00o = -cpliq*t00o - - ! atmo choices for enthalpy at T=0 (liquid ref. phase): - if (.not.compute_enthalpy_flux)then - t00a = 0._r8 - h00a = 0._r8 - h00a_ice = 0._r8 - h00a_vap = 0._r8 - else + ! Initialising t00's and h00's + ! N.B. latent heats should be adjusted to t00a, but unless t00a=tmelt, this will break all physics + ! physics and SE dycore make different, mutually inconsistent, + ! hard-wired assumptions on t00 and h00: + ! physics : t00=tmelt, h00(ice)=L(ice; liq, T=tmelt) + ! dynamics (SE): t00=0, h00=0 + ! As a result, any water non-conservation in the dycore results in fixer + ! increments, proportional to h00a as set below. + + ! ocean choice for enthalpy at T=0 (liquid reference phase) + t00o = tmelt + h00o = -cpliq*t00o + + ! atmo choices for enthalpy at T=0 (liquid reference phase): t00a = tmelt - h00a = -cpliq*t00a + h00a = -cpliq*t00a + + ! hard-wiring here + enthalpy_reference_state = 'ice' ! TODO (mvertens): should this be a namelist variable? if (enthalpy_reference_state == 'ice') then - !h00a =-((cpliq-cpice)*t00a - latice) ! cam default h00a_ice=0 (minimizes fixer increments) - h00a = -cpliq*t00a ! conserve single formula for global energy - else if (enthalpy_reference_state.eq.'vap') then + h00a = -cpliq*t00a ! conserve single formula for global energy + else if (enthalpy_reference_state == 'vap') then h00a =-((cpliq-cpwv )*t00a + latvap) endif + ! the following ensure that the value of atmospheric enthalpy is independent of reference state h00a_vap = h00a + ((cpliq-cpwv )*t00a + latvap) h00a_ice = h00a + ((cpliq-cpice)*t00a - latice) - endif - if (masterproc) then - write(iulog, *) ' ocean t00o: ', t00o - write(iulog, *) ' ocean h00o: ', h00o - write(iulog, *) 'atmos. enthalpy_reference_state: ', trim(enthalpy_reference_state) - write(iulog, *) ' t00a: ', t00a - write(iulog, *) ' h00a: ', h00a - write(iulog, *) ' h00a_ice: ', h00a_ice - write(iulog, *) ' h00a_vap: ', h00a_vap - endif + if (masterproc) then + write(iulog, *) ' ocean t00o: ', t00o + write(iulog, *) ' ocean h00o: ', h00o + write(iulog, *) 'atmos. enthalpy_reference_state: ', trim(enthalpy_reference_state) + write(iulog, *) ' t00a: ', t00a + write(iulog, *) ' h00a: ', h00a + write(iulog, *) ' h00a_ice: ', h00a_ice + write(iulog, *) ' h00a_vap: ', h00a_vap + endif + + end if end subroutine air_composition_init diff --git a/src/utils/cam_thermo.F90 b/src/utils/cam_thermo.F90 index 8923c5cfcb..565eda9553 100644 --- a/src/utils/cam_thermo.F90 +++ b/src/utils/cam_thermo.F90 @@ -32,6 +32,7 @@ module cam_thermo ! https://opensky.ucar.edu/islandora/object/articles:21929 public :: get_conserved_energy, inv_conserved_energy + ! cam_thermo_init: Initialize constituent dependent properties public :: cam_thermo_init ! cam_thermo_dry_air_update: Update dry air composition dependent properties From a698021d806f609f1cc8f8d5304bf184e9af9141 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 7 Oct 2025 11:35:52 +0200 Subject: [PATCH 65/78] fixed compiler issue --- src/physics/cam/cam_diagnostics.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 6f4d425528..497bb94c24 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -2082,6 +2082,7 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) use check_energy, only: check_energy_get_integrals use physconst, only: cpair + use air_composition, only: compute_enthalpy_flux ! Arguments From 65a1d7603ace074148c4cdf54d124daaabee6640 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 7 Oct 2025 15:43:52 +0200 Subject: [PATCH 66/78] fixed compiler issues --- src/physics/cam/qneg_module.F90 | 10 +++------- src/utils/air_composition.F90 | 5 ++--- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/src/physics/cam/qneg_module.F90 b/src/physics/cam/qneg_module.F90 index 638b3d72c2..b6ba3384a6 100644 --- a/src/physics/cam/qneg_module.F90 +++ b/src/physics/cam/qneg_module.F90 @@ -391,18 +391,14 @@ subroutine qneg4 (subnam, lchnk, ncol, ztodt, & qflx (i,1) = qflx (i,1) - excess(i) lhflx(i) = lhflx(i) - excess(i)*latvap shflx(i) = shflx(i) + excess(i)*latvap + if (present(seflx)) then + seflx(i) = seflx(i) + excess(i)*(latvap+latice) + end if if (index > 0) then qneg4_warn_num(index) = qneg4_warn_num(index) + 1 end if end if end do - if (present(seflx)) then - do i = 1, ncol - if (excess(i) < 0._r8) then - seflx(i) = seflx(i) + excess(i)*(latvap+latice) - end if - end do - end if ! Maybe output bad values if ((cnst_outfld((2*pcnst)+1)) .and. (worst < worst_reset)) then diff --git a/src/utils/air_composition.F90 b/src/utils/air_composition.F90 index 88f368dfb6..440e034f4a 100644 --- a/src/utils/air_composition.F90 +++ b/src/utils/air_composition.F90 @@ -35,8 +35,6 @@ module air_composition integer, parameter, public :: fliq_idx = 3 ! index for flux of liquid precipitation integer, parameter, public :: fice_idx = 4 ! index for flux of frozen precipitation - logical, protected, public :: compute_enthalpy_flux = .false. ! obtained from nuopc mediator - private :: air_species_info integer, parameter :: unseti = -HUGE(1) @@ -98,6 +96,7 @@ module air_composition ! explicitly declare reference enthalpies and temperatures for atmosphere and ocean ! only used if compute_enthalpy_flux is true + logical , public, protected :: compute_enthalpy_flux = .false. ! obtained from nuopc mediator real(r8), public, protected :: t00o = unsetr ! Water enthalpy reference temperature, ocean (K) real(r8), public, protected :: t00a = unsetr ! Water enthalpy reference temperature, atmosphere (K) real(r8), public, protected :: h00o = unsetr ! Material enthalpy zero, liquid reference state, ocean water (J/kg) @@ -668,7 +667,7 @@ subroutine air_composition_init() call endrun(subname//': water_species_in_air_num /= 1+liq_num+ice_num') end if - if (compute_enthalpy_fluxes) then + if (compute_enthalpy_flux) then ! Initialising t00's and h00's ! N.B. latent heats should be adjusted to t00a, but unless t00a=tmelt, this will break all physics From 057770598c6787aef3d9529228c51c8abd5279f1 Mon Sep 17 00:00:00 2001 From: mvertens Date: Tue, 7 Oct 2025 18:34:21 +0200 Subject: [PATCH 67/78] physics/cam/qneg_module.F90 fixed problem if refactor - this will change answers --- src/physics/cam/physics_types.F90 | 63 +++++++++++-------------------- src/physics/cam/qneg_module.F90 | 2 +- 2 files changed, 24 insertions(+), 41 deletions(-) diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90 index 41d8af20d1..e144e2a225 100644 --- a/src/physics/cam/physics_types.F90 +++ b/src/physics/cam/physics_types.F90 @@ -432,46 +432,29 @@ subroutine physics_update(state, ptend, dt, tend ) if(ptend%ls) then if(compute_enthalpy_flux) then - !use conserved energy - call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & - , cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & - , pdel(:ncol,:), te(:ncol,:)) - te(:ncol,ptend%top_level:ptend%bot_level)=te(:ncol,ptend%top_level:ptend%bot_level) & - +ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt - call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level & - , te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:) & - , pdel(:ncol,:), t_tmp(:ncol,:)) - if (present(tend)) & - tend%dtdt(:ncol,ptend%top_level:ptend%bot_level)=tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & - (T_tmp(:ncol,ptend%top_level:ptend%bot_level) & - -state%t(:ncol,ptend%top_level:ptend%bot_level))/dt - state%T(:ncol,ptend%top_level:ptend%bot_level)=T_tmp(:ncol,ptend%top_level:ptend%bot_level) - end if - - ! if(compute_enthalpy_flux) then - ! !use conserved energy - ! call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & - ! cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & - ! pdel(:ncol,:), te(:ncol,:)) - ! te(:ncol,ptend%top_level:ptend%bot_level) = te(:ncol,ptend%top_level:ptend%bot_level) + & - ! ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt - ! call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & - ! te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & - ! pdel(:ncol,:), t_tmp(:ncol,:)) - ! if (present(tend)) then - ! tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) = tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & - ! (T_tmp(:ncol,ptend%top_level:ptend%bot_level) - & - ! state%t(:ncol,ptend%top_level:ptend%bot_level))/dt - ! end if - ! state%T(:ncol,ptend%top_level:ptend%bot_level) = T_tmp(:ncol,ptend%top_level:ptend%bot_level) - ! else - ! do k = ptend%top_level, ptend%bot_level - ! state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) - ! if (present(tend)) then - ! tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) - ! end if - ! end do - ! endif + !use conserved energy (pe and te are output variables in get_conserved_energy call) + call get_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & + cpairv_loc(:ncol,:), state%T(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & + pdel(:ncol,:), te(:ncol,:)) + te(:ncol,ptend%top_level:ptend%bot_level) = te(:ncol,ptend%top_level:ptend%bot_level) + & + ptend%s(:ncol,ptend%top_level:ptend%bot_level)*dt + call inv_conserved_energy(levels_are_moist, ptend%top_level, ptend%bot_level, & + te(:ncol,:), cpairv_loc(:ncol,:), state%q(:ncol,:,:), state%pdel(:ncol,:), & + pdel(:ncol,:), t_tmp(:ncol,:)) + if (present(tend)) then + tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) = tend%dtdt(:ncol,ptend%top_level:ptend%bot_level) + & + (T_tmp(:ncol,ptend%top_level:ptend%bot_level) - & + state%t(:ncol,ptend%top_level:ptend%bot_level))/dt + end if + state%T(:ncol,ptend%top_level:ptend%bot_level) = T_tmp(:ncol,ptend%top_level:ptend%bot_level) + else + do k = ptend%top_level, ptend%bot_level + state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) + if (present(tend)) then + tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) + end if + end do + endif end if diff --git a/src/physics/cam/qneg_module.F90 b/src/physics/cam/qneg_module.F90 index b6ba3384a6..432324e1bd 100644 --- a/src/physics/cam/qneg_module.F90 +++ b/src/physics/cam/qneg_module.F90 @@ -325,7 +325,7 @@ subroutine qneg4 (subnam, lchnk, ncol, ztodt, & ! Author: J. Olson ! !----------------------------------------------------------------------- - use physconst, only: gravit, latvap, latice !+tht + use physconst, only: gravit, latvap, latice use constituents, only: qmin use cam_history, only: outfld From 81fb022679f9c778c779e201b9a454d512cccea0 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 8 Oct 2025 11:14:09 +0200 Subject: [PATCH 68/78] made new updates consistent with noresm3_0_015_cam6_4_085 --- src/physics/cam/physics_types.F90 | 98 ++++++++++++++++--------------- 1 file changed, 52 insertions(+), 46 deletions(-) diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90 index e144e2a225..4fb5efe0ca 100644 --- a/src/physics/cam/physics_types.F90 +++ b/src/physics/cam/physics_types.F90 @@ -1520,35 +1520,30 @@ subroutine physics_tend_init(tend) call endrun('physics_tend_init: tend must be allocated before it can be initialized') end if - tend%s_dme = 0._r8!+tht - tend%qt_dme = 0._r8!+tht + tend%s_dme = 0._r8 + tend%qt_dme = 0._r8 tend%dtdt = 0._r8 tend%dudt = 0._r8 tend%dvdt = 0._r8 tend%flx_net = 0._r8 tend%te_tnd = 0._r8 tend%te_sen = 0._r8 - !tend%te_lat = 0._r8 tend%tw_tnd = 0._r8 end subroutine physics_tend_init !=============================================================================== -! this routine only considers wv as not massless (FV and EUL) + subroutine set_state_pdry (state,pdeld_calc) use ppgrid, only: pver - use air_composition, only: dry_air_species_num,thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx implicit none type(physics_state), intent(inout) :: state logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default] ! .false. don't calculate pdeld - - real(r8) :: tot_water (pcols) ! total td'ly active water integer ncol - integer k, m, m_cnst + integer k logical do_pdeld_calc if ( present(pdeld_calc) ) then @@ -1564,16 +1559,10 @@ subroutine set_state_pdry (state,pdeld_calc) state%pintdry(:ncol,1) = state%pint(:ncol,1) if (do_pdeld_calc) then - do k = 1, pver - tot_water(:ncol) = 0.0_r8 - do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num - m = thermodynamic_active_species_idx(m_cnst) - tot_water(:ncol) = tot_water(:ncol)+state%q(:ncol,k,m) - end do - state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-tot_water(:ncol)) - end do + do k = 1, pver + state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-state%q(:ncol,k,1)) + end do endif - do k = 1, pver state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k) state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8 @@ -1588,56 +1577,72 @@ end subroutine set_state_pdry !=============================================================================== -subroutine set_wet_to_dry (state, convert_cnst_type) +subroutine set_wet_to_dry(state, convert_cnst_type) + + ! Convert mixing ratios from a wet to dry basis for constituents of type + ! convert_cnst_type. Constituents are given a type when they are added + ! to the constituent array by a call to cnst_add during the register + ! phase of initialization. There are two constituent types: 'wet' for + ! water species and 'dry' for non-water species. use constituents, only: pcnst, cnst_type type(physics_state), intent(inout) :: state - character(len=3), intent(in), optional :: convert_cnst_type - character(len=3) :: convert_type + character(len=3), intent(in) :: convert_cnst_type + ! local variables integer m, ncol + character(len=*), parameter :: sub = 'set_wet_to_dry' + !----------------------------------------------------------------------------- -if (present(convert_cnst_type)) then - convert_type=convert_cnst_type -else - convert_type='dry' -endif + ! check input + if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then + write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type + call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type) + end if ncol = state%ncol - do m = 1,pcnst - if (cnst_type(m).eq.convert_type) then + do m = 1, pcnst + if (cnst_type(m) == convert_cnst_type) then state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:) - endif + end if end do end subroutine set_wet_to_dry !=============================================================================== -subroutine set_dry_to_wet (state, convert_cnst_type) +subroutine set_dry_to_wet(state, convert_cnst_type) + + ! Convert mixing ratios from a dry to wet basis for constituents of type + ! convert_cnst_type. Constituents are given a type when they are added + ! to the constituent array by a call to cnst_add during the register + ! phase of initialization. There are two constituent types: 'wet' for + ! water species and 'dry' for non-water species. use constituents, only: pcnst, cnst_type type(physics_state), intent(inout) :: state - character(len=3), intent(in), optional :: convert_cnst_type - character(len=3) :: convert_type + character(len=3), intent(in) :: convert_cnst_type + ! local variables integer m, ncol + character(len=*), parameter :: sub = 'set_dry_to_wet' + !----------------------------------------------------------------------------- -if (present(convert_cnst_type)) then - convert_type=convert_cnst_type -else - convert_type='dry' -endif + ! check input + if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then + write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type + call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type) + end if ncol = state%ncol - do m = 1,pcnst - if (cnst_type(m).eq.convert_type) then + do m = 1, pcnst + if (cnst_type(m) == convert_cnst_type) then state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:) - endif + end if end do end subroutine set_dry_to_wet @@ -1954,12 +1959,12 @@ subroutine physics_tend_alloc(tend,psetcols) integer :: ierr = 0 tend%psetcols = psetcols -!+tht + allocate(tend%s_dme(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%s_dme') allocate(tend%qt_dme(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%qt_dme') -!-tht + allocate(tend%dtdt(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt') @@ -1984,8 +1989,8 @@ subroutine physics_tend_alloc(tend,psetcols) allocate(tend%tw_tnd(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd') - tend%s_dme (:,:)= inf !+tht - tend%qt_dme(:,:)= inf !+tht + tend%s_dme (:,:)= inf + tend%qt_dme(:,:)= inf tend%dtdt(:,:) = inf tend%dudt(:,:) = inf tend%dvdt(:,:) = inf @@ -2005,12 +2010,13 @@ subroutine physics_tend_dealloc(tend) type(physics_tend), intent(inout) :: tend integer :: ierr = 0 -!+tht + deallocate(tend%s_dme, stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%s_dme') + deallocate(tend%qt_dme, stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%qt_dme') -!-tht + deallocate(tend%dtdt, stat=ierr) if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt') From 8e7812d7bbb8a3b4883c06037856546b5497b9b2 Mon Sep 17 00:00:00 2001 From: mvertens Date: Wed, 8 Oct 2025 11:38:26 +0200 Subject: [PATCH 69/78] fixed compilation problem --- src/physics/cam/cam_diagnostics.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 497bb94c24..9376e729fe 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -88,7 +88,6 @@ module cam_diagnostics ! liquid budgets. integer :: history_budget_histfile_num ! output history file number for budget fields logical :: history_waccm ! outputs typically used for WACCM -logical :: history_enthalpy_flux ! outputs enthalpy flux diagnostics ! Physics buffer indices From c4ba93d9fa9bd8e34c8c4e9748b31f916638277d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 8 Oct 2025 14:20:24 +0200 Subject: [PATCH 70/78] added new test for cam sending enthalpy to mediator --- cime_config/testdefs/testlist_cam.xml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 5ac4533897..52ddb38198 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -53,6 +53,15 @@ + + + + + + + + + From 0dad3656298b9ba2d1e0ca5f29e888e1657e8012 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 9 Oct 2025 22:33:56 +0200 Subject: [PATCH 71/78] udpated cam with new testmod and new query of component_computes_enthalpy_fluxes --- .../cam/outfrq9s_enthalpy_from_cam/shell_commands | 2 ++ .../cam/outfrq9s_enthalpy_from_cam/user_nl_cam | 5 +++++ .../cam/outfrq9s_enthalpy_from_cam/user_nl_cpl | 1 + src/cpl/nuopc/atm_comp_nuopc.F90 | 7 ++++--- 4 files changed, 12 insertions(+), 3 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/shell_commands create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cam create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/shell_commands new file mode 100644 index 0000000000..eb40ad83e0 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/shell_commands @@ -0,0 +1,2 @@ +./xmlchange ROF_NCPL=\$ATM_NCPL +./xmlchange GLC_NCPL=\$ATM_NCPL diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cam new file mode 100644 index 0000000000..77424c653b --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cam @@ -0,0 +1,5 @@ +mfilt=1,1,1,1,1,1 +ndens=1,1,1,1,1,1 +nhtfrq=9,9,9,9,9,9 +write_nstep0=.true. +inithist='ENDOFRUN' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl new file mode 100644 index 0000000000..eb0ac49cff --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl @@ -0,0 +1 @@ +atm_computes_enthalpy_flux = .true. \ No newline at end of file diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index e60edcb4da..be7e575b2c 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -306,10 +306,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name='atm_computes_enthalpy_flux', value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + compute_enthalpy_flux = .false. if (isPresent .and. isSet) then - read (cvalue,*) compute_enthalpy_flux - else - compute_enthalpy_flux = .false. + if (trim(cvalue) == 'atm') then + compute_enthalpy_flux = .true. + end if end if ! read mediator fields namelists From 2f35a9cf99743b87a1216596b1514c4a8878f0d4 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 10 Oct 2025 10:10:47 +0200 Subject: [PATCH 72/78] fixed new enthalpy test --- .../testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl index eb0ac49cff..58bfdcc086 100644 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_enthalpy_from_cam/user_nl_cpl @@ -1 +1 @@ -atm_computes_enthalpy_flux = .true. \ No newline at end of file +component_computes_enthalpy_flux = 'atm' \ No newline at end of file From e28c1c0abd6f35d0d5a0e3884e769b2382ed9ec8 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 10 Oct 2025 19:56:31 +0200 Subject: [PATCH 73/78] updated logic for component_computes_enthalpy_fluxes --- src/cpl/nuopc/atm_comp_nuopc.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index be7e575b2c..42a459a548 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -313,6 +313,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) end if end if + call NUOPC_CompAttributeGet(gcomp, name='component_computes_enthalpy_flux', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) == 'atm') then + compute_enthalpy_flux = .true. + else + compute_enthalpy_flux = .false. + end if + else + compute_enthalpy_flux = .false. + end if + ! read mediator fields namelists call read_surface_fields_namelists() From 0748f4da924544b2a7f055010499f302d69e4107 Mon Sep 17 00:00:00 2001 From: mvertens Date: Sun, 12 Oct 2025 13:22:01 +0200 Subject: [PATCH 74/78] clean up of comments --- src/chemistry/oslo_aero | 2 +- src/physics/cam/check_energy.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index 442f15bdfe..0c99adb327 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit 442f15bdfe85f76d89a29fbeda826acdafed94ed +Subproject commit 0c99adb32794b3cec92766b4efbce9f0241dde44 diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 741bd7e1b2..8399d685dd 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -985,7 +985,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, real(r8), dimension(pcols) :: variable_latent_heat_surface_cpice_term !xxx diagnostics real(r8), dimension(pcols) :: variable_latent_heat_surface_ls_term !xxx diagnostics real(r8), dimension(pcols) :: variable_latent_heat_surface_lf_term !xxx diagnostics - real(r8), dimension(pcols) :: enthalpy_flux_atm, enthalpy_flux_ocn !tht + real(r8), dimension(pcols) :: enthalpy_flux_atm, enthalpy_flux_ocn real(r8), dimension(pcols,pver) :: tmp_t, pdel_rf, qinp, totliqinp, toticeinp real(r8), dimension(pcols) :: zero, dsema, dcp_heat, iedme real(r8), dimension(pcols) :: water_flux_bc, water_flux_ac, enthalpy_flux_bc, enthalpy_flux_ac @@ -1015,7 +1015,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, nstep = get_nstep() zero(:)=0._r8 - ! scale temperature for consistency with dycore (tht: partial adj. after cp update done implicitly in dme) + ! scale temperature for consistency with dycore (partial adj. after cp update done implicitly in dme) do k = 1, pver do i = 1, ncol scale_cpdry_cpdycore(i,k) = cpairv(i,k,lchnk)/cp_or_cv_dycore(i,k,lchnk) @@ -1038,7 +1038,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, ! using merged quantities, for atmospheric mat.enthalpy flux (used in check_energy) if (minval(cam_in%ts(:ncol)).gt.0._r8) then hevap_atm(:ncol) = cam_in%cflx (:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm - !tht: add non-linear terms? using evap_ocn, sst + ! add non-linear terms? using evap_ocn, sst if (use_nonlinear_evap_fraction) then nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large @@ -1057,7 +1057,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, else tevp (:ncol)= cam_in%ts(:ncol) endif - !tht: for ocean-only mat.enthalpy flux (passed to ocean) + ! for ocean-only mat.enthalpy flux (passed to ocean) hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) else ! not great but better than zeros hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm @@ -1100,7 +1100,7 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, ! compute precipitation enthalpy fluxes from tphysbc tprc (:ncol) = cam_out%tbot(:ncol) - !tht: correct for reference T of latent heats (liquid reference state) + ! correct for reference T of latent heats (liquid reference state) enthalpy_prec_ac(:ncol,hice_idx) = -enthalpy_prec_ac(:ncol,fice_idx)*(cpice*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) enthalpy_prec_ac(:ncol,hliq_idx) = -enthalpy_prec_ac(:ncol,fliq_idx)*(cpliq*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) call pbuf_set_field(pbuf, enthalpy_prec_ac_idx, enthalpy_prec_ac) From d0e98ccc090b8175812a2e19528c604cd109dfaa Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 13 Oct 2025 12:02:23 +0200 Subject: [PATCH 75/78] removal of use_nonlinear_evap_fraction --- src/physics/cam/check_energy.F90 | 71 ++++++++------------------------ 1 file changed, 17 insertions(+), 54 deletions(-) diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 8399d685dd..358925cb3e 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -1002,12 +1002,8 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, integer nstep, ixq, m, m_cnst real(r8), dimension(pcols,pver) :: fct_bc, fct_ac real(r8), dimension(pcols,pver) :: scale_cpdry_cpdycore, ttend_hfix - real(r8), parameter :: eps=1.E-10_r8 - - logical, parameter :: debug_enthalpy=.false. - logical, parameter :: use_nonlinear_evap_fraction=.false. - + logical , parameter :: debug_enthalpy=.false. integer :: i, k real(r8):: tot, wgt_bc, wgt_ac !----------------------------------------------------------------------------- @@ -1035,55 +1031,20 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, if (enthalpy_evop_idx==0) then call endrun("pbufs for enthalpy evap flux not allocated") end if + ! using merged quantities, for atmospheric mat.enthalpy flux (used in check_energy) if (minval(cam_in%ts(:ncol)).gt.0._r8) then - hevap_atm(:ncol) = cam_in%cflx (:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm - ! add non-linear terms? using evap_ocn, sst - if (use_nonlinear_evap_fraction) then - nocnfrc(:ncol)=1._r8-cam_in%ocnfrac(:ncol) - where(nocnfrc(:ncol).gt.1e-2) ! not sure what's safe here -- last factor may be large - hevap_atm(:ncol)= hevap_atm(:ncol) & - + cpwv & - *(1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & - *(cam_in%cflx(:ncol,1)-cam_in%evap_ocn(:ncol)) & - *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) - tevp (:ncol)= cam_in%ts(:ncol) & - + (1._r8-nocnfrc(:ncol))/nocnfrc(:ncol) & - *(1._r8-cam_in%evap_ocn(:ncol)/cam_in%cflx(:ncol,1))& - *(cam_in%ts(:ncol)-cam_in%sst(:ncol)) - elsewhere - tevp (:ncol)= cam_in%ts(:ncol) - endwhere - else - tevp (:ncol)= cam_in%ts(:ncol) - endif + hevap_atm(:ncol) = cam_in%cflx(:ncol,1)*(cpwv*(cam_in%ts (:ncol)-t00a)+(cpliq*t00a+h00a)) ! into atm + tevp(:ncol)= cam_in%ts(:ncol) ! for ocean-only mat.enthalpy flux (passed to ocean) - hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol) *(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) + hevap_ocn (:ncol)= cam_in%evap_ocn(:ncol)*(cpwv*(cam_in%sst(:ncol)-t00a)+(cpliq*t00a+h00a)) else ! not great but better than zeros - hevap_atm (:ncol)= cam_in%cflx (:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm + hevap_atm (:ncol)= cam_in%cflx(:ncol,1)*(cpwv*(state%t(:ncol,pver)-t00a)+(cpliq*t00a+h00a)) ! into atm tevp (:ncol)= state%t(:ncol,pver) hevap_ocn (:ncol)= hevap_atm(:ncol) ! out of ocn endif call pbuf_set_field(pbuf, enthalpy_evop_idx, hevap_ocn) - if (use_nonlinear_evap_fraction) then - if(maxval(tevp(:ncol)).gt.350._r8 .or. minval(tevp(:ncol)).lt.150._r8)then - i=maxloc(tevp(:ncol),1) - k=minloc(tevp(:ncol),1) - print*,'Bad Tevap' - print*,'min ts=',minval(cam_in%ts(:ncol)),maxval(cam_in%ts(:ncol)) - print*,'state%t',minval(state%t(:ncol,pver)),maxval(state%t(:ncol,pver)) - print*,'tevp =',tevp(k),tevp(i) - print*,'ts =',cam_in%ts (k),cam_in%ts (i) - print*,'sst =',cam_in%sst(k),cam_in%sst(i) - print*,'cflx =',cam_in%cflx(k,1),cam_in%cflx(i,1) - print*,'evop =',cam_in%evap_ocn(k),cam_in%evap_ocn(i) - print*,'corr =',(1._r8-nocnfrc(k))/nocnfrc(k) *(1._r8-cam_in%evap_ocn(k)/cam_in%cflx(k,1)) *(cam_in%ts(k)-cam_in%sst(k)) & - ,(1._r8-nocnfrc(i))/nocnfrc(i) *(1._r8-cam_in%evap_ocn(i)/cam_in%cflx(i,1)) *(cam_in%ts(i)-cam_in%sst(i)) - call endrun('stopping in enthalpy_adjustment') - endif - endif - !------------------------------------------------------------------ ! compute precipitation fluxes and set associated physics buffers !------------------------------------------------------------------ @@ -1094,12 +1055,14 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, end if call pbuf_get_field(pbuf, enthalpy_prec_bc_idx, enthalpy_prec_bc) call get_prec_vars(ncol,pbuf,fliq=fliq_tot,fice=fice_tot) + ! fliq_tot holds liquid precipitation from tphysbc and tphysac; idem for ice enthalpy_prec_ac(:ncol,fice_idx) = fice_tot(:ncol)-enthalpy_prec_bc(:ncol,fice_idx) enthalpy_prec_ac(:ncol,fliq_idx) = fliq_tot(:ncol)-enthalpy_prec_bc(:ncol,fliq_idx) ! compute precipitation enthalpy fluxes from tphysbc - tprc (:ncol) = cam_out%tbot(:ncol) + tprc(:ncol) = cam_out%tbot(:ncol) + ! correct for reference T of latent heats (liquid reference state) enthalpy_prec_ac(:ncol,hice_idx) = -enthalpy_prec_ac(:ncol,fice_idx)*(cpice*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) enthalpy_prec_ac(:ncol,hliq_idx) = -enthalpy_prec_ac(:ncol,fliq_idx)*(cpliq*(tprc(:ncol)-t00a)+(cpliq*t00a+h00a)) @@ -1108,16 +1071,16 @@ subroutine enthalpy_adjustment(ncol, lchnk, state, cam_in, cam_out, pbuf, ztodt, ! compute total enthalpy flux enthalpy_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) enthalpy_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & - +hevap_atm (:ncol) - water_flux_bc (:ncol) = enthalpy_prec_bc(:ncol,fliq_idx)+enthalpy_prec_bc(:ncol,fice_idx) - water_flux_ac (:ncol) = enthalpy_prec_ac(:ncol,fliq_idx)+enthalpy_prec_ac(:ncol,fice_idx) & - -cam_in%cflx(:ncol,1) + + hevap_atm(:ncol) + water_flux_bc(:ncol) = enthalpy_prec_bc(:ncol,fliq_idx)+enthalpy_prec_bc(:ncol,fice_idx) + water_flux_ac(:ncol) = enthalpy_prec_ac(:ncol,fliq_idx)+enthalpy_prec_ac(:ncol,fice_idx) & + - cam_in%cflx(:ncol,1) enthalpy_flux_atm(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & - +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & - +hevap_atm (:ncol) + + enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + + hevap_atm(:ncol) enthalpy_flux_ocn(:ncol) = enthalpy_prec_bc(:ncol,hliq_idx)+enthalpy_prec_bc(:ncol,hice_idx) & - +enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & - +hevap_ocn (:ncol) + + enthalpy_prec_ac(:ncol,hliq_idx)+enthalpy_prec_ac(:ncol,hice_idx) & + + hevap_ocn(:ncol) enthalpy_flux_ocn(:ncol) = cam_in%ocnfrac(:ncol)*enthalpy_flux_ocn(:ncol) if (debug_enthalpy) then From e22b1caf598842be99bfb3e6fd1d84f3dd325134 Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 13 Oct 2025 12:04:43 +0200 Subject: [PATCH 76/78] updated atmos_phys --- .gitmodules | 2 +- src/atmos_phys | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 2e549d3be1..e7406cb32e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -33,7 +33,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/mvertens/atmospheric_physics - fxtag = ed27140 + fxtag = 606f3b0 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/atmospheric_physics diff --git a/src/atmos_phys b/src/atmos_phys index ed27140499..606f3b01cf 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit ed271404999d1df4d89b8535b4dd14dd0dc0e8d4 +Subproject commit 606f3b01cfdc135c1ce8df6e69a8a5c8346f9a46 From 8b14205c7ef723514c365c8b22e529383f19c65a Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 21 Oct 2025 11:01:31 +0200 Subject: [PATCH 77/78] updated atmos_phys --- .gitmodules | 2 +- src/atmos_phys | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index e7406cb32e..6e2298f236 100644 --- a/.gitmodules +++ b/.gitmodules @@ -33,7 +33,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/mvertens/atmospheric_physics - fxtag = 606f3b0 + fxtag = 84645d5 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/atmospheric_physics diff --git a/src/atmos_phys b/src/atmos_phys index 606f3b01cf..84645d50e8 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 606f3b01cfdc135c1ce8df6e69a8a5c8346f9a46 +Subproject commit 84645d50e8d29824696d2ccb428b1b8dec9fd4dc From 022cadee8e338eb03709f8717ceeb553565f9803 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 21 Oct 2025 18:09:48 +0200 Subject: [PATCH 78/78] updates for oslo_aero and atmos_phys --- .gitmodules | 4 ++-- src/atmos_phys | 2 +- src/chemistry/oslo_aero | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6e2298f236..f49ccae8d1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -33,7 +33,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/mvertens/atmospheric_physics - fxtag = 84645d5 + fxtag = 339524f fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/atmospheric_physics @@ -77,7 +77,7 @@ [submodule "oslo_aero"] path = src/chemistry/oslo_aero url = https://github.com/mvertens/OSLO_AERO - fxtag = 442f15b + fxtag = 55cd786 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/NorESMhub/OSLO_AERO.git diff --git a/src/atmos_phys b/src/atmos_phys index 84645d50e8..339524f0d7 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 84645d50e8d29824696d2ccb428b1b8dec9fd4dc +Subproject commit 339524f0d7bae50669de9cc651fd5bbc2252ae87 diff --git a/src/chemistry/oslo_aero b/src/chemistry/oslo_aero index 0c99adb327..55cd786ca0 160000 --- a/src/chemistry/oslo_aero +++ b/src/chemistry/oslo_aero @@ -1 +1 @@ -Subproject commit 0c99adb32794b3cec92766b4efbce9f0241dde44 +Subproject commit 55cd786ca0c6b0f3e2603b8d9b2464626ff5f743