diff --git a/bld/build-namelist b/bld/build-namelist index 3891571b67..fa0ad27b52 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'); @@ -3891,6 +3892,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 111dc05182..201158b170 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2787,6 +2787,14 @@ See https://github.com/NorESMhub/noresm3_dev_simulations/discussions/78 .false. 0.5 + + 1.0 + .false. + .false. + 2e-4 + 0.1 + 6.e2 + @@ -2997,6 +3005,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 dfceec274a..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: 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). @@ -3324,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 mbar + + + +Enthalpy flux terms explicitly computed and added in atmosphere and +passed to MOM6 +Default: TRUE + + 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) @@ -1919,6 +1928,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) @@ -1993,6 +2003,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(:,:) @@ -2258,6 +2269,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) @@ -2987,6 +2999,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 @@ -3077,6 +3090,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 @@ -3569,6 +3583,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/air_composition.F90 b/src/physics/camnor_phys/physics/air_composition.F90 new file mode 100644 index 0000000000..6a32020b10 --- /dev/null +++ b/src/physics/camnor_phys/physics/air_composition.F90 @@ -0,0 +1,1287 @@ +! 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/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..12e0ac3c99 --- /dev/null +++ b/src/physics/camnor_phys/physics/check_energy.F90 @@ -0,0 +1,1178 @@ + +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=.true. + 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) 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 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/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