diff --git a/GFDL_tools/fv_ada_nudge.F90 b/GFDL_tools/fv_ada_nudge.F90 index 72b04da6c..3ff65e2fc 100644 --- a/GFDL_tools/fv_ada_nudge.F90 +++ b/GFDL_tools/fv_ada_nudge.F90 @@ -52,7 +52,7 @@ module fv_ada_nudge_mod use fv_grid_utils_mod, only: latlon2xyz, vect_cross, normalize_vect use fv_diagnostics_mod,only: prt_maxmin, fv_time use tp_core_mod, only: copy_corners - use fv_mapz_mod, only: mappm + use fv_operators_mod, only: mappm use fv_mp_mod, only: mp_reduce_sum, mp_reduce_min, mp_reduce_max, is_master use fv_timing_mod, only: timing_on, timing_off diff --git a/GFDL_tools/fv_climate_nudge.F90 b/GFDL_tools/fv_climate_nudge.F90 index 41cfd1134..5ae051468 100644 --- a/GFDL_tools/fv_climate_nudge.F90 +++ b/GFDL_tools/fv_climate_nudge.F90 @@ -38,7 +38,7 @@ module fv_climate_nudge_mod use get_cal_time_mod, only: get_cal_time use mpp_mod, only: mpp_min, mpp_max use constants_mod, only: RDGAS, RVGAS, PI, KAPPA, CP_AIR -use fv_mapz_mod, only: mappm +use fv_operators_mod, only: mappm implicit none private diff --git a/README.md b/README.md index 578bfe421..c6fe71d90 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # GFDL_atmos_cubed_sphere -The source contained herein reflects the 202305 release of the Finite Volume Cubed-Sphere Dynamical Core (FV3) from GFDL +The source contained herein reflects the 202411 release of the Finite Volume Cubed-Sphere Dynamical Core (FV3) from GFDL The GFDL Microphysics is also available within this repository. diff --git a/RELEASE.md b/RELEASE.md index f07465102..97777336f 100644 --- a/RELEASE.md +++ b/RELEASE.md @@ -1,11 +1,82 @@ +# RELEASE NOTES for FV3 202411: Summary +FV3-202411-public --- November 2024 +Primary Point of Contact: Lucas Harris, GFDL lucas.harris@noaa.gov + +This version has been tested with: +SHiELD physics release FV3-202411-public from https://github.com/NOAA-GFDL/SHiELD_physics +FMS release 2024.03 from https://github.com/NOAA-GFDL/FMS +FMS Coupler release 2024.03.01 from https://github.com/NOAA-GFDL/FMScoupler +Atmos Drivers release FV3-202411-public from https://github.com/NOAA-GFDL/atmos_drivers + +This release includes the following: +- Numerics updates (Lucas, Joseph, Linjiong): + - Removed `USE_COND` and `MOIST_CAPPA` compiler directives and replaced with runtime options `use_cond` and `moist_kappa` in the new namelist `fv_thermo_nml`. Both default to `.T.` in nonhydrostatic simulation and `.F.` in hydrostatic. + - Added a simple limiter to prevent dissipative heating from creating spurious cooling. Set `prevent_diss_cooling = .F.` to turn off. + - Fixed bugs in hydrostatic nesting for west and east BCs in `setup_pt_BC_k()` and calculated true pressure in BCs if no BC remapping is done (compute_peBC, compute_peBC_k). + - Revision of `Lagrangian_to_Eulerian` to fix variable dimension mismatch. + - Revision of FV3's dissipation heating `diss_est` option to improve numerical consistency with other dissipation options. + - Fixed edge noise for hord 6 and 7 (suggested by Bill Putman, GMAO). + - Add mixed precision compilation mode to support 32bit FV3 with other 64bit components (with Uriel Ramirez). + - New tracers: + - `w_diff` to allow subgrid mixing of vertical velocity by physics. This requires compiling with the option `-DW_DIFF` to enable. + - `pbl_age` and `tro_pbl_age` tracers representing the age of air since leaving the PBL and tropical PBL, respectively. + - Removed obsolete clock tracers + - Refer to `docs/HOWTO_tracer-2024.11.md` for more information +- GFDL Microphysics updates (Linjiong) + - Included fast microphysics tendencies diagnostics + - Added two namelist options (`fast_fr_mlt` and `fast_dep_sub`) to control freezing/melting and deposition/sublimation in the fast microphysics. + - Included a missing term in the energy conservation formula (credit: Tristan Abbott). May affect prediction of processes depending strongly on microphysics. Compile the model with `-DENG_CNV_OLD` to revert this change. + - Added a namelist option, `prog_cin`, to define the source of CIN (cloud ice nuclei) concentration. This is similar to `prog_ccn` but for ice nuclei. + - Added diagnostics for cloud content and cloud effective radii of all cloud hydrometeors (qc*, re*). + - Added diagnostics for microphysical process rates (mpp*). + - Removed unused Keihl et al. (1994) cloud water effective radius diagnosis +- Driver update (Joseph): + - Implemented a new atmosphere driver to run SHiELD and SHiEMOM with the full FMScoupler. +- Updates to $2\delta z$ filter (fv_sg) (Lucas, Linjiong): + - Included a missing term in the energy conservation formula (credit: Tristan Abbott). May affect prediction of processes depending strongly on microphysics. Compile the model with `-DENG_CNV_OLD` to revert this change. + - Added option, `fv_sg_adj_weak`, to apply a weaker 2dz filter below sg_cutoff. This may be useful in controlling tropospheric instabilities without interfering with the behavior of the PBL scheme. + - Renamed routines and eliminated ifdefs for SHiELD vs. AM4 versions. +- Physics interface updates (Linjiong, Kai, Spencer): + - Fixed negative tracers in the dynamics-physics interface. + - Enhanced the fill_gfs function to remove negative tracers. + - Enabled data_override for nest domain + - Fixed a precipitation diagnostic issue when `ntimes > 1` in the GFDL MP. + - MPI fix for sedimentation mass transport in GFDL MP. +- Updates to nudging (Lucas): + - Added an option to turn TC breeding off. + - Bugfixes for nudging on a nest/regional domain (in which tendencies in the halo are undefined). +- Coarse-graining updates (Spencer, Kai): + - Added options `strategy = 'pressure_level_extrapolate' ’blended_area_weighted’` (developed with support from Chris Bretherton, AI2), and simplest `model_level_area_weighted` (like FREgrid first-order conservative scheme). + - Renamed `model_level` strategy to `model_level_mass_weighted`. + - Coarse-grained plev diagnostics for u, v, w, omega, vorticity, height, temperature, tracers, and RH. + - Coarse-grained plev diagnostics use plevs defined in coarse-grained plev diagnostics for `fv_diag_plevs_nml` + - OpenMP multi-threaded calculations +- Code refactors (Lucas): + - Cleaned up `external_ic_nml` and `fv_surf_map_nml`. + - Cleaned up `fv_mapz.F90` to move vertical remapping operators and thermodynamics/energetics routines into their own modules +- Diagnostics (Lucas, Linjiong, Kai, Spencer): + - Fixes for nudging and fv_sg diagnostics + - Cleaned up fv_diagnostics stdout messages + - True instantaneous and timestep-mean divergence and dissipative heating. + - 40 dBz reflectivity height diagnostic. + - Dissipative heating and dissipation estimate as, even if stochastic physics isn't enabled. + - Introduced a flag `PRT_LEVEL` (now hard-coded) to control which min/max fields are written to stdout. + - Fixed a bug for CAPE/CIN/BRN when nonhydrostatic pressure perturbation is also being output. + - Refactor of plev and standard pressure level diagnostics, added new variables (vort, theta, theta_e, w, RH, dew point) to plevs, and removed unnecessary arguments to cs3_interpolator +- Deprecated/removed options (Lucas): + - Removed outdated options: scale_z, w_max, w_limiter, z_min, d2_divg_max_k[12], damp_k_k[12], old_divg_damp, do_am4_remap, use_new_ncep, use_ncep_phy, a2b_ord, c2l_ord. + - Interpolation from cell-means to corner values (a2b) and from local staggered winds to A-grid lat-lon winds, have been hard-coded to be fourth-order, except where it had previously been hard-coded to be second-order. Supporting codes have been cleaned up. + - Deprecation notice for conserve_ke + - Added warning messages for poorly-chosen advection scheme options (hord_xx), and a FATAL is thrown for invalid scheme choices. + + # RELEASE NOTES for FV3 202305: Summary -FV3-202305-public --- May 2023 -Lucas Harris, GFDL lucas.harris@noaa.gov +FV3-202305-public --- May 2023 +Lucas Harris, GFDL lucas.harris@noaa.gov This version has been tested with SHiELD physics release 202305 and with FMS release 2023.01 from https://github.com/NOAA-GFDL/FMS -This release includes the following: - Revised Vertical Remapping Operators (Lucas) - kord=10 reverted back to AM4 version. - Post-AM4 version of kord=10 is now kord=12. @@ -41,8 +112,8 @@ This release includes the following: # RELEASE NOTES for FV3 202210: Summary -FV3-202210-public --- October 2022 -Lucas Harris, GFDL lucas.harris@noaa.gov +FV3-202210-public --- October 2022 +Lucas Harris, GFDL lucas.harris@noaa.gov This version has been tested with SHiELD physics release 202210 and with FMS release 2022.03 from https://github.com/NOAA-GFDL/FMS @@ -57,8 +128,8 @@ This release includes the following: # RELEASE NOTES for FV3 202204: Summary -FV3-202204-public --- April 2022 -Lucas Harris, GFDL lucas.harris@noaa.gov +FV3-202204-public --- April 2022 +Lucas Harris, GFDL lucas.harris@noaa.gov This version has been tested against the current SHiELD physics and with FMS release 2022.01 from https://github.com/NOAA-GFDL/FMS @@ -83,8 +154,8 @@ This release includes the following: # RELEASE NOTES for FV3 202107: Summary -FV3-202107-public --- 08 July 2021 -Lucas Harris, GFDL lucas.harris@noaa.gov +FV3-202107-public --- 08 July 2021 +Lucas Harris, GFDL lucas.harris@noaa.gov This version has been tested against the current SHiELD physics and with FMS release 2021.02 from https://github.com/NOAA-GFDL/FMS @@ -102,8 +173,8 @@ This release includes the following: # RELEASE NOTES for FV3 202101: Summary -FV3-202101-public --- 22 January 2021 -Lucas Harris, GFDL +FV3-202101-public --- 22 January 2021 +Lucas Harris, GFDL This version has been tested against the current SHiELD (formerly fvGFS) physics and with FMS release candidate 2020.04 from https://github.com/NOAA-GFDL/FMS diff --git a/docs/HOWTO_tracer-2024.11.md b/docs/HOWTO_tracer-2024.11.md new file mode 100644 index 000000000..b0f4f266f --- /dev/null +++ b/docs/HOWTO_tracer-2024.11.md @@ -0,0 +1,20 @@ +NOTE: these tracers are not specific ratios and so should not be mass-adjusted. +To activate, add the following to your field_table: + +``` + "TRACER", "atmos_mod", "w_diff" + "longname", "w_diff" + "units", "m/s" + "adjust_mass", "false" + "profile_type", "fixed", "surface_value=0" / + "TRACER", "atmos_mod", "pbl_age" + "longname", "Age of air from PBL" + "units", "d" + "adjust_mass", "false" + "profile_type", "fixed", "surface_value=0." / + "TRACER", "atmos_mod", "tro_pbl_age" + "longname", "Age of air from tropical PBL" + "units", "d" + "adjust_mass", "false" + "profile_type", "fixed", "surface_value=0." / +``` diff --git a/driver/GFDL/atmosphere.F90 b/driver/GFDL/atmosphere.F90 index 54047e49c..ad5ded943 100644 --- a/driver/GFDL/atmosphere.F90 +++ b/driver/GFDL/atmosphere.F90 @@ -77,7 +77,7 @@ module atmosphere_mod use fv_restart_mod, only: fv_restart, fv_write_restart use fv_timing_mod, only: timing_on, timing_off, timing_init, timing_prt use fv_mp_mod, only: is_master -use fv_sg_mod, only: fv_subgrid_z +use fv_sg_mod, only: fv_sg_AM5 use fv_update_phys_mod, only: fv_update_phys use fv_io_mod, only: fv_io_register_nudge_restart use fv_regional_mod, only: start_regional_restart, read_new_bc_data @@ -166,7 +166,7 @@ module atmosphere_mod real, parameter:: w0_big = 60. ! to prevent negative w-tracer diffusion -!---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys +!---dynamics tendencies for use in fv_sg and during fv_update_phys real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt, qv_dt real, allocatable, dimension(:,:,:,:) :: q_dt real, allocatable :: pref(:,:), dum1d(:) @@ -638,11 +638,11 @@ subroutine atmosphere_dynamics ( Time, Surf_diff ) Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, & Atm(n)%vc, Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, & Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, & - Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, & + Atm(n)%flagstruct%hybrid_z, Atm(n)%gridstruct, & + Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, & Atm(n)%parent_grid, Atm(n)%domain, Atm(n)%inline_mp, & - Atm(n)%diss_est) + Atm(n)%heat_source, Atm(n)%diss_est) call timing_off('FV_DYNAMICS') if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then @@ -713,10 +713,10 @@ subroutine atmosphere_dynamics ( Time, Surf_diff ) call timing_on('FV_SUBGRID_Z') - u_dt(:,:,:) = 0. ! These are updated by fv_subgrid_z + u_dt(:,:,:) = 0. ! These are updated by fv_sg_AM5 v_dt(:,:,:) = 0. ! t_dt is used for two different purposes: -! 1 - to calculate the diagnostic temperature tendency from fv_subgrid_z +! 1 - to calculate the diagnostic temperature tendency from fv_sg_AM5 ! 2 - as an accumulator for the IAU increment and physics tendency ! because of this, it will need to be zeroed out after the diagnostic is calculated t_dt(:,:,:) = Atm(n)%pt(isc:iec,jsc:jec,:) @@ -731,7 +731,7 @@ subroutine atmosphere_dynamics ( Time, Surf_diff ) if ( w_diff /= NO_TRACER ) then nt_dyn = nq - 1 endif - call fv_subgrid_z(isd, ied, jsd, jed, isc, iec, jsc, jec, Atm(n)%npz, & + call fv_sg_AM5(isd, ied, jsd, jed, isc, iec, jsc, jec, Atm(n)%npz, & nt_dyn, dt_atmos, Atm(n)%flagstruct%fv_sg_adj, & Atm(n)%flagstruct%nwat, Atm(n)%delp, Atm(n)%pe, & Atm(n)%peln, Atm(n)%pkz, Atm(n)%pt, Atm(n)%q, & @@ -1322,9 +1322,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(n)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source, Atm(mygrid)%diss_est) ! Backward call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, -dt_atmos, 0., & Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -1336,9 +1336,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(n)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source, Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mygrid, nudge_dz, dz0) & @@ -1408,9 +1408,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(n)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source, Atm(mygrid)%diss_est) ! Forward call call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, dt_atmos, 0., & Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -1422,9 +1422,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(n)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source, Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mygrid) & @@ -1508,12 +1508,9 @@ subroutine atmos_physics_driver_inputs (Physics, Atm_block, Physics_tendency) Physics%block(nb)%t, Physics%block(nb)%q(:,:,:,Physics%control%sphum), & Physics%block(nb)%p_full, Physics%block(nb)%p_half, & Physics%block(nb)%z_full, Physics%block(nb)%z_half, & -#ifdef USE_COND - Atm(mygrid)%q_con(ibs:ibe,jbs:jbe,:), & -#else - Atm(mygrid)%q_con, & -#endif - Physics%control%phys_hydrostatic, Physics%control%do_uni_zfull) !miz + Atm(mygrid)%q_con, & !This should work; indices are same on block as on full PE + Physics%control%phys_hydrostatic, Physics%control%do_uni_zfull, & !miz + Atm(mygrid)%thermostruct%use_cond) if (PRESENT(Physics_tendency)) then !--- copy the dynamics tendencies into the physics tendencies @@ -1563,12 +1560,9 @@ subroutine atmos_radiation_driver_inputs (Time, Radiation, Atm_block) Radiation%block(nb)%t, Radiation%block(nb)%q(:,:,:,Radiation%control%sphum), & Radiation%block(nb)%p_full, Radiation%block(nb)%p_half, & Radiation%block(nb)%z_full, Radiation%block(nb)%z_half, & -#ifdef USE_COND - Atm(mygrid)%q_con(ibs:ibe,jbs:jbe,:), & -#else - Atm(mygrid)%q_con, & -#endif - Radiation%control%phys_hydrostatic, Radiation%control%do_uni_zfull) !miz + Atm(mygrid)%q_con, & !This should work; indices are same on block as on full PE + Radiation%control%phys_hydrostatic, Radiation%control%do_uni_zfull, & !miz + Atm(mygrid)%thermostruct%use_cond) enddo !---------------------------------------------------------------------- @@ -1587,20 +1581,19 @@ end subroutine atmos_radiation_driver_inputs subroutine fv_compute_p_z (npz, phis, pe, peln, delp, delz, pt, q_sph, & - p_full, p_half, z_full, z_half, q_con, hydrostatic, do_uni_zfull) !miz + p_full, p_half, z_full, z_half, q_con, hydrostatic, & + use_cond, do_uni_zfull) !miz integer, intent(in) :: npz real, dimension(:,:), intent(in) :: phis real, dimension(:,:,:), intent(in) :: pe, peln, delp, delz, q_con, pt, q_sph real, dimension(:,:,:), intent(out) :: p_full, p_half, z_full, z_half - logical, intent(in) :: hydrostatic, do_uni_zfull !miz + logical, intent(in) :: hydrostatic, do_uni_zfull, use_cond !miz !--- local variables integer i,j,k,isiz,jsiz real tvm real :: zvir, rrg, ginv -#ifdef USE_COND - real, dimension(size(pe,1),size(pe,3),size(pe,2)):: peg, pelng + real, allocatable, dimension(:,:,:) :: peg, pelng real:: dlg -#endif isiz=size(phis,1) jsiz=size(phis,2) @@ -1608,6 +1601,11 @@ subroutine fv_compute_p_z (npz, phis, pe, peln, delp, delz, pt, q_sph, & ginv = 1./ grav rrg = rdgas / grav + if (use_cond) then + allocate(peg(size(pe,1),size(pe,3),size(pe,2))) + allocate(pelng(size(pe,1),size(pe,3),size(pe,2))) + endif + !---------------------------------------------------- ! Compute pressure and height at full and half levels !---------------------------------------------------- @@ -1623,36 +1621,43 @@ subroutine fv_compute_p_z (npz, phis, pe, peln, delp, delz, pt, q_sph, & !--------- Hydrostatic option ---------------------------------------------- if (hydrostatic ) then -#ifdef USE_COND - do j=1,jsiz - do i=1,isiz - peg(i,j,1) = pe(i,1,j) - enddo - end do - do k=2,npz+1 - do j=1,jsiz + if (use_cond) then + do j=1,jsiz + do i=1,isiz + peg(i,j,1) = pe(i,1,j) + enddo + end do + do k=2,npz+1 + do j=1,jsiz do i=1,isiz peg(i,j,k) = peg(i,j,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) enddo - enddo - enddo -#endif - do k=npz,1,-1 - do j=1,jsiz + enddo + enddo + + do k=npz,1,-1 + do j=1,jsiz do i=1,isiz tvm = rrg*pt(i,j,k)*(1.+zvir*q_sph(i,j,k)) p_full(i,j,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -#ifdef USE_COND dlg = log(peg(i,j,k+1)/peg(i,j,k)) z_full(i,j,k) = z_half(i,j,k+1) + tvm*(1.-peg(i,j,k)*dlg/(peg(i,j,k+1)-peg(i,j,k))) z_half(i,j,k) = z_half(i,j,k+1) + tvm*dlg -#else + enddo + enddo + enddo + else + do k=npz,1,-1 + do j=1,jsiz + do i=1,isiz + tvm = rrg*pt(i,j,k)*(1.+zvir*q_sph(i,j,k)) + p_full(i,j,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) z_full(i,j,k) = z_half(i,j,k+1) + tvm*(1.-p_half(i,j,k)/p_full(i,j,k)) z_half(i,j,k) = z_half(i,j,k+1) + tvm*(peln(i,k+1,j)-peln(i,k,j)) -#endif enddo - enddo - enddo + enddo + enddo + endif else !--------- Non-Hydrostatic option ------------------------------------------ do k=npz,1,-1 @@ -1670,6 +1675,9 @@ subroutine fv_compute_p_z (npz, phis, pe, peln, delp, delz, pt, q_sph, & z_full(:,:,k)=0.5*(z_half(:,:,k)+z_half(:,:,k+1)) enddo endif + + if (use_cond) deallocate(peg,pelng) + end subroutine fv_compute_p_z diff --git a/driver/SHiELD/atmosphere.F90 b/driver/SHiELD/atmosphere.F90 index eb4c19474..b36918248 100644 --- a/driver/SHiELD/atmosphere.F90 +++ b/driver/SHiELD/atmosphere.F90 @@ -72,7 +72,7 @@ module atmosphere_mod use fv_restart_mod, only: fv_restart, fv_write_restart use fv_timing_mod, only: timing_on, timing_off, timing_init, timing_prt use fv_mp_mod, only: is_master -use fv_sg_mod, only: fv_subgrid_z +use fv_sg_mod, only: fv_sg_SHiELD use fv_update_phys_mod, only: fv_update_phys use fv_io_mod, only: fv_io_register_nudge_restart use fv_nwp_nudge_mod, only: fv_nwp_nudge_init, fv_nwp_nudge_end, do_adiabatic_init @@ -146,9 +146,9 @@ module atmosphere_mod integer :: id_udt_dyn, id_vdt_dyn - real, parameter:: w0_big = 60. ! to prevent negative w-tracer diffusion + real, parameter:: w0_big = 200. ! to prevent negative w-tracer diffusion -!---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys +!---dynamics tendencies for use in fv_sg and during fv_update_phys real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt, qv_dt real, allocatable :: pref(:,:), dum1d(:), ps_dt(:,:) @@ -337,7 +337,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data ! --- initiate the start for a restarted regional forecast if ( Atm(mygrid)%gridstruct%regional .and. Atm(mygrid)%flagstruct%warm_start ) then - call start_regional_restart(Atm(1), & + call start_regional_restart(Atm(1), & !should be mygrid instead of 1??? isc, iec, jsc, jec, & isd, ied, jsd, jed ) endif @@ -372,8 +372,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data endif #endif - if ( trim(Atm(mygrid)%flagstruct%grid_file) .NE. "Inline" .and. trim(Atm(mygrid)%flagstruct%grid_file) .NE. "" & - & .and. .NOT.Atm(mygrid)%gridstruct%bounded_domain ) then + if ( trim(Atm(mygrid)%flagstruct%grid_file) .NE. "Inline" .and. trim(Atm(mygrid)%flagstruct%grid_file) .NE. "" ) then call data_override_init(Atm_domain_in = Atm(mygrid)%domain) endif @@ -493,11 +492,11 @@ subroutine atmosphere_dynamics ( Time ) Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, & Atm(n)%vc, Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, & Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, & - Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, & + Atm(n)%flagstruct%hybrid_z, Atm(n)%gridstruct, & + Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, & Atm(n)%parent_grid, Atm(n)%domain, Atm(n)%inline_mp, & - Atm(n)%diss_est,time_total=time_total) + Atm(n)%heat_source,Atm(n)%diss_est,time_total=time_total) call timing_off('FV_DYNAMICS') @@ -530,16 +529,16 @@ subroutine atmosphere_dynamics ( Time ) call mpp_clock_begin (id_subgrid) !----------------------------------------------------- -!--- COMPUTE SUBGRID Z +!--- COMPUTE SUBGRID Z (fv_sg) !----------------------------------------------------- !--- zero out tendencies call timing_on('FV_SUBGRID_Z') - u_dt(:,:,:) = 0. ! These are updated by fv_subgrid_z + u_dt(:,:,:) = 0. ! These are updated by fv_sg v_dt(:,:,:) = 0. ! t_dt is used for two different purposes: -! 1 - to calculate the diagnostic temperature tendency from fv_subgrid_z +! 1 - to calculate the diagnostic temperature tendency from fv_sg ! 2 - as an accumulator for the IAU increment and physics tendency ! because of this, it will need to be zeroed out after the diagnostic is calculated t_dt(:,:,:) = Atm(n)%pt(isc:iec,jsc:jec,:) @@ -553,25 +552,24 @@ subroutine atmosphere_dynamics ( Time ) if ( w_diff /= NO_TRACER ) then nt_dyn = nq - 1 endif - call fv_subgrid_z(isd, ied, jsd, jed, isc, iec, jsc, jec, Atm(n)%npz, & + call fv_sg_SHiELD(isd, ied, jsd, jed, isc, iec, jsc, jec, Atm(n)%npz, & nt_dyn, dt_atmos, Atm(n)%flagstruct%fv_sg_adj, & + Atm(n)%flagstruct%fv_sg_adj_weak, & Atm(n)%flagstruct%nwat, Atm(n)%delp, Atm(n)%pe, & Atm(n)%peln, Atm(n)%pkz, Atm(n)%pt, Atm(n)%q, & Atm(n)%ua, Atm(n)%va, Atm(n)%flagstruct%hydrostatic,& - Atm(n)%w, Atm(n)%delz, u_dt, v_dt, t_dt, Atm(n)%flagstruct%n_sponge) + Atm(n)%w, Atm(n)%delz, u_dt, v_dt, Atm(n)%flagstruct%n_sponge) endif -#ifdef USE_Q_DT + !Only active if w_diff is defined if ( .not. Atm(n)%flagstruct%hydrostatic .and. w_diff /= NO_TRACER ) then !$OMP parallel do default (none) & -!$OMP shared (isc, iec, jsc, jec, w_diff, n, Atm, q_dt) & +!$OMP shared (isc, iec, jsc, jec, w_diff, n, Atm) & !$OMP private (k) do k=1, Atm(n)%npz Atm(n)%q(isc:iec,jsc:jec,k,w_diff) = Atm(n)%w(isc:iec,jsc:jec,k) + w0_big - q_dt(:,:,k,w_diff) = 0. - enddo + enddo endif -#endif if (allocated(Atm(n)%sg_diag%u_dt)) then Atm(n)%sg_diag%u_dt = u_dt(isc:iec,jsc:jec,:) @@ -580,11 +578,11 @@ subroutine atmosphere_dynamics ( Time ) Atm(n)%sg_diag%v_dt = v_dt(isc:iec,jsc:jec,:) endif if (allocated(Atm(n)%sg_diag%t_dt)) then - t_dt(:,:,:) = rdt*(Atm(1)%pt(isc:iec,jsc:jec,:) - t_dt(:,:,:)) + t_dt(:,:,:) = rdt*(Atm(n)%pt(isc:iec,jsc:jec,:) - t_dt(:,:,:)) Atm(n)%sg_diag%t_dt = t_dt(isc:iec,jsc:jec,:) endif if (allocated(Atm(n)%sg_diag%qv_dt)) then - qv_dt(:,:,:) = rdt*(Atm(1)%q(isc:iec,jsc:jec,:,sphum) - qv_dt(:,:,:)) + qv_dt(:,:,:) = rdt*(Atm(n)%q(isc:iec,jsc:jec,:,sphum) - qv_dt(:,:,:)) Atm(n)%sg_diag%qv_dt = qv_dt(isc:iec,jsc:jec,:) endif @@ -1195,6 +1193,7 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) real(kind=kind_phys):: rcp, q0, qwat(nq), qt, rdt real :: psum, qsum, psumb, qsumb, betad, psdt_mean real :: tracer_clock, lat_thresh, fhr + real :: t_aging, t_relax character(len=32) :: tracer_name call timing_on('ATMOS_UPDATE') @@ -1277,7 +1276,11 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) !SJL: perform vertical filling to fix the negative humidity if the SAS convection scheme is used ! This call may be commented out if RAS or other positivity-preserving CPS is used. blen = Atm_block%blksz(nb) - if (Atm(n)%flagstruct%fill_gfs) call fill_gfs(blen, npz, IPD_Data(nb)%Statein%prsi, IPD_Data(nb)%Stateout%gq0, 1.e-9_kind_phys) + if (Atm(n)%flagstruct%fill_gfs) then + do iq = 1, nq + call fill_gfs(blen, npz, IPD_Data(nb)%Statein%prsi, IPD_Data(nb)%Stateout%gq0(:,:,iq)) + enddo + endif !LMH 28sep18: If the name of a tracer ends in 'nopbl' then do NOT update it; !override this by setting Stateout%gq0(:,:,iq) to the input value @@ -1375,25 +1378,25 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) endif !--- adjust w and heat tendency for non-hydrostatic case -#ifdef USE_Q_DT if ( .not.Atm(n)%flagstruct%hydrostatic .and. w_diff /= NO_TRACER ) then rcp = 1. / cp_air !$OMP parallel do default (none) & -!$OMP shared (jsc, jec, isc, iec, n, w_diff, Atm, q_dt, t_dt, rcp, dt_atmos) & -!$OMP private (i, j, k) +!$OMP shared (jsc, jec, isc, iec, n, w_diff, Atm, t_dt, & +!$OMP rcp, dt_atmos, nb, IPD_Data, ix, Atm_block) & +!$OMP private (i, j, k, k1, blen) do k=1, Atm(n)%npz - do j=jsc, jec - do i=isc, iec - Atm(n)%q(i,j,k,w_diff) = q_dt(i,j,k,w_diff) ! w tendency due to phys -! Heating due to loss of KE (vertical diffusion of w) - t_dt(i,j,k) = t_dt(i,j,k) - q_dt(i,j,k,w_diff)*rcp*& - (Atm(n)%w(i,j,k)+0.5*dt_atmos*q_dt(i,j,k,w_diff)) - Atm(n)%w(i,j,k) = Atm(n)%w(i,j,k) + dt_atmos*Atm(n)%q(i,j,k,w_diff) - enddo - enddo - enddo + k1 = Atm(n)%npz+1-k !reverse the k direction + do ix = 1, blen + i = Atm_block%index(nb)%ii(ix) + j = Atm_block%index(nb)%jj(ix) + !Atm(n)%q(i,j,k,w_diff) = q_dt(i,j,k,w_diff) ! w tendency due to phys + ! Heating due to loss of KE (vertical diffusion of w) + !t_dt(i,j,k) = t_dt(i,j,k) - q_dt(i,j,k,w_diff)*rcp*& + ! (Atm(n)%w(i,j,k)+0.5*dt_atmos*q_dt(i,j,k,w_diff)) + Atm(n)%w(i,j,k1) = IPD_Data(nb)%Stateout%gq0(ix,k,w_diff) - w0_big !Atm(n)%w(i,j,k) + dt_atmos*Atm(n)%q(i,j,k,w_diff) + enddo + enddo endif -#endif call timing_on('FV_UPDATE_PHYS') call fv_update_phys( dt_atmos, isc, iec, jsc, jec, isd, ied, jsd, jed, Atm(n)%ng, nt_dyn, & @@ -1423,43 +1426,36 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) enddo enddo -!LMH 7jan2020: Update PBL and other clock tracers, if present - tracer_clock = time_type_to_real(Time_next - Atm(n)%Time_init)*1.e-6 +!Age of (PBL) air tracers --- lmh 21feb24 lat_thresh = 15.*pi/180. + t_aging = dt_atmos/86400. !days + t_relax = exp(-dt_atmos/3600.) !e-folding of 1 hour do iq = 1, nq call get_tracer_names (MODEL_ATMOS, iq, tracer_name) - if (trim(tracer_name) == 'pbl_clock' .or. trim(tracer_name) == 'tro_pbl_clock') then + if (trim(tracer_name) == 'pbl_age' .or. trim(tracer_name) == 'tro_pbl_age') then do nb = 1,Atm_block%nblks blen = Atm_block%blksz(nb) do ix = 1, blen i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) - if (trim(tracer_name) == 'tro_pbl_clock' .and. abs(Atm(n)%gridstruct%agrid(i,j,2)) > lat_thresh) cycle - do k=1,npz - k1 = npz+1-k !reverse the k direction - Atm(n)%q(i,j,k1,iq) = tracer_clock - if (IPD_Data(nb)%Statein%phii(ix,k) > IPD_Data(nb)%intdiag%hpbl(ix)*grav) exit - enddo + if (trim(tracer_name) == 'tro_pbl_age' .and. abs(Atm(n)%gridstruct%agrid(i,j,2)) > lat_thresh) then + do k=1,npz + Atm(n)%q(i,j,k,iq) = Atm(n)%q(i,j,k,iq) + t_aging + enddo + else + do k=1,npz + k1 = npz+1-k !reverse the k direction + if (IPD_Data(nb)%Statein%phii(ix,k) > IPD_Data(nb)%intdiag%hpbl(ix)*grav) then + Atm(n)%q(i,j,k1,iq) = Atm(n)%q(i,j,k1,iq) + t_aging + else !source region + Atm(n)%q(i,j,k1,iq) = Atm(n)%q(i,j,k1,iq)*t_relax + endif + enddo + endif enddo enddo - else if (trim(tracer_name) == 'sfc_clock') then - do j=jsc,jec - do i=isc,iec - Atm(n)%q(i,j,npz,iq) = tracer_clock - enddo - enddo - else if (trim(tracer_name) == 'itcz_clock' ) then - do k=1,npz - do j=jsc,jec - do i=isc,iec - if (abs(Atm(n)%gridstruct%agrid(i,j,2)) < lat_thresh .and. Atm(n)%w(i,j,k) > 1.5) then - Atm(n)%q(i,j,npz,iq) = tracer_clock - endif - enddo - enddo - enddo endif - enddo + enddo !--- nesting update after updating atmospheric variables with !--- physics tendencies @@ -1594,9 +1590,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Backward call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, -dt_atmos, 0., & Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -1608,9 +1604,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mygrid, nudge_dz, dz0) & @@ -1680,9 +1676,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Forward call call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, dt_atmos, 0., & Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -1694,9 +1690,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mygrid) & diff --git a/driver/SHiELDFULL/atmosphere.F90 b/driver/SHiELDFULL/atmosphere.F90 index 47a49eb7b..db145c07d 100644 --- a/driver/SHiELDFULL/atmosphere.F90 +++ b/driver/SHiELDFULL/atmosphere.F90 @@ -79,7 +79,7 @@ module atmosphere_mod use fv_restart_mod, only: fv_restart, fv_write_restart use fv_timing_mod, only: timing_on, timing_off, timing_init, timing_prt use fv_mp_mod, only: is_master -use fv_sg_mod, only: fv_subgrid_z +use fv_sg_mod, only: fv_sg_SHiELD use fv_update_phys_mod, only: fv_update_phys use fv_io_mod, only: fv_io_register_nudge_restart use fv_nwp_nudge_mod, only: fv_nwp_nudge_init, fv_nwp_nudge_end, do_adiabatic_init @@ -185,9 +185,9 @@ module atmosphere_mod integer :: id_udt_dyn, id_vdt_dyn - real, parameter:: w0_big = 60. ! to prevent negative w-tracer diffusion + real, parameter:: w0_big = 200. ! to prevent negative w-tracer diffusion -!---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys +!---dynamics tendencies for use in fv_sg and during fv_update_phys real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt, qv_dt real, allocatable :: pref(:,:), dum1d(:), ps_dt(:,:) @@ -388,7 +388,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data ! --- initiate the start for a restarted regional forecast if ( Atm(mygrid)%gridstruct%regional .and. Atm(mygrid)%flagstruct%warm_start ) then - call start_regional_restart(Atm(1), & + call start_regional_restart(Atm(1), & !should be mygrid instead of 1??? isc, iec, jsc, jec, & isd, ied, jsd, jed ) endif @@ -423,8 +423,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data endif #endif - if ( trim(Atm(mygrid)%flagstruct%grid_file) .NE. "Inline" .and. trim(Atm(mygrid)%flagstruct%grid_file) .NE. "" & - & .and. .NOT.Atm(mygrid)%gridstruct%bounded_domain ) then + if ( trim(Atm(mygrid)%flagstruct%grid_file) .NE. "Inline" .and. trim(Atm(mygrid)%flagstruct%grid_file) .NE. "" ) then call data_override_init(Atm_domain_in = Atm(mygrid)%domain) endif @@ -544,11 +543,11 @@ subroutine atmosphere_dynamics ( Time ) Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, & Atm(n)%vc, Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, & Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, & - Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, & + Atm(n)%flagstruct%hybrid_z, Atm(n)%gridstruct, & + Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, & Atm(n)%parent_grid, Atm(n)%domain, Atm(n)%inline_mp, & - Atm(n)%diss_est,time_total=time_total) + Atm(n)%heat_source,Atm(n)%diss_est,time_total=time_total) call timing_off('FV_DYNAMICS') @@ -581,16 +580,16 @@ subroutine atmosphere_dynamics ( Time ) call mpp_clock_begin (id_subgrid) !----------------------------------------------------- -!--- COMPUTE SUBGRID Z +!--- COMPUTE SUBGRID Z (fv_sg) !----------------------------------------------------- !--- zero out tendencies call timing_on('FV_SUBGRID_Z') - u_dt(:,:,:) = 0. ! These are updated by fv_subgrid_z + u_dt(:,:,:) = 0. ! These are updated by fv_sg v_dt(:,:,:) = 0. ! t_dt is used for two different purposes: -! 1 - to calculate the diagnostic temperature tendency from fv_subgrid_z +! 1 - to calculate the diagnostic temperature tendency from fv_sg ! 2 - as an accumulator for the IAU increment and physics tendency ! because of this, it will need to be zeroed out after the diagnostic is calculated t_dt(:,:,:) = Atm(n)%pt(isc:iec,jsc:jec,:) @@ -604,25 +603,24 @@ subroutine atmosphere_dynamics ( Time ) if ( w_diff /= NO_TRACER ) then nt_dyn = nq - 1 endif - call fv_subgrid_z(isd, ied, jsd, jed, isc, iec, jsc, jec, Atm(n)%npz, & + call fv_sg_SHiELD(isd, ied, jsd, jed, isc, iec, jsc, jec, Atm(n)%npz, & nt_dyn, dt_atmos, Atm(n)%flagstruct%fv_sg_adj, & + Atm(n)%flagstruct%fv_sg_adj_weak, & Atm(n)%flagstruct%nwat, Atm(n)%delp, Atm(n)%pe, & Atm(n)%peln, Atm(n)%pkz, Atm(n)%pt, Atm(n)%q, & Atm(n)%ua, Atm(n)%va, Atm(n)%flagstruct%hydrostatic,& - Atm(n)%w, Atm(n)%delz, u_dt, v_dt, t_dt, Atm(n)%flagstruct%n_sponge) + Atm(n)%w, Atm(n)%delz, u_dt, v_dt, Atm(n)%flagstruct%n_sponge) endif -#ifdef USE_Q_DT + !Only active if w_diff is defined if ( .not. Atm(n)%flagstruct%hydrostatic .and. w_diff /= NO_TRACER ) then !$OMP parallel do default (none) & -!$OMP shared (isc, iec, jsc, jec, w_diff, n, Atm, q_dt) & +!$OMP shared (isc, iec, jsc, jec, w_diff, n, Atm) & !$OMP private (k) do k=1, Atm(n)%npz Atm(n)%q(isc:iec,jsc:jec,k,w_diff) = Atm(n)%w(isc:iec,jsc:jec,k) + w0_big - q_dt(:,:,k,w_diff) = 0. - enddo + enddo endif -#endif if (allocated(Atm(n)%sg_diag%u_dt)) then Atm(n)%sg_diag%u_dt = u_dt(isc:iec,jsc:jec,:) @@ -631,11 +629,11 @@ subroutine atmosphere_dynamics ( Time ) Atm(n)%sg_diag%v_dt = v_dt(isc:iec,jsc:jec,:) endif if (allocated(Atm(n)%sg_diag%t_dt)) then - t_dt(:,:,:) = rdt*(Atm(1)%pt(isc:iec,jsc:jec,:) - t_dt(:,:,:)) + t_dt(:,:,:) = rdt*(Atm(n)%pt(isc:iec,jsc:jec,:) - t_dt(:,:,:)) Atm(n)%sg_diag%t_dt = t_dt(isc:iec,jsc:jec,:) endif if (allocated(Atm(n)%sg_diag%qv_dt)) then - qv_dt(:,:,:) = rdt*(Atm(1)%q(isc:iec,jsc:jec,:,sphum) - qv_dt(:,:,:)) + qv_dt(:,:,:) = rdt*(Atm(n)%q(isc:iec,jsc:jec,:,sphum) - qv_dt(:,:,:)) Atm(n)%sg_diag%qv_dt = qv_dt(isc:iec,jsc:jec,:) endif @@ -680,10 +678,7 @@ subroutine atmosphere_end (Time, Grid_box )!rab, Radiation, Physics) call timing_off('FV_DIAG') endif - call timing_on('FV_DIAG') - call atmos_global_diag_end call fv_end(Atm, mygrid) - call timing_off('FV_DIAG') deallocate (Atm) deallocate( u_dt, v_dt, t_dt, qv_dt, ps_dt, pref, dum1d ) @@ -1082,6 +1077,7 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) real(kind=kind_phys):: rcp, q0, qwat(nq), qt, rdt real :: psum, qsum, psumb, qsumb, betad, psdt_mean real :: tracer_clock, lat_thresh, fhr + real :: t_aging, t_relax character(len=32) :: tracer_name call timing_on('ATMOS_UPDATE') @@ -1164,7 +1160,11 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) !SJL: perform vertical filling to fix the negative humidity if the SAS convection scheme is used ! This call may be commented out if RAS or other positivity-preserving CPS is used. blen = Atm_block%blksz(nb) - if (Atm(n)%flagstruct%fill_gfs) call fill_gfs(blen, npz, IPD_Data(nb)%Statein%prsi, IPD_Data(nb)%Stateout%gq0, 1.e-9_kind_phys) + if (Atm(n)%flagstruct%fill_gfs) then + do iq = 1, nq + call fill_gfs(blen, npz, IPD_Data(nb)%Statein%prsi, IPD_Data(nb)%Stateout%gq0(:,:,iq)) + enddo + endif !LMH 28sep18: If the name of a tracer ends in 'nopbl' then do NOT update it; !override this by setting Stateout%gq0(:,:,iq) to the input value @@ -1262,25 +1262,25 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) endif !--- adjust w and heat tendency for non-hydrostatic case -#ifdef USE_Q_DT if ( .not.Atm(n)%flagstruct%hydrostatic .and. w_diff /= NO_TRACER ) then rcp = 1. / cp_air !$OMP parallel do default (none) & -!$OMP shared (jsc, jec, isc, iec, n, w_diff, Atm, q_dt, t_dt, rcp, dt_atmos) & -!$OMP private (i, j, k) +!$OMP shared (jsc, jec, isc, iec, n, w_diff, Atm, t_dt, & +!$OMP rcp, dt_atmos, nb, IPD_Data, ix, Atm_block) & +!$OMP private (i, j, k, k1, blen) do k=1, Atm(n)%npz - do j=jsc, jec - do i=isc, iec - Atm(n)%q(i,j,k,w_diff) = q_dt(i,j,k,w_diff) ! w tendency due to phys -! Heating due to loss of KE (vertical diffusion of w) - t_dt(i,j,k) = t_dt(i,j,k) - q_dt(i,j,k,w_diff)*rcp*& - (Atm(n)%w(i,j,k)+0.5*dt_atmos*q_dt(i,j,k,w_diff)) - Atm(n)%w(i,j,k) = Atm(n)%w(i,j,k) + dt_atmos*Atm(n)%q(i,j,k,w_diff) - enddo - enddo - enddo + k1 = Atm(n)%npz+1-k !reverse the k direction + do ix = 1, blen + i = Atm_block%index(nb)%ii(ix) + j = Atm_block%index(nb)%jj(ix) + !Atm(n)%q(i,j,k,w_diff) = q_dt(i,j,k,w_diff) ! w tendency due to phys + ! Heating due to loss of KE (vertical diffusion of w) + !t_dt(i,j,k) = t_dt(i,j,k) - q_dt(i,j,k,w_diff)*rcp*& + ! (Atm(n)%w(i,j,k)+0.5*dt_atmos*q_dt(i,j,k,w_diff)) + Atm(n)%w(i,j,k1) = IPD_Data(nb)%Stateout%gq0(ix,k,w_diff) - w0_big !Atm(n)%w(i,j,k) + dt_atmos*Atm(n)%q(i,j,k,w_diff) + enddo + enddo endif -#endif call timing_on('FV_UPDATE_PHYS') call fv_update_phys( dt_atmos, isc, iec, jsc, jec, isd, ied, jsd, jed, Atm(n)%ng, nt_dyn, & @@ -1310,43 +1310,36 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block) enddo enddo -!LMH 7jan2020: Update PBL and other clock tracers, if present - tracer_clock = time_type_to_real(Time_next - Atm(n)%Time_init)*1.e-6 +!Age of (PBL) air tracers --- lmh 21feb24 lat_thresh = 15.*pi/180. + t_aging = dt_atmos/86400. !days + t_relax = exp(-dt_atmos/3600.) !e-folding of 1 hour do iq = 1, nq call get_tracer_names (MODEL_ATMOS, iq, tracer_name) - if (trim(tracer_name) == 'pbl_clock' .or. trim(tracer_name) == 'tro_pbl_clock') then + if (trim(tracer_name) == 'pbl_age' .or. trim(tracer_name) == 'tro_pbl_age') then do nb = 1,Atm_block%nblks blen = Atm_block%blksz(nb) do ix = 1, blen i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) - if (trim(tracer_name) == 'tro_pbl_clock' .and. abs(Atm(n)%gridstruct%agrid(i,j,2)) > lat_thresh) cycle - do k=1,npz - k1 = npz+1-k !reverse the k direction - Atm(n)%q(i,j,k1,iq) = tracer_clock - if (IPD_Data(nb)%Statein%phii(ix,k) > IPD_Data(nb)%intdiag%hpbl(ix)*grav) exit - enddo + if (trim(tracer_name) == 'tro_pbl_age' .and. abs(Atm(n)%gridstruct%agrid(i,j,2)) > lat_thresh) then + do k=1,npz + Atm(n)%q(i,j,k,iq) = Atm(n)%q(i,j,k,iq) + t_aging + enddo + else + do k=1,npz + k1 = npz+1-k !reverse the k direction + if (IPD_Data(nb)%Statein%phii(ix,k) > IPD_Data(nb)%intdiag%hpbl(ix)*grav) then + Atm(n)%q(i,j,k1,iq) = Atm(n)%q(i,j,k1,iq) + t_aging + else !source region + Atm(n)%q(i,j,k1,iq) = Atm(n)%q(i,j,k1,iq)*t_relax + endif + enddo + endif enddo enddo - else if (trim(tracer_name) == 'sfc_clock') then - do j=jsc,jec - do i=isc,iec - Atm(n)%q(i,j,npz,iq) = tracer_clock - enddo - enddo - else if (trim(tracer_name) == 'itcz_clock' ) then - do k=1,npz - do j=jsc,jec - do i=isc,iec - if (abs(Atm(n)%gridstruct%agrid(i,j,2)) < lat_thresh .and. Atm(n)%w(i,j,k) > 1.5) then - Atm(n)%q(i,j,npz,iq) = tracer_clock - endif - enddo - enddo - enddo endif - enddo + enddo !--- nesting update after updating atmospheric variables with !--- physics tendencies @@ -1481,9 +1474,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Backward call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, -dt_atmos, 0., & Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -1495,9 +1488,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mygrid, nudge_dz, dz0) & @@ -1567,9 +1560,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Forward call call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, dt_atmos, 0., & Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -1581,9 +1574,9 @@ subroutine adiabatic_init(zvir,nudge_dz) Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & - Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & - Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & - Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%diss_est) + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, & + Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mygrid) & diff --git a/driver/solo/atmosphere.F90 b/driver/solo/atmosphere.F90 index fcc828e27..f1c8d94c9 100644 --- a/driver/solo/atmosphere.F90 +++ b/driver/solo/atmosphere.F90 @@ -157,6 +157,8 @@ subroutine atmosphere_init ( Time_init, Time, Time_step ) else zvir = rvgas/rdgas - 1. Atm(mygrid)%flagstruct%moist_phys = .true. + endif + if (.not. Atm(mygrid)%flagstruct%adiabatic .or. Atm(mygrid)%flagstruct%fv_sg_adj > 0.) then call fv_phys_init(isc,iec,jsc,jec,Atm(mygrid)%npz,Atm(mygrid)%flagstruct%nwat, Atm(mygrid)%ts, Atm(mygrid)%pt(isc:iec,jsc:jec,:), & Time, axes, Atm(mygrid)%gridstruct%agrid(isc:iec,jsc:jec,2)) endif @@ -164,25 +166,26 @@ subroutine atmosphere_init ( Time_init, Time, Time_step ) if (.not. Atm(mygrid)%flagstruct%adiabatic) call gfdl_mp_init (input_nml_file, stdlog(), Atm(mygrid)%flagstruct%hydrostatic) - if ( Atm(mygrid)%flagstruct%nudge ) & - call fv_nwp_nudge_init( Time, axes, Atm(mygrid)%npz, zvir, Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%ts, & - Atm(mygrid)%phis, Atm(mygrid)%gridstruct, Atm(mygrid)%ks, Atm(mygrid)%npx, Atm(mygrid)%neststruct, Atm(mygrid)%bd) + if ( Atm(mygrid)%flagstruct%nudge ) & + call fv_nwp_nudge_init( Time, axes, Atm(mygrid)%npz, zvir, Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%ts, & + Atm(mygrid)%phis, Atm(mygrid)%gridstruct, Atm(mygrid)%ks, Atm(mygrid)%npx, Atm(mygrid)%neststruct, Atm(mygrid)%bd) - if ( Atm(mygrid)%flagstruct%make_nh ) then - Atm(mygrid)%w(:,:,:) = 0. - endif + if ( Atm(mygrid)%flagstruct%make_nh ) then + Atm(mygrid)%w(:,:,:) = 0. + endif - if ( Atm(mygrid)%flagstruct%na_init>0 ) then - call adiabatic_init(zvir,mygrid) - endif + if ( Atm(mygrid)%flagstruct%na_init>0 ) then + call adiabatic_init(zvir,mygrid) + endif - theta_d = get_tracer_index (MODEL_ATMOS, 'theta_d') - if ( theta_d > 0 ) then - call eqv_pot(Atm(mygrid)%q(isc:iec,jsc:jec,:,theta_d), Atm(mygrid)%pt, Atm(mygrid)%delp, & - Atm(mygrid)%delz, Atm(mygrid)%peln, Atm(mygrid)%pkz, Atm(mygrid)%q(isd,jsd,1,1), isc, iec, jsc, jec, Atm(mygrid)%ng, & - Atm(mygrid)%npz, Atm(mygrid)%flagstruct%hydrostatic, Atm(mygrid)%flagstruct%moist_phys) - endif + theta_d = get_tracer_index (MODEL_ATMOS, 'theta_d') + if ( theta_d > 0 ) then + call eqv_pot(Atm(mygrid)%q(isc:iec,jsc:jec,:,theta_d), Atm(mygrid)%pt, Atm(mygrid)%delp, & + Atm(mygrid)%delz, Atm(mygrid)%peln, Atm(mygrid)%pkz, Atm(mygrid)%q(isd,jsd,1,1), isc, iec, jsc, jec, Atm(mygrid)%ng, & + Atm(mygrid)%npz, Atm(mygrid)%flagstruct%hydrostatic, Atm(mygrid)%flagstruct%moist_phys) + endif + Atm(mygrid)%time_init = Time_init call timing_off('ATMOS_INIT') @@ -254,7 +257,7 @@ subroutine adiabatic_init(zvir, n) enddo do m=1,Atm(n)%flagstruct%na_init -! Forwardward call +! Forward call call fv_dynamics(Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ncnst, Atm(n)%ng, dt_atmos, 0., & Atm(n)%flagstruct%fill, Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, Atm(n)%flagstruct%n_split, & @@ -265,9 +268,9 @@ subroutine adiabatic_init(zvir, n) Atm(n)%q_con, Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, Atm(n)%vc, & Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, & Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & - Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%diss_est) + Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid,& + Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est) ! Backward call fv_dynamics(Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ncnst, Atm(n)%ng, -dt_atmos, 0., & Atm(n)%flagstruct%fill, Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -279,9 +282,9 @@ subroutine adiabatic_init(zvir, n) Atm(n)%q_con, Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, Atm(n)%vc, & Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, & Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & - Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%diss_est) + Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & + Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est) ! Nudging back to IC !$omp parallel do default(shared) do k=1,npz @@ -326,9 +329,9 @@ subroutine adiabatic_init(zvir, n) Atm(n)%q_con, Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, Atm(n)%vc, & Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, & Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & - Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%diss_est) + Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & + Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est) ! Forwardward call call fv_dynamics(Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ncnst, Atm(n)%ng, dt_atmos, 0., & Atm(n)%flagstruct%fill, Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & @@ -340,9 +343,9 @@ subroutine adiabatic_init(zvir, n) Atm(n)%q_con, Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, Atm(n)%vc, & Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, & Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & - Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%diss_est) + Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, & + Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est) ! Nudging back to IC !$omp parallel do default(shared) do k=1,npz @@ -423,19 +426,19 @@ subroutine atmosphere (Time) endif call timing_on('FV_DYNAMICS') - call fv_dynamics(Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%ncnst, Atm(n)%ng, & - dt_atmos/real(abs(p_split)), Atm(n)%flagstruct%consv_te, Atm(n)%flagstruct%fill, & - Atm(n)%flagstruct%reproduce_sum, kappa, & - cp_air, zvir, Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, & - Atm(n)%flagstruct%n_split, Atm(n)%flagstruct%q_split, & - Atm(n)%u0, Atm(n)%v0, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, & - Atm(n)%flagstruct%hydrostatic, Atm(n)%pt, Atm(n)%delp, Atm(n)%q, Atm(n)%ps, & - Atm(n)%pe, Atm(n)%pk, Atm(n)%peln, Atm(n)%pkz, & - Atm(n)%phis, Atm(n)%q_con, Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, Atm(n)%vc, & - Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, & - Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, Atm(n)%domain, & - Atm(n)%inline_mp, Atm(n)%diss_est, time_total=time_total) + call fv_dynamics(Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%ncnst, Atm(n)%ng, & + dt_atmos/real(abs(p_split)), Atm(n)%flagstruct%consv_te, Atm(n)%flagstruct%fill, & + Atm(n)%flagstruct%reproduce_sum, kappa, & + cp_air, zvir, Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, & + Atm(n)%flagstruct%n_split, Atm(n)%flagstruct%q_split, & + Atm(n)%u0, Atm(n)%v0, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, & + Atm(n)%flagstruct%hydrostatic, Atm(n)%pt, Atm(n)%delp, Atm(n)%q, Atm(n)%ps, & + Atm(n)%pe, Atm(n)%pk, Atm(n)%peln, Atm(n)%pkz, & + Atm(n)%phis, Atm(n)%q_con, Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, Atm(n)%vc, & + Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, & + Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, Atm(n)%gridstruct, Atm(n)%flagstruct, & + Atm(n)%neststruct, Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, Atm(n)%domain, & + Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est, time_total=time_total) call timing_off('FV_DYNAMICS') if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then @@ -446,24 +449,24 @@ subroutine atmosphere (Time) end do !p_split - if(Atm(n)%npz /=1 .and. .not. Atm(n)%flagstruct%adiabatic)then + if(Atm(n)%npz /=1 .and. (.not. Atm(n)%flagstruct%adiabatic .or. Atm(mygrid)%flagstruct%fv_sg_adj > 0.)) then call timing_on('FV_PHYS') - call fv_phys(Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%bd%isc, Atm(n)%bd%iec, & - Atm(n)%bd%jsc, Atm(n)%bd%jec, Atm(n)%ng, Atm(n)%ncnst, & - Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%pt, Atm(n)%q, Atm(n)%pe, & - Atm(n)%delp, Atm(n)%peln, Atm(n)%pkz, dt_atmos, & - Atm(n)%ua, Atm(n)%va, Atm(n)%phis, Atm(n)%gridstruct%agrid, & - Atm(n)%ptop, Atm(n)%ak, Atm(n)%bk, Atm(n)%ks, Atm(n)%ps, Atm(n)%pk, & - Atm(n)%u_srf, Atm(n)%v_srf, Atm(n)%ts, Atm(n)%delz, & - Atm(n)%flagstruct%hydrostatic, Atm(n)%oro, .false., & - Atm(n)%flagstruct%p_ref, & - Atm(n)%flagstruct%fv_sg_adj, Atm(n)%flagstruct%do_Held_Suarez, & - Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, & - Atm(n)%flagstruct%nwat, Atm(n)%bd, & - Atm(n)%domain, fv_time, Atm(n)%phys_diag, Atm(n)%nudge_diag, time_total) + call fv_phys(Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%bd%isc, Atm(n)%bd%iec, & + Atm(n)%bd%jsc, Atm(n)%bd%jec, Atm(n)%ng, Atm(n)%ncnst, & + Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%pt, Atm(n)%q, Atm(n)%pe, & + Atm(n)%delp, Atm(n)%peln, Atm(n)%pkz, dt_atmos, & + Atm(n)%ua, Atm(n)%va, Atm(n)%phis, Atm(n)%gridstruct%agrid, & + Atm(n)%ptop, Atm(n)%ak, Atm(n)%bk, Atm(n)%ks, Atm(n)%ps, Atm(n)%pk, & + Atm(n)%u_srf, Atm(n)%v_srf, Atm(n)%ts, Atm(n)%delz, & + Atm(n)%flagstruct%hydrostatic, Atm(n)%oro, .false., & + Atm(n)%flagstruct%p_ref, Atm(n)%flagstruct%do_Held_Suarez, & + Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, & + Atm(n)%thermostruct, Atm(n)%flagstruct%nwat, Atm(n)%bd, & + Atm(n)%domain, fv_time, Atm(n)%phys_diag, Atm(n)%nudge_diag, & + Atm(n)%sg_diag, time_total) call timing_off('FV_PHYS') - endif + endif if (ngrids > 1 .and. p_split > 0) then call timing_on('TWOWAY_UPDATE') diff --git a/driver/solo/fv_phys.F90 b/driver/solo/fv_phys.F90 index 7f1ab7242..4ec51521e 100644 --- a/driver/solo/fv_phys.F90 +++ b/driver/solo/fv_phys.F90 @@ -23,15 +23,18 @@ module fv_phys_mod use constants_mod, only: grav, rdgas, rvgas, pi, cp_air, cp_vapor, hlv, kappa use fv_arrays_mod, only: radius, omega ! scaled for small earth +use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_nest_type +use fv_arrays_mod, only: fv_grid_bounds_type, fv_thermo_type +use fv_arrays_mod, only: phys_diag_type, nudge_diag_type, sg_diag_type use time_manager_mod, only: time_type, get_time use gfdl_mp_mod, only: mqs3d, wet_bulb, c_liq use hswf_mod, only: Held_Suarez_Tend -use fv_sg_mod, only: fv_subgrid_z +use fv_sg_mod, only: fv_sg_SHiELD, fv_sg_AM5 use fv_update_phys_mod, only: fv_update_phys use fv_timing_mod, only: timing_on, timing_off use mon_obkv_mod, only: mon_obkv -use tracer_manager_mod, only: get_tracer_index, adjust_mass +use tracer_manager_mod, only: get_tracer_index, adjust_mass, get_tracer_names use field_manager_mod, only: MODEL_ATMOS use fms_mod, only: error_mesg, FATAL, & check_nml_error, mpp_pe, mpp_root_pe, & @@ -39,7 +42,6 @@ module fv_phys_mod use fv_mp_mod, only: is_master, mp_reduce_max use fv_diagnostics_mod, only: prt_maxmin, gn -use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_grid_bounds_type, phys_diag_type, nudge_diag_type use mpp_domains_mod, only: domain2d use mpp_mod, only: input_nml_file use diag_manager_mod, only: register_diag_field, register_static_field, send_data @@ -185,14 +187,13 @@ subroutine fv_phys(npx, npy, npz, is, ie, js, je, ng, nq, & u, v, w, pt, q, pe, delp, peln, pkz, pdt, & ua, va, phis, grid, ptop, ak, bk, ks, ps, pk,& u_srf, v_srf, ts, delz, hydrostatic, & - oro, rayf, p_ref, fv_sg_adj, & + oro, rayf, p_ref, & do_Held_Suarez, gridstruct, flagstruct, & - neststruct, nwat, bd, domain, & !S-J: Need to update fv_phys call - Time, phys_diag, nudge_diag, time_total) + neststruct, thermostruct, nwat, bd, domain, & !S-J: Need to update fv_phys call + Time, phys_diag, nudge_diag, sg_diag, time_total) integer, INTENT(IN ) :: npx, npy, npz integer, INTENT(IN ) :: is, ie, js, je, ng, nq, nwat - integer, INTENT(IN ) :: fv_sg_adj real, INTENT(IN) :: p_ref, ptop real, INTENT(IN) :: oro(is:ie,js:je) @@ -222,10 +223,12 @@ subroutine fv_phys(npx, npy, npz, is, ie, js, je, ng, nq, & real, INTENT(inout):: ts(is:ie,js:je) type(phys_diag_type), intent(inout) :: phys_diag type(nudge_diag_type), intent(inout) :: nudge_diag + type(sg_diag_type) :: sg_diag type(fv_grid_type) :: gridstruct type(fv_flags_type) :: flagstruct type(fv_nest_type) :: neststruct + type(fv_thermo_type) :: thermostruct type(fv_grid_bounds_type), intent(IN) :: bd type(domain2d), intent(INOUT) :: domain @@ -241,13 +244,15 @@ subroutine fv_phys(npx, npy, npz, is, ie, js, je, ng, nq, & real, dimension(is:ie,npz):: dp2, pm, rdelp, u2, v2, t2, q2, du2, dv2, dt2, dq2 real:: lcp(is:ie), den(is:ie) real:: rain(is:ie,js:je), rain2(is:ie), zint(is:ie,1:npz+1) - real:: dq, dqsdt, delm, adj, rkv, sigl, tmp, prec, rgrav + real:: dq, dqsdt, delm, adj, rkv, sigl, tmp, prec, rgrav, rdt real :: qdiag(1,1,1) logical moist_phys integer isd, ied, jsd, jed - integer i, j, k, m, n, int + integer i, j, k, m, n, int, iq integer theta_d, Cl, Cl2 logical used + character(len=32) :: tracer_name + real::lat_thresh, tracer_clock call get_time (time, seconds, days) @@ -307,12 +312,81 @@ subroutine fv_phys(npx, npy, npz, is, ie, js, je, ng, nq, & enddo enddo - if ( fv_sg_adj > 0 ) then - if (is_master() .and. first_call) print*, " Calling fv_subgrid_z ", fv_sg_adj, flagstruct%n_sponge - call fv_subgrid_z(isd, ied, jsd, jed, is, ie, js, je, npz, min(6,nq), pdt, & - fv_sg_adj, nwat, delp, pe, peln, pkz, pt, q, ua, va, & - hydrostatic, w, delz, u_dt, v_dt, t_dt, q_dt, flagstruct%n_sponge ) - no_tendency = .false. + if ( flagstruct%fv_sg_adj > 0 ) then + if (is_master() .and. first_call) print*, " Calling fv_subgrid_z ", flagstruct%fv_sg_adj, flagstruct%n_sponge + +!$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,is,ie,js,je,sphum,sg_diag,ua,va,pt,q) + do k=1, npz + if (allocated(sg_diag%u_dt)) then + do j=js, je + do i=is, ie + sg_diag%u_dt(i,j,k) = 0. + enddo + enddo + endif + if (allocated(sg_diag%v_dt)) then + do j=js, je + do i=is, ie + sg_diag%v_dt(i,j,k) = 0. + enddo + enddo + endif + if (allocated(sg_diag%t_dt)) then + do j=js, je + do i=is, ie + sg_diag%t_dt(i,j,k) = pt(i,j,k) + enddo + enddo + endif + if (allocated(sg_diag%qv_dt)) then + do j=js, je + do i=is, ie + sg_diag%qv_dt(i,j,k) = q(i,j,k,sphum) + enddo + enddo + endif + enddo + + !fv_sg already returns the state, not the tendency. + call fv_sg_SHiELD(isd, ied, jsd, jed, is, ie, js, je, npz, min(6,nq), pdt, & + flagstruct%fv_sg_adj, flagstruct%fv_sg_adj_weak, & + nwat, delp, pe, peln, pkz, pt, q, ua, va, & + hydrostatic, w, delz, u_dt, v_dt, flagstruct%n_sponge ) + + rdt = 1./pdt +!$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,is,ie,js,je,sphum,rdt,sg_diag,ua,va,pt,q,u_dt,v_dt) + do k=1, npz + if (allocated(sg_diag%u_dt)) then + do j=js, je + do i=is, ie + sg_diag%u_dt(i,j,k) = u_dt(i,j,k) + enddo + enddo + endif + if (allocated(sg_diag%v_dt)) then + do j=js, je + do i=is, ie + sg_diag%v_dt(i,j,k) = v_dt(i,j,k) + enddo + enddo + endif + if (allocated(sg_diag%t_dt)) then + do j=js, je + do i=is, ie + sg_diag%t_dt(i,j,k) = (pt(i,j,k) - sg_diag%t_dt(i,j,k))*rdt + enddo + enddo + endif + if (allocated(sg_diag%qv_dt)) then + do j=js, je + do i=is, ie + sg_diag%qv_dt(i,j,k) = (q(i,j,k,sphum) - sg_diag%qv_dt(i,j,k))*rdt + enddo + enddo + endif + enddo + no_tendency = .false. + endif if ( do_LS_cond ) then @@ -419,7 +493,8 @@ subroutine fv_phys(npx, npy, npz, is, ie, js, je, ng, nq, & endif call K_warm_rain(pdt, is, ie, js, je, ng, npz, nq, zvir, ua, va, & w, u_dt, v_dt, q, pt, delp, delz, & - pe, peln, pk, ps, rain, Time, flagstruct%hydrostatic) + pe, peln, pk, ps, rain, Time, & + flagstruct%hydrostatic, thermostruct%moist_kappa) if( K_sedi_transport ) no_tendency = .false. if (do_terminator) then @@ -615,6 +690,32 @@ subroutine fv_phys(npx, npy, npz, is, ie, js, je, ng, nq, & deallocate ( t_dt ) deallocate ( q_dt ) +!LMH 7jan2020: Update PBL and other clock tracers, if present + tracer_clock = time_total*1.e-6 + lat_thresh = 15.*pi/180. + do iq = 1, nq + call get_tracer_names (MODEL_ATMOS, iq, tracer_name) + if (trim(tracer_name) == 'sfc_clock') then + do j=js,je + do i=is,ie + q(i,j,npz-4:npz,iq) = tracer_clock + enddo + enddo + else if (trim(tracer_name) == 'itcz_clock' ) then + do k=1,npz + do j=js,je + do i=is,ie + if (abs(gridstruct%agrid(i,j,2)) < lat_thresh .and. w(i,j,k) > 1.5) then + q(i,j,npz,iq) = tracer_clock + endif + enddo + enddo + enddo + endif + enddo + + + first_call = .false. end subroutine fv_phys @@ -1492,6 +1593,9 @@ subroutine gray_radiation(sec, is, ie, km, lon, lat, clouds, ts, temp, ps, phalf ! Gray-Radiation algorithms based on Frierson, Held, and Zurita-Gotor, 2006 JAS ! Note: delz is negative ! Coded by S.-J. Lin, June 20, 2012 +! From FHZ06: A gray-radiation scheme is one "in which the optical depths are +! fixed and radiative fluxes are a function of temperature alone. There are +! therefore no cloud- or water vapor–radiative feedbacks." integer, intent(in):: sec integer, intent(in):: is, ie, km real, dimension(is:ie):: ts @@ -1789,6 +1893,7 @@ subroutine fv_phys_init(is, ie, js, je, km, nwat, ts, pt, time, axes, lat) 'Physics U tendency', 'm/s/s', missing_value=missing_value) id_dvdt = register_diag_field( mod_name, 'dvdt', axes(1:3), time, & 'Physics V tendency', 'm/s/s', missing_value=missing_value) + !dtdt does NOT include heating from kessler id_dtdt = register_diag_field( mod_name, 'dtdt', axes(1:3), time, & 'Physics T tendency', 'K/s', missing_value=missing_value) id_dqdt = register_diag_field( mod_name, 'dqdt', axes(1:3), time, & @@ -1885,12 +1990,12 @@ real function g0_sum(p, ifirst, ilast, jfirst, jlast, ngc, area, mode) end function g0_sum subroutine K_warm_rain(dt, is, ie, js, je, ng, km, nq, zvir, u, v, w, u_dt, v_dt, & - q, pt, dp, delz, pe, peln, pk, ps, rain, Time, hydrostatic) + q, pt, dp, delz, pe, peln, pk, ps, rain, Time, hydrostatic, moist_kappa) type (time_type), intent(in) :: Time real, intent(in):: dt ! time step real, intent(in):: zvir integer, intent(in):: is, ie, js, je, km, ng, nq - logical, intent(in) :: hydrostatic + logical, intent(in) :: hydrostatic, moist_kappa real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: dp, pt, w, u, v, u_dt, v_dt real, intent(inout), dimension(is :ie ,js :je ,km):: delz real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km,nq):: q @@ -1996,7 +2101,7 @@ subroutine K_warm_rain(dt, is, ie, js, je, ng, km, nq, zvir, u, v, w, u_dt, v_dt endif endif enddo - call kessler_imp( t1, q1, q2, q3, vr, drym, sdt, dz, km ) + call kessler_imp( t1, q1, q2, q3, vr, drym, sdt, dz, km, moist_kappa ) ! Retrive rain_flux from non-local changes in total water m1(1) = drym(1)*(q0(1)-(q1(1)+q2(1)+q3(1))) ! Pa * kg/kg (dry) = kg * (g/dA) @@ -2094,7 +2199,7 @@ end subroutine K_warm_rain ! numerical techniques, implemented consistently with ! the FV3 dynamics. You can think of this as a "lite" ! version of the GFDL MP. - subroutine kessler_imp( T, qv, qc, qr, vr, drym, dt, dz, NZ ) + subroutine kessler_imp( T, qv, qc, qr, vr, drym, dt, dz, NZ, moist_kappa ) ! T - TEMPERATURE (K) ! QV - WATER VAPOR MIXING RATIO (GM/GM) ! qc - CLOUD WATER MIXING RATIO (GM/GM) @@ -2112,6 +2217,7 @@ subroutine kessler_imp( T, qv, qc, qr, vr, drym, dt, dz, NZ ) REAL, intent(in) :: drym(nz), dz(nz) REAL, intent(inout):: T(NZ), qv(NZ), qc(NZ), qr(NZ) real, intent(out):: vr(nz) ! terminal fall speed of rain * dt + logical, intent(in) :: moist_kappa ! Local: real, parameter:: qr_min = 1.e-8 real, parameter:: vr_min = 1.e-3 @@ -2134,32 +2240,53 @@ subroutine kessler_imp( T, qv, qc, qr, vr, drym, dt, dz, NZ ) qr(k) = (dz(k)*qr(k)+qr(k-1)*r(k-1)*dt*vr(k-1)/r(k)) / (dz(k)+dt*vr(k)) enddo - do k=1,nz -! Autoconversion and accretion rates following K&W78 Eq. 2.13a,b - QRPROD = qc(k) - (qc(k)-dt*max(.001*(qc(k)-.001),0.))/(1.+dt*2.2*qr(k)**.875) - qc(K) = qc(k) - QRPROD - qr(K) = qr(k) + QRPROD - rqr(k) = r(k)*max(qr(k), qr_min) - QVS = qs_wat(T(k), rho(k), dqsdt) -#ifdef MOIST_CAPPA - hlvm = (Lv0+dc_vap*T(k)) / (cv_air+qv(k)*cv_vap+(qc(k)+qr(k))*c_liq) -#else - hlvm = hlv / cv_air -#endif - PROD = (qv(k)-QVS) / (1.+dqsdt*hlvm) -! Evaporation rate following K&W78 Eq3. 3.8-3.10 - ERN = min(dt*(((1.6+124.9*rqr(k)**.2046) & - *rqr(k)**.525)/(2.55E6*pc(K) & - /(3.8 *QVS)+5.4E5))*(DIM(QVS,qv(K)) & - /(r(k)*QVS)),max(-PROD-qc(k),0.), qr(k)) -! Saturation adjustment following K&W78 Eq.2.14a,b - dq = max(PROD, -qc(k)) - T(k) = T(k) + hlvm*(dq-ERN) -! The following conserves total water - qv(K) = qv(K) - dq + ERN - qc(K) = qc(K) + dq - qr(K) = qr(K) - ERN - enddo + if (moist_kappa) then + do k=1,nz + ! Autoconversion and accretion rates following K&W78 Eq. 2.13a,b + QRPROD = qc(k) - (qc(k)-dt*max(.001*(qc(k)-.001),0.))/(1.+dt*2.2*qr(k)**.875) + qc(K) = qc(k) - QRPROD + qr(K) = qr(k) + QRPROD + rqr(k) = r(k)*max(qr(k), qr_min) + QVS = qs_wat(T(k), rho(k), dqsdt) + hlvm = (Lv0+dc_vap*T(k)) / (cv_air+qv(k)*cv_vap+(qc(k)+qr(k))*c_liq) !moist_kappa calc + PROD = (qv(k)-QVS) / (1.+dqsdt*hlvm) + ! Evaporation rate following K&W78 Eq3. 3.8-3.10 + ERN = min(dt*(((1.6+124.9*rqr(k)**.2046) & + *rqr(k)**.525)/(2.55E6*pc(K) & + /(3.8 *QVS)+5.4E5))*(DIM(QVS,qv(K)) & + /(r(k)*QVS)),max(-PROD-qc(k),0.), qr(k)) + ! Saturation adjustment following K&W78 Eq.2.14a,b + dq = max(PROD, -qc(k)) + T(k) = T(k) + hlvm*(dq-ERN) + ! The following conserves total water + qv(K) = qv(K) - dq + ERN + qc(K) = qc(K) + dq + qr(K) = qr(K) - ERN + enddo + else + do k=1,nz + ! Autoconversion and accretion rates following K&W78 Eq. 2.13a,b + QRPROD = qc(k) - (qc(k)-dt*max(.001*(qc(k)-.001),0.))/(1.+dt*2.2*qr(k)**.875) + qc(K) = qc(k) - QRPROD + qr(K) = qr(k) + QRPROD + rqr(k) = r(k)*max(qr(k), qr_min) + QVS = qs_wat(T(k), rho(k), dqsdt) + hlvm = hlv / cv_air + PROD = (qv(k)-QVS) / (1.+dqsdt*hlvm) + ! Evaporation rate following K&W78 Eq3. 3.8-3.10 + ERN = min(dt*(((1.6+124.9*rqr(k)**.2046) & + *rqr(k)**.525)/(2.55E6*pc(K) & + /(3.8 *QVS)+5.4E5))*(DIM(QVS,qv(K)) & + /(r(k)*QVS)),max(-PROD-qc(k),0.), qr(k)) + ! Saturation adjustment following K&W78 Eq.2.14a,b + dq = max(PROD, -qc(k)) + T(k) = T(k) + hlvm*(dq-ERN) + ! The following conserves total water + qv(K) = qv(K) - dq + ERN + qc(K) = qc(K) + dq + qr(K) = qr(K) - ERN + enddo + endif !moist cappa end subroutine kessler_imp diff --git a/model/a2b_edge.F90 b/model/a2b_edge.F90 index 9b2a4ae5c..127776832 100644 --- a/model/a2b_edge.F90 +++ b/model/a2b_edge.F90 @@ -356,8 +356,8 @@ subroutine a2b_ord2(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace if (gridstruct%bounded_domain) then - do j=js-2,je+1+2 - do i=is-2,ie+1+2 + do j=js,je+1 + do i=is,ie+1 qout(i,j) = 0.25*(qin(i-1,j-1)+qin(i,j-1)+qin(i-1,j)+qin(i,j)) enddo enddo diff --git a/model/dyn_core.F90 b/model/dyn_core.F90 index a2aef966d..c2c423763 100644 --- a/model/dyn_core.F90 +++ b/model/dyn_core.F90 @@ -51,8 +51,8 @@ module dyn_core_mod use fv_nwp_nudge_mod, only: breed_slp_inline, do_adiabatic_init #endif use diag_manager_mod, only: send_data - use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_diag_type, & - fv_grid_bounds_type, R_GRID, fv_nest_BC_type_3d + use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_diag_type + use fv_arrays_mod, only: fv_grid_bounds_type, R_GRID, fv_nest_BC_type_3d, fv_thermo_type use boundary_mod, only: extrapolation_BC, nested_grid_BC_apply_intT use fv_regional_mod, only: regional_boundary_update @@ -77,8 +77,6 @@ module dyn_core_mod real :: d3_damp real, allocatable, dimension(:,:,:) :: ut, vt, crx, cry, xfx, yfx, divgd, & zh, du, dv, pkc, delpc, pk3, ptc, gz -! real, parameter:: delt_max = 1.e-1 ! Max dissipative heating/cooling rate - ! 6 deg per 10-min real(kind=R_GRID), parameter :: cnst_0p20=0.20d0 real, allocatable :: rf(:) @@ -96,8 +94,8 @@ module dyn_core_mod subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, akap, cappa, grav, hydrostatic, & u, v, w, delz, pt, q, delp, pe, pk, phis, ws, omga, ptop, pfull, ua, va, & uc, vc, mfx, mfy, cx, cy, pkz, peln, q_con, ak, bk, & - ks, gridstruct, flagstruct, neststruct, idiag, bd, domain, & - init_step, i_pack, end_step, diss_est, consv, te0_2d, time_total) + ks, gridstruct, flagstruct, neststruct, thermostruct, idiag, bd, domain, & + init_step, i_pack, end_step, heat_source, diss_est, consv, te0_2d, time_total) integer, intent(IN) :: npx integer, intent(IN) :: npy integer, intent(IN) :: npz @@ -121,7 +119,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, real, intent(inout) :: pt( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) ! temperature (K) real, intent(inout) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) ! pressure thickness (pascal) real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, nq) ! - real, intent(inout) :: diss_est(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< skeb dissipation + real, intent(inout) :: heat_source(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< dissipative heating rate + real, intent(inout) :: diss_est(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< skeb dissipation real, intent(in), optional:: time_total ! total time (seconds) since start !----------------------------------------------------------------------- @@ -162,10 +161,11 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, type(fv_grid_type), intent(INOUT), target :: gridstruct type(fv_flags_type), intent(IN), target :: flagstruct type(fv_nest_type), intent(INOUT) :: neststruct + type(fv_thermo_type), intent(INOUT),target :: thermostruct type(fv_diag_type), intent(IN) :: idiag type(domain2d), intent(INOUT) :: domain - real, allocatable, dimension(:,:,:):: pem, heat_source + real, allocatable, dimension(:,:,:):: pem ! Auto 1D & 2D arrays: real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ws3, z_rat real:: dp_ref(npz) @@ -191,11 +191,11 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, integer :: ms !--------------------------------------- integer :: i,j,k, it, iq, n_con, nf_ke - integer :: iep1, jep1 + integer :: iep1, jep1, k_q_con real :: beta, beta_d, d_con_k, damp_w, damp_t, kgb, cv_air real :: dt, dt2, rdt real :: d2_divg - real :: k1k, rdg, dtmp, delt + real :: k1k, rdg, dtmp, dtmp2, delt real :: recip_k_split_n_split real :: reg_bc_update_time logical :: last_step, remap_step @@ -281,6 +281,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, allocate( dv(isd:ied+1,jsd:jed, npz) ) call init_ijk_mem(isd,ied+1, jsd,jed , npz, dv, 0.) endif + !only zero if first_step?? call init_ijk_mem(isd,ied, jsd,jed, npz, diss_est, 0.) endif ! end init_step @@ -290,10 +291,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call init_ijk_mem(is, ie+1, jsd, jed, npz, cx, 0.) call init_ijk_mem(isd, ied, js, je+1, npz, cy, 0.) - if ( flagstruct%d_con > 1.0E-5 ) then - allocate( heat_source(isd:ied, jsd:jed, npz) ) - call init_ijk_mem(isd, ied, jsd, jed, npz, heat_source, 0.) - endif + call init_ijk_mem(isd, ied, jsd, jed, npz, heat_source, 0.) if ( flagstruct%convert_ke .or. flagstruct%vtdm4> 1.E-4 ) then n_con = npz @@ -324,7 +322,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, endif if ( flagstruct%fv_debug ) then - if(is_master()) write(*,*) 'n_split loop, it=', it + if(is_master()) write(*,*) 'n_split loop, it=', it + call prt_mxm('delp', delp, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) if ( .not. flagstruct%hydrostatic ) & call prt_mxm('delz', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) endif @@ -436,7 +435,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call timing_on('C_SW') !$OMP parallel do default(none) shared(npz,isd,jsd,delpc,delp,ptc,pt,u,v,w,uc,vc,ua,va, & !$OMP omga,ut,vt,divgd,flagstruct,dt2,hydrostatic,bd, & -!$OMP gridstruct) +!$OMP gridstruct,thermostruct) do k=1,npz call c_sw(delpc(isd,jsd,k), delp(isd,jsd,k), ptc(isd,jsd,k), & pt(isd,jsd,k), u(isd,jsd,k), v(isd,jsd,k), & @@ -480,7 +479,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, endif if ( hydrostatic ) then call geopk(ptop, pe, peln, delpc, pkc, gz, phis, ptc, q_con, pkz, npz, akap, .true., & - gridstruct%bounded_domain, .false., npx, npy, flagstruct%a2b_ord, bd) + gridstruct%bounded_domain, .false., thermostruct%use_cond, npx, npy, bd) else #ifndef SW_DYNAMICS if ( it == 1 ) then @@ -532,36 +531,27 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call Riem_Solver_C( ms, dt2, is, ie, js, je, npz, ng, & akap, cappa, cp, ptop, phis, omga, ptc, & q_con, delpc, gz, pkc, ws3, flagstruct%p_fac, & - flagstruct%a_imp, flagstruct%scale_z, pfull, & + flagstruct%a_imp, thermostruct%use_cond, & + thermostruct%moist_kappa, pfull, & flagstruct%fast_tau_w_sec, flagstruct%rf_cutoff ) call timing_off('Riem_Solver') if (gridstruct%nested) then call nh_bc(ptop, grav, akap, cp, delpc, neststruct%delz_BC, ptc, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & + q_con, cappa, pkc, gz, pk3, & split_timestep_BC+0.5, real(n_split*flagstruct%k_split), & - npx, npy, npz, gridstruct%bounded_domain, .false., .false., .false., bd) + npx, npy, npz, gridstruct%bounded_domain, .false., .false., .false., & + thermostruct%use_cond, thermostruct%moist_kappa, bd) endif if (flagstruct%regional) then reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(0.5+(it-1))*dt call nh_bc(ptop, grav, akap, cp, delpc, delz_regBC, ptc, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & + q_con, cappa, pkc, gz, pk3, & mod(reg_bc_update_time,bc_time_interval*3600.), bc_time_interval*3600., & - npx, npy, npz, gridstruct%bounded_domain, .false., .false., .false., bd) + npx, npy, npz, gridstruct%bounded_domain, .false., .false., .false., & + thermostruct%use_cond, thermostruct%moist_kappa, bd) endif @@ -669,9 +659,10 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, !$OMP is,ie,js,je,isd,ied,jsd,jed,omga,delp,gridstruct,npx,npy, & !$OMP ng,zh,vt,ptc,pt,u,v,w,uc,vc,ua,va,divgd,mfx,mfy,cx,cy, & !$OMP crx,cry,xfx,yfx,q_con,zvir,sphum,nq,q,dt,bd,rdt,iep1,jep1, & -!$OMP heat_source,diss_est,radius) & +!$OMP heat_source,diss_est,radius,idiag,end_step,thermostruct) & !$OMP private(nord_k, nord_w, nord_t, damp_w, damp_t, d2_divg, & -!$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, diss_e, z_rat) +!$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, & +!$OMP diss_e, z_rat, k_q_con) do k=1,npz hord_m = flagstruct%hord_mt hord_t = flagstruct%hord_tm @@ -763,21 +754,22 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, enddo enddo endif + if (thermostruct%use_cond) then + k_q_con = k + else + k_q_con = 1 + endif call d_sw(vt(isd,jsd,k), delp(isd,jsd,k), ptc(isd,jsd,k), pt(isd,jsd,k), & u(isd,jsd,k), v(isd,jsd,k), w(isd:,jsd:,k), uc(isd,jsd,k), & vc(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), divgd(isd,jsd,k), & mfx(is, js, k), mfy(is, js, k), cx(is, jsd,k), cy(isd,js, k), & crx(is, jsd,k), cry(isd,js, k), xfx(is, jsd,k), yfx(isd,js, k), & -#ifdef USE_COND - q_con(isd:,jsd:,k), z_rat(isd,jsd), & -#else - q_con(isd:,jsd:,1), z_rat(isd,jsd), & -#endif + q_con(isd:,jsd:,k_q_con), z_rat(isd,jsd), & kgb, heat_s, diss_e, zvir, sphum, nq, q, k, npz, flagstruct%inline_q, dt, & flagstruct%hord_tr, hord_m, hord_v, hord_t, hord_p, & nord_k, nord_v(k), nord_w, nord_t, flagstruct%dddmp, d2_divg, flagstruct%d4_bg, & damp_vt(k), damp_w, damp_t, d_con_k, & - hydrostatic, gridstruct, flagstruct, bd) + hydrostatic, gridstruct, flagstruct, thermostruct%use_cond, bd) if((.not.flagstruct%use_old_omega) .and. last_step ) then ! Average horizontal "convergence" to cell center @@ -788,6 +780,14 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, enddo endif + if ((idiag%id_divg > 0) .and. end_step ) then + do j=js,je + do i=is,ie + divgd(i,j,k) = (xfx(i+1,j,k)-xfx(i,j,k)+yfx(i,j+1,k)-yfx(i,j,k))*gridstruct%rarea(i,j)*rdt + enddo + enddo + endif + if ( flagstruct%d_ext > 0. ) then do j=js,jep1 do i=is,iep1 @@ -795,11 +795,16 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, enddo enddo endif - if ( flagstruct%d_con > 1.0E-5 .OR. flagstruct%do_diss_est ) then -! Average horizontal "convergence" to cell center + if ( flagstruct%d_con > 1.0E-5) then do j=js,je do i=is,ie heat_source(i,j,k) = heat_source(i,j,k) + heat_s(i,j) + enddo + enddo + endif + if ( flagstruct%do_diss_est) then + do j=js,je + do i=is,ie diss_est(i,j,k) = diss_est(i,j,k) + diss_e(i,j) enddo enddo @@ -817,9 +822,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call timing_on('COMM_TOTAL') call start_group_halo_update(i_pack(1), delp, domain, complete=.false.) call start_group_halo_update(i_pack(1), pt, domain, complete=.true.) -#ifdef USE_COND - call start_group_halo_update(i_pack(11), q_con, domain) -#endif + if (thermostruct%use_cond) call start_group_halo_update(i_pack(11), q_con, domain) call timing_off('COMM_TOTAL') if ( flagstruct%d_ext > 0. ) then @@ -846,13 +849,12 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call timing_on('COMM_TOTAL') call complete_group_halo_update(i_pack(1), domain) -#ifdef USE_COND - call complete_group_halo_update(i_pack(11), domain) -#endif + if (thermostruct%use_cond) call complete_group_halo_update(i_pack(11), domain) call timing_off('COMM_TOTAL') if ( flagstruct%fv_debug ) then + call prt_mxm('delp 1', delp, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) if ( .not. flagstruct%hydrostatic ) & - call prt_mxm('delz', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) + call prt_mxm('delz 1', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) endif !Want to move this block into the hydro/nonhydro branch above and merge the two if structures @@ -867,11 +869,11 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, 0, 0, npx, npy, npz, bd, split_timestep_BC+1, real(n_split*flagstruct%k_split), & neststruct%pt_BC, bctype=neststruct%nestbctype ) -#ifdef USE_COND - call nested_grid_BC_apply_intT(q_con, & + if (thermostruct%use_cond) then + call nested_grid_BC_apply_intT(q_con, & 0, 0, npx, npy, npz, bd, split_timestep_BC+1, real(n_split*flagstruct%k_split), & neststruct%q_con_BC, bctype=neststruct%nestbctype ) -#endif + endif #endif @@ -890,19 +892,19 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, isd, ied, jsd, jed, & reg_bc_update_time,it ) -#ifdef USE_COND - call regional_boundary_update(q_con, 'q_con', & + if (thermostruct%use_cond) then + call regional_boundary_update(q_con, 'q_con', & isd, ied, jsd, jed, npz, & is, ie, js, je, & isd, ied, jsd, jed, & reg_bc_update_time,it ) -#endif + endif #endif endif if ( hydrostatic ) then call geopk(ptop, pe, peln, delp, pkc, gz, phis, pt, q_con, pkz, npz, akap, .false., & - gridstruct%bounded_domain, .true., npx, npy, flagstruct%a2b_ord, bd) + gridstruct%bounded_domain, .true., thermostruct%use_cond, npx, npy, bd) else #ifndef SW_DYNAMICS call timing_on('UPDATE_DZ') @@ -910,13 +912,14 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, gridstruct%rarea, dp_ref, zs, zh, crx, cry, xfx, yfx, ws, rdt, gridstruct, bd, flagstruct%lim_fac) call timing_off('UPDATE_DZ') if ( flagstruct%fv_debug ) then + call prt_mxm('delp updated', delp, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) if ( .not. flagstruct%hydrostatic ) then call prt_mxm('delz updated', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) call prt_mxm('WS', ws, is, ie, js, je, 0, 1, 1., gridstruct%area_64, domain) endif endif - if (idiag%id_ws>0 .and. last_step) then + if (idiag%id_ws>0 .and. end_step) then ! call prt_mxm('WS', ws, is, ie, js, je, 0, 1, 1., gridstruct%area_64, domain) used=send_data(idiag%id_ws, ws, fv_time) endif @@ -930,8 +933,10 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, isd, ied, jsd, jed, & akap, cappa, cp, ptop, zs, q_con, w, delz, pt, delp, zh, & pe, pkc, pk3, pk, peln, ws, & - flagstruct%scale_z, flagstruct%p_fac, flagstruct%a_imp, & - flagstruct%use_logp, remap_step, beta<-0.1, flagstruct%d2bg_zq, & + flagstruct%p_fac, flagstruct%a_imp, & + flagstruct%use_logp, thermostruct%use_cond, & + thermostruct%moist_kappa, remap_step, & + beta<-0.1, flagstruct%d2bg_zq, & flagstruct%fv_debug, flagstruct%fast_tau_w_sec) call timing_off('Riem_Solver') @@ -955,29 +960,19 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, if (gridstruct%nested) then call nh_bc(ptop, grav, akap, cp, delp, neststruct%delz_BC, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & + q_con, cappa, pkc, gz, pk3, & split_timestep_BC+1., real(n_split*flagstruct%k_split), & - npx, npy, npz, gridstruct%bounded_domain, .true., .true., .true., bd) + npx, npy, npz, gridstruct%bounded_domain, .true., .true., .true., & + thermostruct%use_cond, thermostruct%moist_kappa, bd) endif if (flagstruct%regional) then reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+it*dt call nh_bc(ptop, grav, akap, cp, delp, delz_regBC, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & + q_con, cappa, pkc, gz, pk3, & mod(reg_bc_update_time,bc_time_interval*3600.), bc_time_interval*3600., & - npx, npy, npz, gridstruct%bounded_domain, .true., .true., .true., bd) + npx, npy, npz, gridstruct%bounded_domain, .true., .true., .true., & + thermostruct%use_cond, thermostruct%moist_kappa, bd) endif @@ -1021,9 +1016,9 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call timing_on('PG_D') if ( hydrostatic ) then if ( beta > 0. ) then - call grad1_p_update(divg2, u, v, pkc, gz, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta_d, flagstruct%a2b_ord) + call grad1_p_update(divg2, u, v, pkc, gz, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta_d) else - call one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, flagstruct%a2b_ord, flagstruct%d_ext) + call one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, flagstruct%d_ext) endif else @@ -1032,7 +1027,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, if ( beta > 0. ) then call split_p_grad( u, v, pkc, gz, delp, pk3, beta_d, dt, ng, gridstruct, bd, npx, npy, npz, flagstruct%use_logp) elseif ( beta < -0.1 ) then - call one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, flagstruct%a2b_ord, flagstruct%d_ext) + call one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, flagstruct%d_ext) else call nh_p_grad(u, v, pkc, gz, delp, pk3, dt, ng, gridstruct, bd, npx, npy, npz, flagstruct%use_logp) endif @@ -1067,20 +1062,28 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, !------------------------------------------------------------------------------------------------------- if ( flagstruct%breed_vortex_inline ) then if ( .not. hydrostatic ) then + if (thermostruct%moist_kappa) then !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,cappa,rdg,delp,delz,pt,k1k) - do k=1,npz + do k=1,npz do j=js,je do i=is,ie ! Note: pt at this stage is Theta_m -#ifdef MOIST_CAPPA pkz(i,j,k) = exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) ) -#else + enddo + enddo + enddo + else +!$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,cappa,rdg,delp,delz,pt,k1k) + do k=1,npz + do j=js,je + do i=is,ie +! Note: pt at this stage is Theta_m pkz(i,j,k) = exp( k1k*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) ) -#endif enddo enddo - enddo - endif + enddo + endif !moist_kappa + endif !.not. hydrostatic #if defined (ADA_NUDGE) call breed_slp_inline_ada( it, dt, npz, ak, bk, phis, pe, pk, peln, pkz, & delp, u, v, pt, q, flagstruct%nwat, zvir, gridstruct, ks, domain, bd ) @@ -1100,9 +1103,9 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, call timing_on('FAST_PHYS') call fast_phys (is, ie, js, je, isd, ied, jsd, jed, npz, npx, npy, nq, & - flagstruct%c2l_ord, dt, consv, akap, ptop, phis, te0_2d, u, v, w, pt, & + dt, consv, akap, ptop, phis, te0_2d, u, v, w, pt, & delp, delz, q_con, cappa, q, pkz, zvir, flagstruct%te_err, flagstruct%tw_err, & - gridstruct, domain, bd, hydrostatic, do_adiabatic_init, & + gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, & flagstruct%consv_checker, flagstruct%adj_mass_vmr) call timing_on('COMM_TOTAL') @@ -1210,7 +1213,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, enddo enddo endif - if (idiag%id_ws>0 .and. hydrostatic) then + !this may be meaningless since delz not init for hydro + if (idiag%id_ws>0 .and. hydrostatic .and. end_step) then !$OMP parallel do default(none) shared(is,ie,js,je,npz,ws,delz,delp,omga) do j=js,je do i=is,ie @@ -1225,8 +1229,6 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, if (gridstruct%nested) then - - #ifndef SW_DYNAMICS if (.not. hydrostatic) then call nested_grid_BC_apply_intT(w, & @@ -1276,7 +1278,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, if ( do_diag_debug_dyn ) then call debug_column_dyn( pt, delp, delz, u, v, w, q, heat_source, cappa, akap, & - allocated(heat_source), npz, nq, sphum, flagstruct%nwat, zvir, ptop, hydrostatic, bd, fv_time, n_map, it) + npz, nq, sphum, flagstruct%nwat, zvir, ptop, hydrostatic, & + thermostruct%moist_kappa, bd, fv_time, n_map, it) endif !----------------------------------------------------- @@ -1296,6 +1299,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, if ( n_con/=0 .and. flagstruct%d_con > 1.e-5 ) then nf_ke = min(3, flagstruct%nord+1) + !Requires heat_source(:,:,:) have haloes call del2_cubed(heat_source, cnst_0p20*gridstruct%da_min, gridstruct, domain, npx, npy, npz, nf_ke, bd) ! Note: pt here is cp*(Virtual_Temperature/pkz) @@ -1306,7 +1310,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pt,heat_source,delp,pkz,bdt) & !$OMP private(dtmp) do j=js,je - do k=1,n_con ! n_con is usually less than 3; + do k=1,n_con ! n_con is usually less than 3 unless convert_ke or vtdm4 are enabled; then n_con = npz if ( k<3 ) then do i=is,ie pt(i,j,k) = pt(i,j,k) + heat_source(i,j,k)/(cp_air*delp(i,j,k)*pkz(i,j,k)) @@ -1314,36 +1318,44 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, else do i=is,ie dtmp = heat_source(i,j,k) / (cp_air*delp(i,j,k)) - pt(i,j,k) = pt(i,j,k) + sign(min(abs(bdt)*flagstruct%delt_max,abs(dtmp)), dtmp)/pkz(i,j,k) + pt(i,j,k) = pt(i,j,k) + sign(min(abs(bdt)*flagstruct%delt_max,abs(dtmp)), dtmp)/pkz(i,j,k) + heat_source(i,j,k) = dtmp enddo endif enddo enddo else !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pkz,cappa,rdg,delp,delz,pt, & -!$OMP heat_source,k1k,cv_air,bdt) & +!$OMP heat_source,k1k,cv_air,bdt,thermostruct) & !$OMP private(dtmp, delt) do k=1,n_con delt = abs(bdt*flagstruct%delt_max) ! Sponge layers: if ( k == 1 ) delt = 0.1*delt if ( k == 2 ) delt = 0.5*delt - do j=js,je + if (thermostruct%moist_kappa) then + do j=js,je do i=is,ie -#ifdef MOIST_CAPPA pkz(i,j,k) = exp( cappa(i,j,k)/(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) ) -#else + dtmp = heat_source(i,j,k) / (cv_air*delp(i,j,k)) + pt(i,j,k) = pt(i,j,k) + sign(min(delt, abs(dtmp)),dtmp) / pkz(i,j,k) + heat_source(i,j,k) = dtmp !save actual K/s for diagnostics + enddo + enddo + else + do j=js,je + do i=is,ie pkz(i,j,k) = exp( k1k*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) ) -#endif - dtmp = heat_source(i,j,k) / (cv_air*delp(i,j,k)) + dtmp = heat_source(i,j,k) / (cv_air*delp(i,j,k)) pt(i,j,k) = pt(i,j,k) + sign(min(delt, abs(dtmp)),dtmp) / pkz(i,j,k) + heat_source(i,j,k) = dtmp !save actual K/s for diagnostics enddo - enddo + enddo + endif !moist_kappa enddo endif endif - if (allocated(heat_source)) deallocate( heat_source ) !If ncon == 0 but d_con > 1.e-5, this would not be deallocated in earlier versions of the code if ((.not. hydrostatic) .and. w_forcing .and. present(time_total)) then call do_w_forcing(bd, npx, npy, npz, w, delz, phis, & @@ -1351,6 +1363,11 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, endif if ( end_step ) then + + if (idiag%id_divg > 0) then + used=send_data(idiag%id_divg, divgd(is:ie,js:je,:), fv_time) + endif + deallocate( gz ) deallocate( ptc ) deallocate( crx ) @@ -1890,9 +1907,9 @@ end subroutine split_p_grad subroutine one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, & - ptop, hydrostatic, a2b_ord, d_ext) + ptop, hydrostatic, d_ext) -integer, intent(IN) :: ng, npx, npy, npz, a2b_ord +integer, intent(IN) :: ng, npx, npy, npz real, intent(IN) :: dt, ptop, d_ext logical, intent(in) :: hydrostatic type(fv_grid_bounds_type), intent(IN) :: bd @@ -1937,24 +1954,16 @@ subroutine one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, np enddo enddo -!$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) & +!$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng) & !$OMP private(wk) do k=2,npz+1 - if ( a2b_ord==4 ) then - call a2b_ord4(pk(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - else - call a2b_ord2(pk(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - endif + call a2b_ord4(pk(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) enddo -!$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) & +!$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng) & !$OMP private(wk) do k=1,npz+1 - if ( a2b_ord==4 ) then - call a2b_ord4( gz(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - else - call a2b_ord2( gz(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - endif + call a2b_ord4( gz(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) enddo if ( d_ext > 0. ) then @@ -1987,7 +1996,7 @@ subroutine one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, np endif -!$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,delp,hydrostatic,a2b_ord,gridstruct, & +!$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,delp,hydrostatic,gridstruct, & !$OMP npx,npy,isd,jsd,ng,u,v,wk2,dt,gz,wk1) & !$OMP private(wk) do k=1,npz @@ -1999,11 +2008,7 @@ subroutine one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, np enddo enddo else - if ( a2b_ord==4 ) then - call a2b_ord4(delp(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng) - else - call a2b_ord2(delp(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng) - endif + call a2b_ord4(delp(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng) endif do j=js,je+1 @@ -2025,9 +2030,9 @@ subroutine one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, np end subroutine one_grad_p -subroutine grad1_p_update(divg2, u, v, pk, gz, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord) +subroutine grad1_p_update(divg2, u, v, pk, gz, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta) -integer, intent(in) :: ng, npx, npy, npz, a2b_ord +integer, intent(in) :: ng, npx, npy, npz real, intent(in) :: dt, ptop, beta type(fv_grid_bounds_type), intent(IN) :: bd real, intent(in):: divg2(bd%is:bd%ie+1,bd%js:bd%je+1) @@ -2065,24 +2070,16 @@ subroutine grad1_p_update(divg2, u, v, pk, gz, dt, ng, gridstruct, bd, npx, npy, pk(i,j,1) = top_value enddo enddo -!$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) & +!$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng) & !$OMP private(wk) do k=2,npz+1 - if ( a2b_ord==4 ) then - call a2b_ord4(pk(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - else - call a2b_ord2(pk(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - endif + call a2b_ord4(pk(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) enddo -!$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) & +!$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng) & !$OMP private(wk) do k=1,npz+1 - if ( a2b_ord==4 ) then - call a2b_ord4( gz(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - else - call a2b_ord2( gz(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) - endif + call a2b_ord4( gz(isd,jsd,k), wk, gridstruct, npx, npy, is, ie, js, je, ng, .true.) enddo !$OMP parallel do default(none) shared(npz,is,ie,js,je,pk,u,beta,gz,divg2,alpha, & @@ -2202,15 +2199,15 @@ subroutine mix_dp(hydrostatic, w, delp, pt, km, ak, bk, CG, fv_debug, bd, gridst end subroutine mix_dp - subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, CG, bounded_domain, computehalo, npx, npy, a2b_ord, bd) + subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, CG, bounded_domain, computehalo, use_cond, npx, npy, bd) - integer, intent(IN) :: km, npx, npy, a2b_ord + integer, intent(IN) :: km, npx, npy real , intent(IN) :: akap, ptop type(fv_grid_bounds_type), intent(IN) :: bd real , intent(IN) :: hs(bd%isd:bd%ied,bd%jsd:bd%jed) real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,km):: pt, delp real, intent(IN), dimension(bd%isd:,bd%jsd:,1:):: q_con - logical, intent(IN) :: CG, bounded_domain, computehalo + logical, intent(IN) :: CG, bounded_domain, computehalo, use_cond ! !OUTPUT PARAMETERS real, intent(OUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,km+1):: gz, pk real, intent(OUT) :: pe(bd%is-1:bd%ie+1,km+1,bd%js-1:bd%je+1) @@ -2239,7 +2236,7 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, CG, jsd = bd%jsd jed = bd%jed - if ( (.not. CG .and. a2b_ord==4) .or. (bounded_domain .and. .not. CG) ) then ! D-Grid + if ( (.not. CG) .or. (bounded_domain .and. .not. CG) ) then ! D-Grid ifirst = is-2; ilast = ie+2 jfirst = js-2; jlast = je+2 else @@ -2255,19 +2252,26 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, CG, end if !$OMP parallel do default(none) shared(jfirst,jlast,ifirst,ilast,pk,km,gz,hs,ptop,ptk, & -!$OMP js,je,is,ie,peln,peln1,pe,delp,akap,pt,CG,pkz,q_con) & +!$OMP js,je,is,ie,peln,peln1,pe,delp,akap,pt,CG,pkz, & +!$OMP q_con,use_cond) & !$OMP private(peg, pkg, p1d, logp) do 2000 j=jfirst,jlast - do i=ifirst, ilast - p1d(i) = ptop - pk(i,j,1) = ptk - gz(i,j,km+1) = hs(i,j) -#ifdef USE_COND - peg(i,1) = ptop - pkg(i,1) = ptk -#endif - enddo + if (use_cond) then + do i=ifirst, ilast + p1d(i) = ptop + pk(i,j,1) = ptk + gz(i,j,km+1) = hs(i,j) + peg(i,1) = ptop + pkg(i,1) = ptk + enddo + else + do i=ifirst, ilast + p1d(i) = ptop + pk(i,j,1) = ptk + gz(i,j,km+1) = hs(i,j) + enddo + endif !use_cond #ifndef SW_DYNAMICS if( j>=js .and. j<=je) then @@ -2285,15 +2289,21 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, CG, ! Top down do k=2,km+1 - do i=ifirst, ilast - p1d(i) = p1d(i) + delp(i,j,k-1) - logp(i) = log(p1d(i)) - pk(i,j,k) = exp( akap*logp(i) ) -#ifdef USE_COND - peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) - pkg(i,k) = exp( akap*log(peg(i,k)) ) -#endif - enddo + if (use_cond) then + do i=ifirst, ilast + p1d(i) = p1d(i) + delp(i,j,k-1) + logp(i) = log(p1d(i)) + pk(i,j,k) = exp( akap*logp(i) ) + peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) + pkg(i,k) = exp( akap*log(peg(i,k)) ) + enddo + else + do i=ifirst, ilast + p1d(i) = p1d(i) + delp(i,j,k-1) + logp(i) = log(p1d(i)) + pk(i,j,k) = exp( akap*logp(i) ) + enddo + endif if( j>(js-2) .and. j<(je+2) ) then do i=max(ifirst,is-1), min(ilast,ie+1) @@ -2309,19 +2319,27 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, CG, enddo ! Bottom up +#ifdef SW_DYNAMICS do k=km,1,-1 do i=ifirst, ilast -#ifdef SW_DYNAMICS gz(i,j,k) = gz(i,j,k+1) + pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k)) + enddo + enddo #else -#ifdef USE_COND + if (use_cond) then + do k=km,1,-1 + do i=ifirst, ilast gz(i,j,k) = gz(i,j,k+1) + cp_air*pt(i,j,k)*(pkg(i,k+1)-pkg(i,k)) -#else - gz(i,j,k) = gz(i,j,k+1) + cp_air*pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k)) -#endif -#endif enddo enddo + else + do k=km,1,-1 + do i=ifirst, ilast + gz(i,j,k) = gz(i,j,k+1) + cp_air*pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k)) + enddo + enddo + endif !use_cond +#endif SW_DYNAMICS if ( .not. CG .and. j .ge. js .and. j .le. je ) then do k=1,km diff --git a/model/fast_phys.F90 b/model/fast_phys.F90 index b66cd38b6..69077dd13 100644 --- a/model/fast_phys.F90 +++ b/model/fast_phys.F90 @@ -33,7 +33,7 @@ module fast_phys_mod use constants_mod, only: rdgas, grav #endif use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys - use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type + use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, fv_thermo_type use mpp_domains_mod, only: domain2d, mpp_update_domains use tracer_manager_mod, only: get_tracer_index, get_tracer_names use field_manager_mod, only: model_atmos @@ -56,9 +56,9 @@ module fast_phys_mod contains subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, & - c2l_ord, mdt, consv, akap, ptop, hs, te0_2d, u, v, w, pt, & + mdt, consv, akap, ptop, hs, te0_2d, u, v, w, pt, & delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, & - gridstruct, domain, bd, hydrostatic, do_adiabatic_init, & + gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, & consv_checker, adj_mass_vmr) implicit none @@ -67,7 +67,7 @@ subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, & ! input / output arguments ! ----------------------------------------------------------------------- - integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, c2l_ord, adj_mass_vmr + integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, adj_mass_vmr logical, intent (in) :: hydrostatic, do_adiabatic_init, consv_checker @@ -93,6 +93,8 @@ subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, & type (fv_grid_type), intent (in), target :: gridstruct + type (fv_thermo_type), intent (in), target :: thermostruct + type (fv_grid_bounds_type), intent (in) :: bd type (domain2d), intent (inout) :: domain @@ -162,40 +164,53 @@ subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, & ! pt conversion !----------------------------------------------------------------------- - do k = 1, km - do j = js, je - do i = is, ie -#ifdef MOIST_CAPPA - pt (i, j, k) = pt (i, j, k) * exp (cappa (i, j, k) / (1. - cappa (i, j, k)) * & - log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k))) -#else - pt (i, j, k) = pt (i, j, k) * exp (akap / (1 - akap) * & - log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k))) -#endif - enddo - enddo - enddo + if (thermostruct%moist_kappa) then + do k = 1, km + do j = js, je + do i = is, ie + pt (i, j, k) = pt (i, j, k) * exp (cappa (i, j, k) / (1. - cappa (i, j, k)) * & + log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k))) + enddo + enddo + enddo + else + do k = 1, km + do j = js, je + do i = is, ie + pt (i, j, k) = pt (i, j, k) * exp (akap / (1 - akap) * & + log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k))) + enddo + enddo + enddo + endif !----------------------------------------------------------------------- ! pt conversion !----------------------------------------------------------------------- - do k = 1, km - do j = js, je - do i = is, ie -#ifdef MOIST_CAPPA - pkz (i, j, k) = exp (cappa (i, j, k) * & - log (rrg * delp (i, j, k) / & - delz (i, j, k) * pt (i, j, k))) -#else - pkz (i, j, k) = exp (akap * & - log (rrg * delp (i, j, k) / & - delz (i, j, k) * pt (i, j, k))) -#endif - pt (i, j, k) = pt (i, j, k) / pkz (i, j, k) - enddo - enddo - enddo + if (thermostruct%moist_kappa) then + do k = 1, km + do j = js, je + do i = is, ie + pkz (i, j, k) = exp (cappa (i, j, k) * & + log (rrg * delp (i, j, k) / & + delz (i, j, k) * pt (i, j, k))) + pt (i, j, k) = pt (i, j, k) / pkz (i, j, k) + enddo + enddo + enddo + else + do k = 1, km + do j = js, je + do i = is, ie + pkz (i, j, k) = exp (akap * & + log (rrg * delp (i, j, k) / & + delz (i, j, k) * pt (i, j, k))) + pt (i, j, k) = pt (i, j, k) / pkz (i, j, k) + enddo + enddo + enddo + endif end subroutine fast_phys diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90 index 862528dda..4c11a5f0e 100644 --- a/model/fv_arrays.F90 +++ b/model/fv_arrays.F90 @@ -60,7 +60,7 @@ module fv_arrays_mod real, allocatable :: zxg(:,:) integer :: id_u_dt_sg, id_v_dt_sg, id_t_dt_sg, id_qv_dt_sg, id_diss - integer :: id_ws, id_te, id_amdt, id_divg, id_aam + integer :: id_ws, id_te, id_amdt, id_divg_mean, id_divg, id_aam logical :: initialized = .false. real :: efx(max_step), efx_sum, efx_nest(max_step), efx_sum_nest, mtq(max_step), mtq_sum @@ -283,9 +283,6 @@ module fv_arrays_mod integer :: kord_tr = 8 !< The vertical remapping scheme for tracers. The default is 8. !< 9 or 11 recommended. It is often recommended to use the same !< value for 'kord_tr' as for 'kord_tm'. - real :: scale_z = 0. !< diff_z = scale_z**2 * 0.25 (only used for Riemann solver) - real :: w_max = 75. !< Not used. - real :: z_min = 0.05 !< Not used. real :: d2bg_zq = 0.0 !< Implicit vertical diffusion for scalars (currently vertical velocity only) real :: lim_fac = 1.0 !< linear scheme limiting factor when using hord = 1. 1: hord = 5, 3: hord = 6 @@ -328,10 +325,6 @@ module fv_arrays_mod real :: d2_bg_k2 = 2. !< Strength of second-order diffusion in the second sponge !< layer from the model top. This value must be specified, and !< should be less than 'd2_bg_k1'. - real :: d2_divg_max_k1 = 0.15 !< d2_divg max value (k=1) - real :: d2_divg_max_k2 = 0.08 !< d2_divg max value (k=2) - real :: damp_k_k1 = 0.2 !< damp_k value (k=1) - real :: damp_k_k2 = 0.12 !< damp_k value (k=2) !> Additional (after the fact) terrain filter (to further smooth the terrain after cold start) integer :: n_zs_filter=0 !< Number of times to apply a diffusive filter to the topography @@ -640,6 +633,7 @@ module fv_arrays_mod !< Values of 0 or smaller disable this feature. If n_sponge < 0 !< then the mixing is applied only to the top n_sponge layers of the !< domain. Set to -1 (inactive) by default. The proper range is 0 to 3600. + integer :: fv_sg_adj_weak = -1 !< Option for weaker (longer timescale) 2dz filter below sg_cutoff. Disabled if < 0. real :: sg_cutoff = -1 !< cutoff level for fv_sg_adj (2dz filter; overrides n_sponge) integer :: na_init = 0 !< Number of forward-backward dynamics steps used to initialize !< adiabatic solver. This is useful for spinning up the nonhydrostatic @@ -680,6 +674,8 @@ module fv_arrays_mod !< converted to heat. Acts as a dissipative heating mechanism in !< the dynamical core. The default is 0. Proper range is 0 to 1. !< Note that this is a local, physically correct, energy fixer. + logical :: prevent_diss_cooling = .false. !< Flag to enable limiter to prevent dissipative cooling if + !< d_con > 0. Turned off by default to retain previous behavior. real :: ke_bg = 0. !< background KE production (m^2/s^3) over a small step !< Use this to conserve total energy if consv_te=0 real :: consv_te = 0. !< Fraction of total energy lost during the adiabatic integration @@ -735,12 +731,13 @@ module fv_arrays_mod logical :: fill_gfs = .true. ! default behavior logical :: check_negative = .false. !< Whether to print the most negativ global value of microphysical tracers. logical :: non_ortho = .true. - logical :: moist_phys = .true. !< Run with moist physics + logical :: moist_phys = .true. !< Run with moist physics. This is *only* false in idealized (solo_core) + !< simulations with adiabatic = .true. or in a held_suarez simulation. When false, + !< the virtual temperature effect is disabled, the moist effect in total energy + !< is neglected, and water species are treated as passive tracers. logical :: do_Held_Suarez = .false. !< Whether to use Held-Suarez forcing. Requires adiabatic !< to be false. The default is .false.; this option has no !< effect if not running solo_core. - logical :: do_reed_physics = .false. - logical :: reed_cond_only = .false. logical :: reproduce_sum = .true. !< uses an exactly-reproducible global sum operation performed !< when computing the global energy for consv_te. This is used !< because the FMS routine mpp_sum() is not bit-wise reproducible @@ -776,17 +773,6 @@ module fv_arrays_mod !< This may improve efficiency for very large numbers of tracers. !< The default value is .false.; currently not implemented. - logical :: old_divg_damp = .false. !< parameter to revert damping parameters back to values - !< defined in a previous revision - !< old_values: - !< d2_bg_k1 = 6. d2_bg_k2 = 4. - !< d2_divg_max_k1 = 0.02 d2_divg_max_k2 = 0.01 - !< damp_k_k1 = 0. damp_k_k2 = 0. - !< current_values: - !< d2_bg_k1 = 4. d2_bg_k2 = 2. - !< d2_divg_max_k1 = 0.15 d2_divg_max_k2 = 0.08 - !< damp_k_k1 = 0.2 damp_k_k2 = 0.12 - logical :: fv_land = .false. !< Whether to create terrain deviation and land fraction for !< output to mg_drag restart files, for use in mg_drag and in the land !< model. The default is .false; .true. is recommended when, and only @@ -795,7 +781,6 @@ module fv_arrays_mod !< wave drag parameterization and for the land surface roughness than !< either computes internally. This has no effect on the representation of !< the terrain in the dynamics. - logical :: do_am4_remap = .false. !< Use AM4 vertical remapping operators !-------------------------------------------------------------------------------------- ! The following options are useful for NWP experiments using datasets on the lat-lon grid !-------------------------------------------------------------------------------------- @@ -825,8 +810,6 @@ module fv_arrays_mod !< (ua and va) to the restart files. This is useful for data !< assimilation cycling systems which do not handle staggered winds. !< The default is .false. - logical :: use_new_ncep = .false. !< use the NCEP ICs created after 2014/10/22, if want to read CWAT (not used??) - logical :: use_ncep_phy = .false. !< if .T., separate CWAT by weights of liq_wat and liq_ice in FV_IC (not used??) logical :: fv_diag_ic = .false. !< reconstruct IC from fv_diagnostics on lat-lon grid logical :: external_ic = .false. !< Whether to initialize the models state using the data !< in an externally specified file, given in res_latlon_dynamics. @@ -890,16 +873,6 @@ module fv_arrays_mod !< Useful for perturbing initial conditions. -1 by default; !< disabled if 0 or negative. - integer :: a2b_ord = 4 !< Order of interpolation used by the pressure gradient force - !< to interpolate cell-centered (A-grid) values to the grid corners. - !< The default value is 4 (recommended), which uses fourth-order - !< interpolation; otherwise second-order interpolation is used. - integer :: c2l_ord = 4 !< Order of interpolation from the solvers native D-grid winds - !< to latitude-longitude A-grid winds, which are used as input to - !< the physics routines and for writing to history files. - !< The default value is 4 (recommended); fourth-order interpolation - !< is used unless c2l_ord = 2. - real(kind=R_GRID) :: dx_const = 1000. !< Specifies the (uniform) grid-cell-width in the x-direction !< on a doubly-periodic grid (grid_type = 4) in meters. !< The default value is 1000. @@ -920,7 +893,6 @@ module fv_arrays_mod !f1p integer :: adj_mass_vmr = 0 !0: no correction; 1: AM4/CM4 correction; 2: correction based on convertion of VMR to dry mixing ratio - logical :: w_limiter = .true. ! Fix excessive w - momentum conserving --- sjl ! options related to regional mode logical :: regional = .false. !< Default setting for the regional domain. @@ -1033,12 +1005,8 @@ module fv_arrays_mod type(fv_nest_BC_type_3D), allocatable, dimension(:) :: q_BC #ifndef SW_DYNAMICS type(fv_nest_BC_type_3D) :: pt_BC, w_BC, delz_BC -#ifdef USE_COND type(fv_nest_BC_type_3D) :: q_con_BC -#ifdef MOIST_CAPPA type(fv_nest_BC_type_3D) :: cappa_BC -#endif -#endif #endif !points to same parent grid as does Atm%parent_grid @@ -1077,6 +1045,47 @@ module fv_arrays_mod real, _ALLOCATABLE :: u_dt(:,:,:) real, _ALLOCATABLE :: v_dt(:,:,:) + real, _ALLOCATABLE :: qcw(:,:,:) + real, _ALLOCATABLE :: qci(:,:,:) + real, _ALLOCATABLE :: qcr(:,:,:) + real, _ALLOCATABLE :: qcs(:,:,:) + real, _ALLOCATABLE :: qcg(:,:,:) + real, _ALLOCATABLE :: rew(:,:,:) + real, _ALLOCATABLE :: rei(:,:,:) + real, _ALLOCATABLE :: rer(:,:,:) + real, _ALLOCATABLE :: res(:,:,:) + real, _ALLOCATABLE :: reg(:,:,:) + real, _ALLOCATABLE :: cld(:,:,:) + + real, _ALLOCATABLE :: mppcw(:,:) _NULL + real, _ALLOCATABLE :: mppew(:,:) _NULL + real, _ALLOCATABLE :: mppe1(:,:) _NULL + real, _ALLOCATABLE :: mpper(:,:) _NULL + real, _ALLOCATABLE :: mppdi(:,:) _NULL + real, _ALLOCATABLE :: mppd1(:,:) _NULL + real, _ALLOCATABLE :: mppds(:,:) _NULL + real, _ALLOCATABLE :: mppdg(:,:) _NULL + real, _ALLOCATABLE :: mppsi(:,:) _NULL + real, _ALLOCATABLE :: mpps1(:,:) _NULL + real, _ALLOCATABLE :: mppss(:,:) _NULL + real, _ALLOCATABLE :: mppsg(:,:) _NULL + real, _ALLOCATABLE :: mppfw(:,:) _NULL + real, _ALLOCATABLE :: mppfr(:,:) _NULL + real, _ALLOCATABLE :: mppmi(:,:) _NULL + real, _ALLOCATABLE :: mppms(:,:) _NULL + real, _ALLOCATABLE :: mppmg(:,:) _NULL + real, _ALLOCATABLE :: mppm1(:,:) _NULL + real, _ALLOCATABLE :: mppm2(:,:) _NULL + real, _ALLOCATABLE :: mppm3(:,:) _NULL + real, _ALLOCATABLE :: mppar(:,:) _NULL + real, _ALLOCATABLE :: mppas(:,:) _NULL + real, _ALLOCATABLE :: mppag(:,:) _NULL + real, _ALLOCATABLE :: mpprs(:,:) _NULL + real, _ALLOCATABLE :: mpprg(:,:) _NULL + real, _ALLOCATABLE :: mppxr(:,:) _NULL + real, _ALLOCATABLE :: mppxs(:,:) _NULL + real, _ALLOCATABLE :: mppxg(:,:) _NULL + end type inline_mp_type type phys_diag_type @@ -1102,6 +1111,7 @@ module fv_arrays_mod real, _ALLOCATABLE :: nudge_delp_dt(:,:,:) real, _ALLOCATABLE :: nudge_u_dt(:,:,:) real, _ALLOCATABLE :: nudge_v_dt(:,:,:) + real, _ALLOCATABLE :: nudge_qv_dt(:,:,:) end type nudge_diag_type @@ -1207,6 +1217,28 @@ module fv_arrays_mod ,is_west_uvw ,ie_west_uvw ,js_west_uvw ,je_west_uvw end type fv_regional_bc_bounds_type + + type fv_thermo_type + + !Option flags. If hydrostatic is set, for backwards-compatibility + ! the defaults are changed in fv_thermo_init() to both be false. + ! In either case, fv_thermo_nml will override the defaults. + logical :: use_cond = .true. + logical :: moist_kappa = .true. + + !Simulation flags + logical :: pt_is_potential = .false. + logical :: pt_is_virtual = .false. + logical :: pt_is_density = .false. + + real :: zvir = 0.0 !choose a better default + + !integer, dimension(:), allocatable :: nwat_for_delp + + logical :: is_initialized = .false. + + end type fv_thermo_type + type fv_atmos_type logical :: allocated = .false. @@ -1276,6 +1308,7 @@ module fv_arrays_mod real, _ALLOCATABLE :: ci(:,:) _NULL ! sea-ice fraction from external file ! For stochastic kinetic energy backscatter (SKEB) + real, _ALLOCATABLE :: heat_source(:,:,:) _NULL !< dissipative heating real, _ALLOCATABLE :: diss_est(:,:,:) _NULL !< dissipation estimate taken from 'heat_source' !----------------------------------------------------------------------- @@ -1376,6 +1409,7 @@ module fv_arrays_mod type(sg_diag_type) :: sg_diag type(coarse_restart_type) :: coarse_restart type(fv_coarse_graining_type) :: coarse_graining + type(fv_thermo_type) :: thermostruct end type fv_atmos_type contains @@ -1510,7 +1544,8 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie endif ! Allocate others - allocate ( Atm%diss_est(isd:ied ,jsd:jed ,npz) ) + allocate ( Atm%heat_source(isd:ied,jsd:jed,npz) ) + allocate ( Atm%diss_est(isd:ied,jsd:jed,npz) ) allocate ( Atm%ts(is:ie,js:je) ) allocate ( Atm%phis(isd:ied ,jsd:jed ) ) allocate ( Atm%omga(isd:ied ,jsd:jed ,npz) ); Atm%omga=0. @@ -1542,6 +1577,34 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie allocate ( Atm%inline_mp%prefluxs(is:ie,js:je,npz) ) allocate ( Atm%inline_mp%prefluxg(is:ie,js:je,npz) ) endif + allocate ( Atm%inline_mp%mppcw(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppew(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppe1(is:ie,js:je) ) + allocate ( Atm%inline_mp%mpper(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppdi(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppd1(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppds(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppdg(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppsi(is:ie,js:je) ) + allocate ( Atm%inline_mp%mpps1(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppss(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppsg(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppfw(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppfr(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppmi(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppms(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppmg(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppm1(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppm2(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppm3(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppar(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppas(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppag(is:ie,js:je) ) + allocate ( Atm%inline_mp%mpprs(is:ie,js:je) ) + allocate ( Atm%inline_mp%mpprg(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppxr(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppxs(is:ie,js:je) ) + allocate ( Atm%inline_mp%mppxg(is:ie,js:je) ) !-------------------------- ! Non-hydrostatic dynamics: @@ -1562,11 +1625,11 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie ! allocate ( mono(isd:ied, jsd:jed, npz)) endif -#ifdef USE_COND + if ( Atm%thermostruct%use_cond ) then allocate ( Atm%q_con(isd:ied,jsd:jed,1:npz) ) -#else + else allocate ( Atm%q_con(isd:isd,jsd:jsd,1) ) -#endif + endif ! Notes by SJL ! Place the memory in the optimal shared mem space @@ -1642,6 +1705,38 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie enddo enddo endif + do j=js, je + do i=is, ie + Atm%inline_mp%mppcw(i,j) = real_big + Atm%inline_mp%mppew(i,j) = real_big + Atm%inline_mp%mppe1(i,j) = real_big + Atm%inline_mp%mpper(i,j) = real_big + Atm%inline_mp%mppdi(i,j) = real_big + Atm%inline_mp%mppd1(i,j) = real_big + Atm%inline_mp%mppds(i,j) = real_big + Atm%inline_mp%mppdg(i,j) = real_big + Atm%inline_mp%mppsi(i,j) = real_big + Atm%inline_mp%mpps1(i,j) = real_big + Atm%inline_mp%mppss(i,j) = real_big + Atm%inline_mp%mppsg(i,j) = real_big + Atm%inline_mp%mppfw(i,j) = real_big + Atm%inline_mp%mppfr(i,j) = real_big + Atm%inline_mp%mppmi(i,j) = real_big + Atm%inline_mp%mppms(i,j) = real_big + Atm%inline_mp%mppmg(i,j) = real_big + Atm%inline_mp%mppm1(i,j) = real_big + Atm%inline_mp%mppm2(i,j) = real_big + Atm%inline_mp%mppm3(i,j) = real_big + Atm%inline_mp%mppar(i,j) = real_big + Atm%inline_mp%mppas(i,j) = real_big + Atm%inline_mp%mppag(i,j) = real_big + Atm%inline_mp%mpprs(i,j) = real_big + Atm%inline_mp%mpprg(i,j) = real_big + Atm%inline_mp%mppxr(i,j) = real_big + Atm%inline_mp%mppxs(i,j) = real_big + Atm%inline_mp%mppxg(i,j) = real_big + enddo + enddo do j=js, je do i=is, ie @@ -1817,12 +1912,13 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie #ifndef SW_DYNAMICS call allocate_fv_nest_BC_type(Atm%neststruct%pt_BC,Atm,ns,0,0,dummy) -#ifdef USE_COND - call allocate_fv_nest_BC_type(Atm%neststruct%q_con_BC,Atm,ns,0,0,dummy) -#ifdef MOIST_CAPPA - call allocate_fv_nest_BC_type(Atm%neststruct%cappa_BC,Atm,ns,0,0,dummy) -#endif -#endif +!About USE_COND and MOIST_CAPPA: We want to initialize these to length 1 in each dimension if the flags are not defined. + if ( Atm%thermostruct%use_cond) then + call allocate_fv_nest_BC_type(Atm%neststruct%q_con_BC,Atm,ns,0,0,dummy) !only initialize if using USE_COND + endif + if ( Atm%thermostruct%moist_kappa) then + call allocate_fv_nest_BC_type(Atm%neststruct%cappa_BC,Atm,ns,0,0,dummy) !only initialize if using MOIST_CAPPA + endif if (.not.Atm%flagstruct%hydrostatic) then call allocate_fv_nest_BC_type(Atm%neststruct%w_BC,Atm,ns,0,0,dummy) call allocate_fv_nest_BC_type(Atm%neststruct%delz_BC,Atm,ns,0,0,dummy) @@ -1894,6 +1990,7 @@ subroutine deallocate_fv_atmos_type(Atm) deallocate ( Atm%cy ) deallocate ( Atm%ak ) deallocate ( Atm%bk ) + deallocate ( Atm%heat_source ) deallocate ( Atm%diss_est ) if (Atm%flagstruct%do_inline_mp) then @@ -1908,6 +2005,34 @@ subroutine deallocate_fv_atmos_type(Atm) deallocate ( Atm%inline_mp%prefluxs ) deallocate ( Atm%inline_mp%prefluxg ) endif + deallocate ( Atm%inline_mp%mppcw ) + deallocate ( Atm%inline_mp%mppew ) + deallocate ( Atm%inline_mp%mppe1 ) + deallocate ( Atm%inline_mp%mpper ) + deallocate ( Atm%inline_mp%mppdi ) + deallocate ( Atm%inline_mp%mppd1 ) + deallocate ( Atm%inline_mp%mppds ) + deallocate ( Atm%inline_mp%mppdg ) + deallocate ( Atm%inline_mp%mppsi ) + deallocate ( Atm%inline_mp%mpps1 ) + deallocate ( Atm%inline_mp%mppss ) + deallocate ( Atm%inline_mp%mppsg ) + deallocate ( Atm%inline_mp%mppfw ) + deallocate ( Atm%inline_mp%mppfr ) + deallocate ( Atm%inline_mp%mppmi ) + deallocate ( Atm%inline_mp%mppms ) + deallocate ( Atm%inline_mp%mppmg ) + deallocate ( Atm%inline_mp%mppm1 ) + deallocate ( Atm%inline_mp%mppm2 ) + deallocate ( Atm%inline_mp%mppm3 ) + deallocate ( Atm%inline_mp%mppar ) + deallocate ( Atm%inline_mp%mppas ) + deallocate ( Atm%inline_mp%mppag ) + deallocate ( Atm%inline_mp%mpprs ) + deallocate ( Atm%inline_mp%mpprg ) + deallocate ( Atm%inline_mp%mppxr ) + deallocate ( Atm%inline_mp%mppxs ) + deallocate ( Atm%inline_mp%mppxg ) deallocate ( Atm%u_srf ) deallocate ( Atm%v_srf ) @@ -2064,12 +2189,12 @@ subroutine deallocate_fv_atmos_type(Atm) #ifndef SW_DYNAMICS call deallocate_fv_nest_BC_type(Atm%neststruct%pt_BC) -#ifdef USE_COND - call deallocate_fv_nest_BC_type(Atm%neststruct%q_con_BC) -#ifdef MOIST_CAPPA - call deallocate_fv_nest_BC_type(Atm%neststruct%cappa_BC) -#endif -#endif + if ( Atm%thermostruct%use_cond ) then + call deallocate_fv_nest_BC_type(Atm%neststruct%q_con_BC) + endif + if ( Atm%thermostruct%moist_kappa ) then + call deallocate_fv_nest_BC_type(Atm%neststruct%cappa_BC) + endif if (.not.Atm%flagstruct%hydrostatic) then call deallocate_fv_nest_BC_type(Atm%neststruct%w_BC) call deallocate_fv_nest_BC_type(Atm%neststruct%delz_BC) diff --git a/model/fv_control.F90 b/model/fv_control.F90 index c8167015a..0fd48ea7b 100644 --- a/model/fv_control.F90 +++ b/model/fv_control.F90 @@ -68,6 +68,8 @@ module fv_control_mod mpp_max use fv_diagnostics_mod, only: fv_diag_init_gn use coarse_grained_restart_files_mod, only: deallocate_coarse_restart_type + use tp_core_mod, only: tp_mono_schemes, tp_PD_schemes, tp_unlim_schemes, tp_valid_schemes + use fv_thermodynamics_mod, only: fv_thermo_init implicit none private @@ -121,7 +123,7 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) integer, dimension(MAX_NNEST) :: tile_coarse = 0 integer, dimension(MAX_NTILE) :: npes_nest_tile = 0 - real :: sdt + real :: sdt, rdt integer :: unit, ens_root_pe, tile_id(1) !!!!!!!!!! POINTERS FOR READING NAMELISTS !!!!!!!!!! @@ -143,9 +145,6 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) integer , pointer :: kord_tm integer , pointer :: hord_tr integer , pointer :: kord_tr - real , pointer :: scale_z - real , pointer :: w_max - real , pointer :: z_min real , pointer :: d2bg_zq real , pointer :: lim_fac @@ -159,10 +158,6 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) real , pointer :: trdm2 real , pointer :: d2_bg_k1 real , pointer :: d2_bg_k2 - real , pointer :: d2_divg_max_k1 - real , pointer :: d2_divg_max_k2 - real , pointer :: damp_k_k1 - real , pointer :: damp_k_k2 integer , pointer :: n_zs_filter integer , pointer :: nord_zs_filter logical , pointer :: full_zs_filter @@ -224,6 +219,7 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) integer , pointer :: ntiles integer , pointer :: nf_omega integer , pointer :: fv_sg_adj + integer , pointer :: fv_sg_adj_weak real , pointer :: sg_cutoff integer , pointer :: na_init @@ -236,6 +232,7 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) real , pointer :: delt_max real , pointer :: d_con + logical , pointer :: prevent_diss_cooling real , pointer :: ke_bg real , pointer :: consv_te real , pointer :: tau @@ -263,22 +260,18 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) logical , pointer :: mountain logical , pointer :: remap_t logical , pointer :: z_tracer - logical , pointer :: w_limiter - logical , pointer :: old_divg_damp logical , pointer :: fv_land - logical , pointer :: do_am4_remap logical , pointer :: nudge logical , pointer :: nudge_ic logical , pointer :: ncep_ic logical , pointer :: nggps_ic logical , pointer :: hrrrv3_ic logical , pointer :: ecmwf_ic + logical , pointer :: do_diss_est logical , pointer :: use_gfsO3 logical , pointer :: gfs_phil logical , pointer :: agrid_vel_rst - logical , pointer :: use_new_ncep - logical , pointer :: use_ncep_phy logical , pointer :: fv_diag_ic logical , pointer :: external_ic logical , pointer :: external_eta @@ -295,9 +288,6 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) logical , pointer :: nudge_qv real, pointer :: add_noise - integer , pointer :: a2b_ord - integer , pointer :: c2l_ord - integer, pointer :: ndims real(kind=R_GRID), pointer :: dx_const @@ -463,6 +453,8 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) call read_namelist_fv_core_nml(Atm(this_grid)) ! do options processing here too? call read_namelist_test_case_nml call read_namelist_integ_phys_nml + call fv_thermo_init(Atm(this_grid)%thermostruct,Atm(this_grid)%flagstruct) !thermo namelist and setup + call mpp_get_current_pelist(Atm(this_grid)%pelist, commID=commID) ! for commID call mp_start(commID,halo_update_type) @@ -566,8 +558,10 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) call tm_register_tracers (MODEL_ATMOS, Atm(this_grid)%flagstruct%ncnst, Atm(this_grid)%flagstruct%nt_prog, & Atm(this_grid)%flagstruct%pnats, num_family) if(is_master()) then - write(*,*) 'ncnst=', ncnst,' num_prog=',Atm(this_grid)%flagstruct%nt_prog,' pnats=',Atm(this_grid)%flagstruct%pnats,' dnats=',dnats,& - ' num_family=',num_family + write(*,200) ncnst, Atm(this_grid)%flagstruct%nt_prog, Atm(this_grid)%flagstruct%pnats + write(*,201) dnats, num_family +200 format('ncnst = ', I4, ' num_prog = ', I4, ' pnats = ', I4) +201 format('dnats = ', I4, ' num_family = ', I4) print*, '' endif if (dnrts < 0) dnrts = dnats @@ -635,30 +629,39 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) ! 8. grid_utils_init() ! Initialize the SW (2D) part of the model - call grid_utils_init(Atm(this_grid), Atm(this_grid)%flagstruct%npx, Atm(this_grid)%flagstruct%npy, Atm(this_grid)%flagstruct%npz, Atm(this_grid)%flagstruct%non_ortho, Atm(this_grid)%flagstruct%grid_type, Atm(this_grid)%flagstruct%c2l_ord) + call grid_utils_init(Atm(this_grid), Atm(this_grid)%flagstruct%npx, Atm(this_grid)%flagstruct%npy, Atm(this_grid)%flagstruct%npz, Atm(this_grid)%flagstruct%non_ortho, Atm(this_grid)%flagstruct%grid_type) - ! Finish up initialization; write damping coefficients dependent upon + ! Finish up initialization; write solver information and damping coefficients if ( is_master() ) then - sdt = dt_atmos/real(Atm(this_grid)%flagstruct%n_split*Atm(this_grid)%flagstruct%k_split*abs(p_split)) write(*,*) ' ' - write(*,*) 'Divergence damping Coefficients' - write(*,*) 'For small dt=', sdt - write(*,*) 'External mode del-2 (m**2/s)=', Atm(this_grid)%flagstruct%d_ext*Atm(this_grid)%gridstruct%da_min_c/sdt - write(*,*) 'Internal mode del-2 SMAG dimensionless coeff=', Atm(this_grid)%flagstruct%dddmp - write(*,*) 'Internal mode del-2 background diff=', Atm(this_grid)%flagstruct%d2_bg*Atm(this_grid)%gridstruct%da_min_c/sdt - - if (nord==1) then - write(*,*) 'Internal mode del-4 background diff=', Atm(this_grid)%flagstruct%d4_bg - write(*,*) 'Vorticity del-4 (m**4/s)=', (Atm(this_grid)%flagstruct%vtdm4*Atm(this_grid)%gridstruct%da_min)**2/sdt*1.E-6 - endif - if (Atm(this_grid)%flagstruct%nord==2) write(*,*) 'Internal mode del-6 background diff=', Atm(this_grid)%flagstruct%d4_bg - if (Atm(this_grid)%flagstruct%nord==3) write(*,*) 'Internal mode del-8 background diff=', Atm(this_grid)%flagstruct%d4_bg - write(*,*) 'tracer del-2 diff=', Atm(this_grid)%flagstruct%trdm2 + write(*,300) Atm(this_grid)%flagstruct%hydrostatic, Atm(this_grid)%thermostruct%use_cond, Atm(this_grid)%thermostruct%moist_kappa +300 format(' hydrostatic = ',L1,' use_cond = ',L1,' moist_kappa = ',L1) - write(*,*) 'Vorticity del-4 (m**4/s)=', (Atm(this_grid)%flagstruct%vtdm4*Atm(this_grid)%gridstruct%da_min)**2/sdt*1.E-6 - write(*,*) 'beta=', Atm(this_grid)%flagstruct%beta + rdt = dt_atmos/real(Atm(this_grid)%flagstruct%k_split*abs(p_split)) + sdt = rdt/real(Atm(this_grid)%flagstruct%n_split) write(*,*) ' ' + write(*,*) 'Acoustic (small) dt = ', sdt + write(*,*) 'Remapping dt = ', rdt + + if (Atm(this_grid)%flagstruct%fv_debug) then + write(*,*) ' ' + write(*,*) 'Divergence damping Coefficients' + write(*,*) 'External mode del-2 (m**2/s)=', Atm(this_grid)%flagstruct%d_ext*Atm(this_grid)%gridstruct%da_min_c/sdt + write(*,*) 'Internal mode del-2 SMAG dimensionless coeff=', Atm(this_grid)%flagstruct%dddmp + write(*,*) 'Internal mode del-2 background diff=', Atm(this_grid)%flagstruct%d2_bg*Atm(this_grid)%gridstruct%da_min_c/sdt + + if (nord==1) then + write(*,*) 'Internal mode del-4 background diff=', Atm(this_grid)%flagstruct%d4_bg + endif + if (Atm(this_grid)%flagstruct%nord==2) write(*,*) 'Internal mode del-6 background diff=', Atm(this_grid)%flagstruct%d4_bg + if (Atm(this_grid)%flagstruct%nord==3) write(*,*) 'Internal mode del-8 background diff=', Atm(this_grid)%flagstruct%d4_bg + write(*,*) 'tracer del-2 diff=', Atm(this_grid)%flagstruct%trdm2 + + write(*,*) 'Vorticity del-4 (m**4/s)=', (Atm(this_grid)%flagstruct%vtdm4*Atm(this_grid)%gridstruct%da_min)**2/sdt*1.E-6 + write(*,*) 'beta=', Atm(this_grid)%flagstruct%beta + write(*,*) ' ' + endif endif !Initialize restart @@ -684,9 +687,6 @@ subroutine set_namelist_pointers(Atm) remap_te => Atm%flagstruct%remap_te hord_tr => Atm%flagstruct%hord_tr kord_tr => Atm%flagstruct%kord_tr - scale_z => Atm%flagstruct%scale_z - w_max => Atm%flagstruct%w_max - z_min => Atm%flagstruct%z_min d2bg_zq => Atm%flagstruct%d2bg_zq lim_fac => Atm%flagstruct%lim_fac nord => Atm%flagstruct%nord @@ -699,10 +699,6 @@ subroutine set_namelist_pointers(Atm) trdm2 => Atm%flagstruct%trdm2 d2_bg_k1 => Atm%flagstruct%d2_bg_k1 d2_bg_k2 => Atm%flagstruct%d2_bg_k2 - d2_divg_max_k1 => Atm%flagstruct%d2_divg_max_k1 - d2_divg_max_k2 => Atm%flagstruct%d2_divg_max_k2 - damp_k_k1 => Atm%flagstruct%damp_k_k1 - damp_k_k2 => Atm%flagstruct%damp_k_k2 n_zs_filter => Atm%flagstruct%n_zs_filter nord_zs_filter => Atm%flagstruct%nord_zs_filter full_zs_filter => Atm%flagstruct%full_zs_filter @@ -762,6 +758,7 @@ subroutine set_namelist_pointers(Atm) ntiles => Atm%flagstruct%ntiles nf_omega => Atm%flagstruct%nf_omega fv_sg_adj => Atm%flagstruct%fv_sg_adj + fv_sg_adj_weak => Atm%flagstruct%fv_sg_adj_weak sg_cutoff => Atm%flagstruct%sg_cutoff na_init => Atm%flagstruct%na_init nudge_dz => Atm%flagstruct%nudge_dz @@ -772,6 +769,7 @@ subroutine set_namelist_pointers(Atm) tau_h2o => Atm%flagstruct%tau_h2o delt_max => Atm%flagstruct%delt_max d_con => Atm%flagstruct%d_con + prevent_diss_cooling => Atm%flagstruct%prevent_diss_cooling ke_bg => Atm%flagstruct%ke_bg consv_te => Atm%flagstruct%consv_te tau => Atm%flagstruct%tau @@ -795,25 +793,21 @@ subroutine set_namelist_pointers(Atm) reproduce_sum => Atm%flagstruct%reproduce_sum adjust_dry_mass => Atm%flagstruct%adjust_dry_mass fv_debug => Atm%flagstruct%fv_debug - w_limiter => Atm%flagstruct%w_limiter srf_init => Atm%flagstruct%srf_init mountain => Atm%flagstruct%mountain remap_t => Atm%flagstruct%remap_t z_tracer => Atm%flagstruct%z_tracer - old_divg_damp => Atm%flagstruct%old_divg_damp fv_land => Atm%flagstruct%fv_land - do_am4_remap => Atm%flagstruct%do_am4_remap nudge => Atm%flagstruct%nudge nudge_ic => Atm%flagstruct%nudge_ic ncep_ic => Atm%flagstruct%ncep_ic nggps_ic => Atm%flagstruct%nggps_ic hrrrv3_ic => Atm%flagstruct%hrrrv3_ic ecmwf_ic => Atm%flagstruct%ecmwf_ic + do_diss_est => Atm%flagstruct%do_diss_est use_gfsO3 => Atm%flagstruct%use_gfsO3 gfs_phil => Atm%flagstruct%gfs_phil agrid_vel_rst => Atm%flagstruct%agrid_vel_rst - use_new_ncep => Atm%flagstruct%use_new_ncep - use_ncep_phy => Atm%flagstruct%use_ncep_phy fv_diag_ic => Atm%flagstruct%fv_diag_ic external_ic => Atm%flagstruct%external_ic external_eta => Atm%flagstruct%external_eta @@ -830,8 +824,6 @@ subroutine set_namelist_pointers(Atm) make_hybrid_z => Atm%flagstruct%make_hybrid_z nudge_qv => Atm%flagstruct%nudge_qv add_noise => Atm%flagstruct%add_noise - a2b_ord => Atm%flagstruct%a2b_ord - c2l_ord => Atm%flagstruct%c2l_ord ndims => Atm%flagstruct%ndims dx_const => Atm%flagstruct%dx_const @@ -940,26 +932,27 @@ subroutine read_namelist_fv_core_nml(Atm) do_schmidt, do_cube_transform, & hord_mt, hord_vt, hord_tm, hord_dp, hord_tr, shift_fac, stretch_fac, target_lat, target_lon, & kord_mt, kord_wz, kord_tm, kord_tr, remap_te, fv_debug, fv_land, & - do_am4_remap, nudge, do_f3d, external_ic, is_ideal_case, read_increment, & - ncep_ic, nggps_ic, hrrrv3_ic, ecmwf_ic, use_gfsO3, use_new_ncep, use_ncep_phy, fv_diag_ic, & - external_eta, res_latlon_dynamics, res_latlon_tracers, scale_z, w_max, z_min, d2bg_zq, lim_fac, & + nudge, do_f3d, external_ic, is_ideal_case, read_increment, & + ncep_ic, nggps_ic, hrrrv3_ic, ecmwf_ic, do_diss_est, use_gfsO3, fv_diag_ic, & + external_eta, res_latlon_dynamics, res_latlon_tracers, d2bg_zq, lim_fac, & dddmp, smag2d, d2_bg, d4_bg, vtdm4, trdm2, d_ext, delt_max, beta, non_ortho, n_sponge, & - warm_start, adjust_dry_mass, mountain, d_con, ke_bg, nord, nord_tr, convert_ke, use_old_omega, & + warm_start, adjust_dry_mass, mountain, d_con, prevent_diss_cooling, ke_bg, nord, nord_tr, convert_ke, use_old_omega, & dry_mass, grid_type, do_Held_Suarez, & consv_te, fill, filter_phys, fill_dp, fill_wz, fill_gfs, consv_am, RF_fast, & range_warn, dwind_2d, inline_q, z_tracer, reproduce_sum, adiabatic, do_vort_damp, no_dycore, & - tau, fast_tau_w_sec, tau_h2o, rf_cutoff, nf_omega, hydrostatic, fv_sg_adj, sg_cutoff, breed_vortex_inline, & + tau, fast_tau_w_sec, tau_h2o, rf_cutoff, nf_omega, hydrostatic, fv_sg_adj, fv_sg_adj_weak, & + sg_cutoff, breed_vortex_inline, & na_init, nudge_dz, hybrid_z, Make_NH, n_zs_filter, nord_zs_filter, full_zs_filter, reset_eta, & - pnats, dnats, dnrts, a2b_ord, remap_t, p_ref, d2_bg_k1, d2_bg_k2, & - c2l_ord, dx_const, dy_const, umax, deglat, domain_deg, & + pnats, dnats, dnrts, remap_t, p_ref, d2_bg_k1, d2_bg_k2, & + dx_const, dy_const, umax, deglat, domain_deg, & deglon_start, deglon_stop, deglat_start, deglat_stop, & - phys_hydrostatic, use_hydro_pressure, make_hybrid_z, old_divg_damp, add_noise, & + phys_hydrostatic, use_hydro_pressure, make_hybrid_z, add_noise, & nested, twowaynest, nudge_qv, & nestbctype, nestupdate, nsponge, s_weight, & check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, & do_uni_zfull, adj_mass_vmr, update_blend, regional,& bc_update_interval, nrows_blend, write_restart_with_bcs, regional_bcs_from_gsi, & - w_limiter, write_coarse_restart_files, write_coarse_diagnostics,& + write_coarse_restart_files, write_coarse_diagnostics,& write_only_coarse_intermediate_restarts, & write_coarse_agrid_vel_rst, write_coarse_dgrid_vel_rst, & restart_from_agrid_winds, write_optional_dgrid_vel_rst, & @@ -1035,15 +1028,7 @@ subroutine read_namelist_fv_core_nml(Atm) write(*,199) 'Using p_split = ', p_split endif - if (old_divg_damp) then - if (is_master()) write(*,*) " fv_control: using AM2/AM3 damping methods " - d2_bg_k1 = 6. ! factor for d2_bg (k=1) - default(4.) - d2_bg_k2 = 4. ! factor for d2_bg (k=2) - default(2.) - d2_divg_max_k1 = 0.02 ! d2_divg max value (k=1) - default(0.05) - d2_divg_max_k2 = 0.01 ! d2_divg max value (k=2) - default(0.02) - damp_k_k1 = 0. ! damp_k value (k=1) - default(0.05) - damp_k_k2 = 0. ! damp_k value (k=2) - default(0.025) - elseif (n_sponge == 0 ) then + if (n_sponge == 0 ) then if ( d2_bg_k1 > 1. ) d2_bg_k1 = 0.20 if ( d2_bg_k2 > 1. ) d2_bg_k2 = 0.015 endif @@ -1099,12 +1084,58 @@ subroutine read_namelist_fv_core_nml(Atm) call mpp_error(NOTE, " The old PPM remapping operators will be removed in a future release.") endif - if (do_am4_remap) then - call mpp_error(NOTE, "** DEPRECATED DO_AM4_REMAP **") - call mpp_error(NOTE, " This switch is no longer necessary because the AM4 kord=10 has been") - call mpp_error(NOTE, " restored to normal operation.") + if (convert_ke) then + call mpp_error(NOTE, " The convert_ke option will be removed in a future release.") + call mpp_error(NOTE, " Use d_con > 0. instead.") endif + !Check over tracer options for unwise values + if (ANY(tp_unlim_schemes == hord_tr)) then + call mpp_error(NOTE, "** NON-MONOTONE/NON-POSITIVE TRACER ADVECTION **") + call mpp_error(NOTE, " The value of hord_tr will not prevent negatives. " ) + call mpp_error(NOTE, " Consider a monotonic or positive-definite scheme. ") + call mpp_error(NOTE, " Recommended: Mono = 8; PD = -5.") + endif + if (.not. ANY(tp_valid_schemes == hord_tr)) then + call mpp_error(FATAL, "** Invalid hord_tr ** Use hord_tr > 0 or hord_tr == -5") + endif + if (.not. ANY(tp_valid_schemes == hord_dp)) then + call mpp_error(FATAL, "** Invalid hord_dp ** Use hord_dp > 0 or hord_tr == -5") + endif + if (.not. ANY(tp_valid_schemes == hord_tm)) then + call mpp_error(FATAL, "** Invalid hord_tm ** Use hord_tm > 0") + endif + if (.not. ANY(tp_valid_schemes == hord_mt)) then + call mpp_error(FATAL, "** Invalid hord_mt ** Use hord_mt > 0") + endif + if (.not. ANY(tp_valid_schemes == hord_vt)) then + call mpp_error(FATAL, "** Invalid hord_vt ** Use hord_vt > 0") + endif + if (ANY(tp_PD_schemes == hord_tm) .and. .not. hydrostatic) then + call mpp_error(NOTE, "** POSITIVE-DEFINITE hord_tm SELECTED **") + call mpp_error(NOTE, " This may give unphysical results " ) + call mpp_error(NOTE, " Consider a monotonic or unlimited scheme. ") + call mpp_error(NOTE, " Recommended: Mono = 8; unlim = 5, 6, or 10.") + endif + if (ANY(tp_PD_schemes == hord_mt)) then + call mpp_error(NOTE, "** POSITIVE-DEFINITE hord_mt SELECTED **") + call mpp_error(NOTE, " This may give unphysical results " ) + call mpp_error(NOTE, " Consider a monotonic or unlimited scheme. ") + call mpp_error(NOTE, " Recommended: Mono = 8; unlim = 5, 6, or 10.") + endif + if (ANY(tp_PD_schemes == hord_vt)) then + call mpp_error(NOTE, "** POSITIVE-DEFINITE hord_vt SELECTED **") + call mpp_error(NOTE, " This may give unphysical results " ) + call mpp_error(NOTE, " Consider a monotonic or unlimited scheme. ") + call mpp_error(NOTE, " Recommended: Mono = 8; unlim = 5, 6, or 10.") + endif + + if (.not. moist_phys) then + call mpp_error(NOTE, "** Deprecated moist_phys = .false. **") + call mpp_error(NOTE, " The moist_phys = .false. capability is being") + call mpp_error(NOTE, " removed and will be replaced with a separate") + call mpp_error(NOTE, " option to turn off the virtual effect soon.") + endif end subroutine read_namelist_fv_core_nml diff --git a/model/fv_dynamics.F90 b/model/fv_dynamics.F90 index 8c553e0a8..c657be222 100644 --- a/model/fv_dynamics.F90 +++ b/model/fv_dynamics.F90 @@ -27,9 +27,10 @@ module fv_dynamics_mod #endif use fv_arrays_mod, only: radius, omega ! scaled for small earth use dyn_core_mod, only: dyn_core, del2_cubed, init_ijk_mem - use fv_mapz_mod, only: compute_total_energy, Lagrangian_to_Eulerian, moist_cv, moist_cp + use fv_mapz_mod, only: Lagrangian_to_Eulerian + use fv_thermodynamics_mod, only: compute_total_energy, moist_cv, moist_cp use fv_tracer2d_mod, only: tracer_2d, tracer_2d_1L, tracer_2d_nested - use fv_grid_utils_mod, only: cubed_to_latlon, c2l_ord2, g_sum + use fv_grid_utils_mod, only: cubed_to_latlon, g_sum use fv_fill_mod, only: fill2D use fv_mp_mod, only: is_master use fv_mp_mod, only: group_halo_update_type @@ -48,8 +49,8 @@ module fv_dynamics_mod use fv_regional_mod, only: a_step, p_step, k_step use fv_regional_mod, only: current_time_in_seconds use boundary_mod, only: nested_grid_BC_apply_intT - use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_atmos_type, fv_nest_type, & - fv_diag_type, fv_grid_bounds_type, inline_mp_type + use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_atmos_type, fv_nest_type + use fv_arrays_mod, only: fv_diag_type, fv_grid_bounds_type, inline_mp_type, fv_thermo_type use fv_nwp_nudge_mod, only: do_adiabatic_init implicit none @@ -80,8 +81,8 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, q_split, u0, v0, u, v, w, delz, hydrostatic, pt, delp, q, & ps, pe, pk, peln, pkz, phis, q_con, omga, ua, va, uc, vc, & ak, bk, mfx, mfy, cx, cy, ze0, hybrid_z, & - gridstruct, flagstruct, neststruct, idiag, bd, & - parent_grid, domain, inline_mp, diss_est, time_total) + gridstruct, flagstruct, neststruct, thermostruct, idiag, bd, & + parent_grid, domain, inline_mp, heat_source, diss_est, time_total) real, intent(IN) :: bdt ! Large time-step real, intent(IN) :: consv_te @@ -114,7 +115,8 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) ! specific humidity and constituents real, intent(inout) :: delz(bd%is:,bd%js:,1:) ! delta-height (m); non-hydrostatic only real, intent(inout) :: ze0(bd%is:, bd%js: ,1:) ! height at edges (m); non-hydrostatic - real, intent(inout) :: diss_est(bd%isd:bd%ied ,bd%jsd:bd%jed, npz) ! diffusion estimate for SKEB + real, intent(inout) :: diss_est(bd%isd:bd%ied,bd%jsd:bd%jed,npz) ! diffusion estimate for SKEB + real, intent(inout) :: heat_source(bd%isd:bd%ied ,bd%jsd:bd%jed, npz) ! Dissipative heating ! ze0 no longer used !----------------------------------------------------------------------- @@ -155,6 +157,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, type(domain2d), intent(INOUT) :: domain type(fv_atmos_type), pointer, intent(IN) :: parent_grid type(fv_diag_type), intent(IN) :: idiag + type(fv_thermo_type), intent(INOUT) :: thermostruct ! Local Arrays real:: ws(bd%is:bd%ie,bd%js:bd%je) @@ -200,28 +203,26 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, allocate ( dp1(isd:ied, jsd:jed, 1:npz) ) -#ifdef MOIST_CAPPA - allocate ( cappa(isd:ied,jsd:jed,npz) ) - call init_ijk_mem(isd,ied, jsd,jed, npz, cappa, 0.) -#else - allocate ( cappa(isd:isd,jsd:jsd,1) ) - cappa = 0. -#endif + if (thermostruct%moist_kappa) then + allocate ( cappa(isd:ied,jsd:jed,npz) ) + call init_ijk_mem(isd,ied, jsd,jed, npz, cappa, 0.) + else + allocate ( cappa(isd:isd,jsd:jsd,1) ) + cappa = 0. + endif + !We call this BEFORE converting pt to virtual potential temperature, !since we interpolate on (regular) temperature rather than theta. + +!NOTE: are q_con and moist_kappa set up yet?? Probably not! if (gridstruct%nested .or. ANY(neststruct%child_grids)) then call timing_on('NEST_BCs') call setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & u, v, w, pt, delp, delz, q, uc, vc, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif + q_con, cappa, & neststruct%nested, flagstruct%inline_q, flagstruct%make_nh, ng, & - gridstruct, flagstruct, neststruct, & + gridstruct, flagstruct, neststruct, thermostruct, & neststruct%nest_timestep, neststruct%tracer_nest_timestep, & domain, parent_grid, bd, nwat, ak, bk) @@ -237,14 +238,8 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, reg_bc_update_time=current_time_in_seconds call set_regional_BCs & !<-- Insert values into the boundary region valid for the start of this large timestep. - (delp,w,pt & -#ifdef USE_COND - ,q_con & -#endif -#ifdef MOIST_CAPPA - ,cappa & -#endif - ,q,u,v,uc,vc, bd, npz, reg_bc_update_time ) + (delp,w,pt,q_con,cappa,q,u,v,uc,vc, bd, npz, & + reg_bc_update_time, thermostruct%use_cond, thermostruct%moist_kappa ) call timing_off('Regional_BCs') endif @@ -285,15 +280,21 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, pfull(k) = (ph2 - ph1) / log(ph2/ph1) enddo +! call compute_q_con(bd, npz, nwat, q, q_con) if ( hydrostatic ) then -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,zvir,nwat,q,q_con,sphum,liq_wat, & + if (thermostruct%use_cond) then +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,zvir,nwat,q,q_con,sphum,liq_wat, & !$OMP rainwat,ice_wat,snowwat,graupel) private(cvm) - do k=1,npz - do j=js,je -#ifdef USE_COND + do k=1,npz + do j=js,je call moist_cp(is,ie,isd,ied,jsd,jed, npz, j, k, nwat, sphum, liq_wat, rainwat, & ice_wat, snowwat, graupel, q, q_con(is:ie,j,k), cvm) -#endif + enddo + enddo + endif +!$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,zvir,q,sphum) + do k=1,npz + do j=js,je do i=is,ie dp1(i,j,k) = zvir*q(i,j,k,sphum) enddo @@ -302,56 +303,34 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, else !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,zvir,q,q_con,sphum,liq_wat, & !$OMP rainwat,ice_wat,snowwat,graupel,pkz,flagstruct, & -!$OMP cappa,kappa,rdg,delp,pt,delz,nwat) & +!$OMP cappa,kappa,rdg,delp,pt,delz,nwat,thermostruct) & !$OMP private(cvm) do k=1,npz - if ( flagstruct%moist_phys ) then + if (thermostruct%moist_kappa) then do j=js,je -#ifdef MOIST_CAPPA call moist_cv(is,ie,isd,ied,jsd,jed, npz, j, k, nwat, sphum, liq_wat, rainwat, & ice_wat, snowwat, graupel, q, q_con(is:ie,j,k), cvm) -#endif do i=is,ie dp1(i,j,k) = zvir*q(i,j,k,sphum) -#ifdef MOIST_CAPPA - cappa(i,j,k) = rdgas/(rdgas + cvm(i)/(1.+dp1(i,j,k))) - pkz(i,j,k) = exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k)* & + cappa(i,j,k) = rdgas/(rdgas + cvm(i)/(1.+dp1(i,j,k))) + pkz(i,j,k) = exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k)* & (1.+dp1(i,j,k))*(1.-q_con(i,j,k))/delz(i,j,k)) ) -#else - pkz(i,j,k) = exp( kappa*log(rdg*delp(i,j,k)*pt(i,j,k)* & - (1.+dp1(i,j,k))/delz(i,j,k)) ) -! Using dry pressure for the definition of the virtual potential temperature -! pkz(i,j,k) = exp( kappa*log(rdg*delp(i,j,k)*pt(i,j,k)* & -! (1.-q(i,j,k,sphum))/delz(i,j,k)) ) -#endif enddo enddo else - do j=js,je -#ifdef MOIST_CAPPA - call moist_cv(is,ie,isd,ied,jsd,jed, npz, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, q_con(is:ie,j,k), cvm) -#endif - do i=is,ie - dp1(i,j,k) = zvir*q(i,j,k,sphum) -#ifdef MOIST_CAPPA - cappa(i,j,k) = rdgas/(rdgas + cvm(i)/(1.+dp1(i,j,k))) - pkz(i,j,k) = exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k)* & - (1.+dp1(i,j,k))*(1.-q_con(i,j,k))/delz(i,j,k)) ) -#else - dp1(i,j,k) = 0. - pkz(i,j,k) = exp(kappa*log(rdg*delp(i,j,k)*pt(i,j,k)/delz(i,j,k))) -#endif - enddo - enddo - endif - enddo - endif + do j=js,je + do i=is,ie + dp1(i,j,k) = zvir*q(i,j,k,sphum) + pkz(i,j,k) = exp( kappa*log(rdg*delp(i,j,k)*pt(i,j,k)* & + (1.+dp1(i,j,k))/delz(i,j,k)) ) + enddo + enddo + endif + enddo + endif if ( flagstruct%fv_debug ) then -#ifdef MOIST_CAPPA - call prt_mxm('cappa', cappa, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) -#endif + if (thermostruct%moist_kappa) call prt_mxm('cappa', cappa, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) call prt_mxm('PS', ps, is, ie, js, je, ng, 1, 0.01, gridstruct%area_64, domain) call prt_mxm('T_dyn_b', pt, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) if ( .not. hydrostatic) call prt_mxm('delz', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) @@ -369,49 +348,56 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, gridstruct%rsin2, gridstruct%cosa_s, & zvir, cp_air, rdgas, hlv, te_2d, ua, va, teq, & flagstruct%moist_phys, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, hydrostatic, idiag%id_te) + ice_wat, snowwat, graupel, hydrostatic, & + thermostruct%moist_kappa, idiag%id_te) if( idiag%id_te>0 ) then used = send_data(idiag%id_te, teq, fv_time) -! te_den=1.E-9*g_sum(teq, is, ie, js, je, ng, area, 0)/(grav*4.*pi*radius**2) -! if(is_master()) write(*,*) 'Total Energy Density (Giga J/m**2)=',te_den endif endif if( (flagstruct%consv_am .or. idiag%id_amdt>0) .and. (.not.do_adiabatic_init) ) then - call compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & - ptop, ua, va, u, v, delp, teq, ps2, m_fac) + call compute_aam(npx, npy, npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & + ptop, ua, va, u, v, delp, teq, ps2, m_fac, domain) endif if( .not.flagstruct%RF_fast .and. flagstruct%tau > 0. ) then if ( gridstruct%grid_type<4 .or. gridstruct%bounded_domain .or. flagstruct%is_ideal_case ) then -! if ( flagstruct%RF_fast ) then -! call Ray_fast(abs(dt), npx, npy, npz, pfull, flagstruct%tau, u, v, w, & -! dp_ref, ptop, hydrostatic, flagstruct%rf_cutoff, bd) -! else call Rayleigh_Super(abs(bdt), npx, npy, npz, ks, pfull, phis, flagstruct%tau, u0, v0, u, v, w, pt, & ua, va, delz, gridstruct%agrid, cp_air, rdgas, ptop, hydrostatic, & .not. (gridstruct%bounded_domain .or. flagstruct%is_ideal_case), flagstruct%rf_cutoff, gridstruct, domain, bd, flagstruct%is_ideal_case) -! endif else call Rayleigh_Friction(abs(bdt), npx, npy, npz, ks, pfull, flagstruct%tau, u, v, w, pt, & ua, va, delz, cp_air, rdgas, ptop, hydrostatic, .true., flagstruct%rf_cutoff, gridstruct, domain, bd) endif endif -! Convert pt to virtual potential temperature on the first timestep +! Convert pt to virtual potential density temperature on the first timestep + if (thermostruct%use_cond) then !$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,dp1,pkz,q_con) - do k=1,npz - do j=js,je - do i=is,ie -#ifdef USE_COND - pt(i,j,k) = pt(i,j,k)*(1.+dp1(i,j,k))*(1.-q_con(i,j,k))/pkz(i,j,k) -#else - pt(i,j,k) = pt(i,j,k)*(1.+dp1(i,j,k))/pkz(i,j,k) -#endif - enddo - enddo - enddo -#endif !end ifdef SW_DYNAMICS + do k=1,npz + do j=js,je + do i=is,ie + pt(i,j,k) = pt(i,j,k)*(1.+dp1(i,j,k))*(1.-q_con(i,j,k))/pkz(i,j,k) + enddo + enddo + enddo + thermostruct%pt_is_potential = .true. + if (zvir > 0.) thermostruct%pt_is_virtual = .true. + thermostruct%pt_is_density = .true. + else +!$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,dp1,pkz) + do k=1,npz + do j=js,je + do i=is,ie + pt(i,j,k) = pt(i,j,k)*(1.+dp1(i,j,k))/pkz(i,j,k) + enddo + enddo + enddo + thermostruct%pt_is_potential = .true. + if (zvir > 0.) thermostruct%pt_is_virtual = .true. + thermostruct%pt_is_density = .false. + endif +#endif SW_DYNAMICS last_step = .false. mdt = bdt / real(k_split) @@ -439,6 +425,34 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, if (allocated(inline_mp%t_dt)) inline_mp%t_dt = 0.0 if (allocated(inline_mp%u_dt)) inline_mp%u_dt = 0.0 if (allocated(inline_mp%v_dt)) inline_mp%v_dt = 0.0 + inline_mp%mppcw = 0.0 + inline_mp%mppew = 0.0 + inline_mp%mppe1 = 0.0 + inline_mp%mpper = 0.0 + inline_mp%mppdi = 0.0 + inline_mp%mppd1 = 0.0 + inline_mp%mppds = 0.0 + inline_mp%mppdg = 0.0 + inline_mp%mppsi = 0.0 + inline_mp%mpps1 = 0.0 + inline_mp%mppss = 0.0 + inline_mp%mppsg = 0.0 + inline_mp%mppfw = 0.0 + inline_mp%mppfr = 0.0 + inline_mp%mppmi = 0.0 + inline_mp%mppms = 0.0 + inline_mp%mppmg = 0.0 + inline_mp%mppm1 = 0.0 + inline_mp%mppm2 = 0.0 + inline_mp%mppm3 = 0.0 + inline_mp%mppar = 0.0 + inline_mp%mppas = 0.0 + inline_mp%mppag = 0.0 + inline_mp%mpprs = 0.0 + inline_mp%mpprg = 0.0 + inline_mp%mppxr = 0.0 + inline_mp%mppxs = 0.0 + inline_mp%mppxg = 0.0 endif call timing_on('FV_DYN_LOOP') @@ -446,18 +460,17 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, do n_map=1, k_split ! first level of time-split k_step = n_map call timing_on('COMM_TOTAL') -#ifdef USE_COND - call start_group_halo_update(i_pack(11), q_con, domain) -#ifdef MOIST_CAPPA - call start_group_halo_update(i_pack(12), cappa, domain) -#endif -#endif + if (thermostruct%use_cond) then + call start_group_halo_update(i_pack(11), q_con, domain) + if (thermostruct%moist_kappa) call start_group_halo_update(i_pack(12), cappa, domain) + endif call start_group_halo_update(i_pack(1), delp, domain, complete=.false.) call start_group_halo_update(i_pack(1), pt, domain, complete=.true.) #ifndef ROT3 call start_group_halo_update(i_pack(8), u, v, domain, gridtype=DGRID_NE) #endif call timing_off('COMM_TOTAL') +! dp1 now delp before dyn_core; used for subcycled tracer advection !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,dp1,delp) do k=1,npz do j=jsd,jed @@ -469,21 +482,19 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, if ( n_map==k_split ) last_step = .true. -#ifdef USE_COND - call timing_on('COMM_TOTAL') - call complete_group_halo_update(i_pack(11), domain) -#ifdef MOIST_CAPPA - call complete_group_halo_update(i_pack(12), domain) -#endif - call timing_off('COMM_TOTAL') -#endif + if (thermostruct%use_cond) then + call timing_on('COMM_TOTAL') + call complete_group_halo_update(i_pack(11), domain) + if (thermostruct%moist_kappa) call complete_group_halo_update(i_pack(12), domain) + call timing_off('COMM_TOTAL') + endif call timing_on('DYN_CORE') call dyn_core(npx, npy, npz, ng, sphum, nq, mdt, n_map, n_split, zvir, cp_air, akap, cappa, grav, hydrostatic, & u, v, w, delz, pt, q, delp, pe, pk, phis, ws, omga, ptop, pfull, ua, va, & uc, vc, mfx, mfy, cx, cy, pkz, peln, q_con, ak, bk, ks, & - gridstruct, flagstruct, neststruct, idiag, bd, & - domain, n_map==1, i_pack, last_step, diss_est, & + gridstruct, flagstruct, neststruct, thermostruct, idiag, bd, & + domain, n_map==1, i_pack, last_step, heat_source, diss_est, & consv_te, te_2d, time_total) call timing_off('DYN_CORE') @@ -508,17 +519,17 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, !!! CLEANUP: merge these two calls? if (gridstruct%bounded_domain) then call tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, & - flagstruct%hord_tr, q_split, mdt, idiag%id_divg, i_pack(10), i_pack(13), & + flagstruct%hord_tr, q_split, mdt, idiag%id_divg_mean, i_pack(10), i_pack(13), & flagstruct%nord_tr, flagstruct%trdm2, & k_split, neststruct, parent_grid, n_map, flagstruct%lim_fac) else if ( flagstruct%z_tracer ) then call tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, & - flagstruct%hord_tr, q_split, mdt, idiag%id_divg, i_pack(10), i_pack(13), & + flagstruct%hord_tr, q_split, mdt, idiag%id_divg_mean, i_pack(10), i_pack(13), & flagstruct%nord_tr, flagstruct%trdm2, flagstruct%lim_fac) else call tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, & - flagstruct%hord_tr, q_split, mdt, idiag%id_divg, i_pack(10), i_pack(13), & + flagstruct%hord_tr, q_split, mdt, idiag%id_divg_mean, i_pack(10), i_pack(13), & flagstruct%nord_tr, flagstruct%trdm2, flagstruct%lim_fac) endif endif @@ -541,9 +552,9 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, endif #endif - if( last_step .and. idiag%id_divg>0 ) then - used = send_data(idiag%id_divg, dp1, fv_time) - if(flagstruct%fv_debug) call prt_mxm('divg', dp1, is, ie, js, je, 0, npz, 1.,gridstruct%area_64, domain) + if( last_step .and. idiag%id_divg_mean>0 ) then + used = send_data(idiag%id_divg_mean, dp1(is:ie,js:je,:), fv_time) + if(flagstruct%fv_debug) call prt_mxm('divg_mean', dp1, is, ie, js, je, 0, npz, 1.,gridstruct%area_64, domain) endif endif @@ -599,12 +610,12 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, zvir, cp_air, flagstruct%te_err, flagstruct%tw_err, akap, cappa, flagstruct%kord_mt, flagstruct%kord_wz, & kord_tracer, flagstruct%kord_tm, flagstruct%remap_te, peln, te_2d, & ng, ua, va, omga, dp1, ws, fill, reproduce_sum, & - ptop, ak, bk, pfull, gridstruct, domain, & + ptop, ak, bk, pfull, gridstruct, thermostruct, domain, & flagstruct%do_sat_adj, hydrostatic, & hybrid_z, & flagstruct%adiabatic, do_adiabatic_init, flagstruct%do_inline_mp, & - inline_mp, flagstruct%c2l_ord, bd, flagstruct%fv_debug, & - flagstruct%w_limiter, flagstruct%do_fast_phys, flagstruct%do_intermediate_phys, & + inline_mp, bd, flagstruct%fv_debug, & + flagstruct%do_fast_phys, flagstruct%do_intermediate_phys, & flagstruct%consv_checker, flagstruct%adj_mass_vmr) if ( flagstruct%fv_debug ) then @@ -626,13 +637,13 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, call timing_off('Remapping') -#ifdef MOIST_CAPPA - if ( neststruct%nested .and. .not. last_step) then + if (thermostruct%moist_kappa .and. .not. last_step) then + if ( neststruct%nested ) then call nested_grid_BC_apply_intT(cappa, & 0, 0, npx, npy, npz, bd, real(n_map+1), real(k_split), & neststruct%cappa_BC, bctype=neststruct%nestbctype ) endif - if ( flagstruct%regional .and. .not. last_step) then + if ( flagstruct%regional ) then reg_bc_update_time=current_time_in_seconds+(n_map+1)*mdt call regional_boundary_update(cappa, 'cappa', & isd, ied, jsd, jed, npz, & @@ -640,7 +651,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, isd, ied, jsd, jed, & reg_bc_update_time,1 ) endif -#endif + endif !-------------------------- ! Filter omega for physics: !-------------------------- @@ -678,6 +689,34 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, if (allocated(inline_mp%t_dt)) inline_mp%t_dt = inline_mp%t_dt / bdt if (allocated(inline_mp%u_dt)) inline_mp%u_dt = inline_mp%u_dt / bdt if (allocated(inline_mp%v_dt)) inline_mp%v_dt = inline_mp%v_dt / bdt + inline_mp%mppcw = inline_mp%mppcw / k_split + inline_mp%mppew = inline_mp%mppew / k_split + inline_mp%mppe1 = inline_mp%mppe1 / k_split + inline_mp%mpper = inline_mp%mpper / k_split + inline_mp%mppdi = inline_mp%mppdi / k_split + inline_mp%mppd1 = inline_mp%mppd1 / k_split + inline_mp%mppds = inline_mp%mppds / k_split + inline_mp%mppdg = inline_mp%mppdg / k_split + inline_mp%mppsi = inline_mp%mppsi / k_split + inline_mp%mpps1 = inline_mp%mpps1 / k_split + inline_mp%mppss = inline_mp%mppss / k_split + inline_mp%mppsg = inline_mp%mppsg / k_split + inline_mp%mppfw = inline_mp%mppfw / k_split + inline_mp%mppfr = inline_mp%mppfr / k_split + inline_mp%mppmi = inline_mp%mppmi / k_split + inline_mp%mppms = inline_mp%mppms / k_split + inline_mp%mppmg = inline_mp%mppmg / k_split + inline_mp%mppm1 = inline_mp%mppm1 / k_split + inline_mp%mppm2 = inline_mp%mppm2 / k_split + inline_mp%mppm3 = inline_mp%mppm3 / k_split + inline_mp%mppar = inline_mp%mppar / k_split + inline_mp%mppas = inline_mp%mppas / k_split + inline_mp%mppag = inline_mp%mppag / k_split + inline_mp%mpprs = inline_mp%mpprs / k_split + inline_mp%mpprg = inline_mp%mpprg / k_split + inline_mp%mppxr = inline_mp%mppxr / k_split + inline_mp%mppxs = inline_mp%mppxs / k_split + inline_mp%mppxg = inline_mp%mppxg / k_split endif if( nwat==6 ) then @@ -706,63 +745,64 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, endif if( (flagstruct%consv_am.or.idiag%id_amdt>0.or.idiag%id_aam>0) .and. (.not.do_adiabatic_init) ) then - call compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & - ptop, ua, va, u, v, delp, te_2d, ps, m_fac) - if( idiag%id_aam>0 ) then - used = send_data(idiag%id_aam, te_2d, fv_time) - endif - if ( idiag%id_aam>0 .or. flagstruct%consv_am ) then - if ( prt_minmax ) then - gam = g_sum( domain, te_2d, is, ie, js, je, ng, gridstruct%area_64, 0) - if( is_master() ) write(6,*) 'Total AAM =', gam - endif - endif - endif - - if( (flagstruct%consv_am.or.idiag%id_amdt>0) .and. (.not.do_adiabatic_init) ) then -!$OMP parallel do default(none) shared(is,ie,js,je,te_2d,teq,dt2,ps2,ps,idiag) - do j=js,je - do i=is,ie -! Note: the mountain torque computation contains also numerical error -! The numerical error is mostly from the zonal gradient of the terrain (zxg) - te_2d(i,j) = te_2d(i,j)-teq(i,j) + dt2*(ps2(i,j)+ps(i,j))*idiag%zxg(i,j) - enddo - enddo - if( idiag%id_amdt>0 ) used = send_data(idiag%id_amdt, te_2d/bdt, fv_time) + call compute_aam(npx, npy, npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & + ptop, ua, va, u, v, delp, te_2d, ps, m_fac, domain) + if( idiag%id_aam>0 ) then + used = send_data(idiag%id_aam, te_2d, fv_time) + endif + if ( idiag%id_aam>0 .or. flagstruct%consv_am ) then + if ( prt_minmax ) then + gam = g_sum( domain, te_2d, is, ie, js, je, ng, gridstruct%area_64, 0) + if( is_master() ) write(6,*) ' Total AAM =', gam + endif + endif - if ( flagstruct%consv_am .or. prt_minmax ) then - amdt = g_sum( domain, te_2d, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.) - u00 = -radius*amdt/g_sum( domain, m_fac, is, ie, js, je, ng, gridstruct%area_64, 0,reproduce=.true.) - if(is_master() .and. prt_minmax) & - write(6,*) 'Dynamic AM tendency (Hadleys)=', amdt/(bdt*1.e18), 'del-u (per day)=', u00*86400./bdt - endif + !$OMP parallel do default(none) shared(is,ie,js,je,te_2d,teq,dt2,ps2,ps,idiag) + do j=js,je + do i=is,ie + ! Note: the mountain torque computation contains also numerical error + ! The numerical error is mostly from the zonal gradient of the terrain (zxg) + te_2d(i,j) = te_2d(i,j)-teq(i,j) + dt2*(ps2(i,j)+ps(i,j))*idiag%zxg(i,j) + enddo + enddo + if ( idiag%id_amdt>0 ) used = send_data(idiag%id_amdt, te_2d/bdt, fv_time) + + if ( flagstruct%consv_am .or. idiag%id_amdt>0 ) then + amdt = g_sum( domain, te_2d, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.) + u00 = -radius*amdt/g_sum( domain, m_fac, is, ie, js, je, ng, gridstruct%area_64, 0,reproduce=.true.) + if(is_master() .and. prt_minmax) then + write(6,*) ' Dynamic AM tendency (Hadleys)=', amdt/(bdt*1.e18) + write(6,*) ' del-u (per day)=', u00*86400./bdt + endif + endif - if( flagstruct%consv_am ) then -!$OMP parallel do default(none) shared(is,ie,js,je,m_fac,u00,gridstruct) - do j=js,je - do i=is,ie - m_fac(i,j) = u00*cos(gridstruct%agrid(i,j,2)) - enddo - enddo -!$OMP parallel do default(none) shared(is,ie,js,je,npz,hydrostatic,pt,m_fac,ua,cp_air, & -!$OMP u,u00,gridstruct,v ) - do k=1,npz - do j=js,je+1 - do i=is,ie - u(i,j,k) = u(i,j,k) + u00*gridstruct%l2c_u(i,j) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = v(i,j,k) + u00*gridstruct%l2c_v(i,j) - enddo - enddo - enddo - endif ! consv_am + if( flagstruct%consv_am ) then + !$OMP parallel do default(none) shared(is,ie,js,je,m_fac,u00,gridstruct) + do j=js,je + do i=is,ie + m_fac(i,j) = u00*cos(gridstruct%agrid(i,j,2)) + enddo + enddo + !$OMP parallel do default(none) shared(is,ie,js,je,npz,hydrostatic,pt,m_fac,ua,cp_air, & + !$OMP u,u00,gridstruct,v ) + do k=1,npz + do j=js,je+1 + do i=is,ie + u(i,j,k) = u(i,j,k) + u00*gridstruct%l2c_u(i,j) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j,k) = v(i,j,k) + u00*gridstruct%l2c_v(i,j) + enddo + enddo + enddo + endif ! consv_am endif 911 call cubed_to_latlon(u, v, ua, va, gridstruct, & - npx, npy, npz, 1, gridstruct%grid_type, domain, gridstruct%bounded_domain, flagstruct%c2l_ord, bd) + npx, npy, npz, 1, gridstruct%grid_type, & + domain, gridstruct%bounded_domain, 4, bd) deallocate(dp1) deallocate(cappa) @@ -997,7 +1037,9 @@ subroutine Rayleigh_Super(dt, npx, npy, npz, ks, pm, phis, tau, u0, v0, u, v, & RF_initialized = .true. endif - call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) + call cubed_to_latlon(u, v, ua, va, gridstruct, & + npx, npy, npz, 1, gridstruct%grid_type, & + domain, gridstruct%bounded_domain, 2, bd) allocate( u2f(isd:ied,jsd:jed,kmax) ) @@ -1141,7 +1183,9 @@ subroutine Rayleigh_Friction(dt, npx, npy, npz, ks, pm, tau, u, v, w, pt, & allocate( u2f(isd:ied,jsd:jed,kmax) ) - call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) + call cubed_to_latlon(u, v, ua, va, gridstruct, & + npx, npy, npz, 1, gridstruct%grid_type, & + domain, gridstruct%bounded_domain, 2, bd) !$OMP parallel do default(none) shared(is,ie,js,je,kmax,u2f,hydrostatic,ua,va,w) do k=1,kmax @@ -1219,10 +1263,10 @@ subroutine Rayleigh_Friction(dt, npx, npy, npz, ks, pm, tau, u, v, w, pt, & end subroutine Rayleigh_Friction - subroutine compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & - ptop, ua, va, u, v, delp, aam, ps, m_fac) + subroutine compute_aam(npx, npy, npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & + ptop, ua, va, u, v, delp, aam, ps, m_fac, domain) ! Compute vertically (mass) integrated Atmospheric Angular Momentum - integer, intent(in):: npz + integer, intent(in):: npx, npy, npz integer, intent(in):: is, ie, js, je integer, intent(in):: isd, ied, jsd, jed real, intent(in):: ptop @@ -1235,11 +1279,16 @@ subroutine compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, real, intent(out):: ps(isd:ied,jsd:jed) type(fv_grid_bounds_type), intent(IN) :: bd type(fv_grid_type), intent(IN) :: gridstruct + type(domain2d), intent(INOUT) :: domain ! local: real, dimension(is:ie):: r1, r2, dm integer i, j, k - call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) + call cubed_to_latlon(u, v, ua, va, gridstruct, & + npx, npy, npz, 1, gridstruct%grid_type, & + domain, gridstruct%bounded_domain, 2, bd) + + !call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) !$OMP parallel do default(none) shared(is,ie,js,je,npz,gridstruct,aam,m_fac,ps,ptop,delp,agrav,ua,radius,omega) & !$OMP private(r1, r2, dm) diff --git a/model/fv_fill.F90 b/model/fv_fill.F90 index edcdff6d3..86e38bf88 100644 --- a/model/fv_fill.F90 +++ b/model/fv_fill.F90 @@ -138,11 +138,10 @@ subroutine fillz(im, km, nq, q, dp) enddo end subroutine fillz - subroutine fill_gfs(im, km, pe2, q, q_min) + subroutine fill_gfs(im, km, pe2, q) !SJL: this routine is the equivalent of fillz except that the vertical index is upside down integer, intent(in):: im, km real(kind=kind_phys), intent(in):: pe2(im,km+1) ! pressure interface - real(kind=kind_phys), intent(in):: q_min real(kind=kind_phys), intent(inout):: q(im,km) ! LOCAL VARIABLES: real(kind=kind_phys) :: dp(im,km) @@ -154,28 +153,28 @@ subroutine fill_gfs(im, km, pe2, q, q_min) enddo enddo + do i=1,im + ! From bottom up: - do k=1,km-1 - k1 = k+1 - do i=1,im - if ( q(i,k)= q_min - q(i,k1) = q(i,k1) + (q(i,k)-q_min)*dp(i,k)/dp(i,k1) - q(i,k ) = q_min + do k=1,km-1 + k1 = k+1 + if ( q(i,k)<0.0 ) then +! Take mass from above + q(i,k1) = q(i,k1) + q(i,k)*dp(i,k)/dp(i,k1) + q(i,k ) = 0. endif enddo - enddo ! From top down: - do k=km,2,-1 - k1 = k-1 - do i=1,im + do k=km,2,-1 + k1 = k-1 if ( q(i,k)<0.0 ) then ! Take mass from below q(i,k1) = q(i,k1) + q(i,k)*dp(i,k)/dp(i,k1) q(i,k ) = 0. endif enddo + enddo end subroutine fill_gfs diff --git a/model/fv_grid_utils.F90 b/model/fv_grid_utils.F90 index 4d4119c51..06a176cbd 100644 --- a/model/fv_grid_utils.F90 +++ b/model/fv_grid_utils.F90 @@ -63,7 +63,7 @@ module fv_grid_utils_mod public cos_angle public update_dwinds_phys, update2d_dwinds_phys, latlon2xyz, gnomonic_grids, & global_mx, unit_vect_latlon, & - cubed_to_latlon, c2l_ord2, g_sum, global_qsum, great_circle_dist, & + cubed_to_latlon, g_sum, global_qsum, great_circle_dist, & v_prod, get_unit_vect2, project_sphere_v public mid_pt_sphere, mid_pt_cart, vect_cross, grid_utils_init, grid_utils_end, & spherical_angle, cell_center2, get_area, inner_prod, fill_ghost, & @@ -81,12 +81,12 @@ module fv_grid_utils_mod contains - subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) + subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type) ! Initialize 2D memory and geometrical factors type(fv_atmos_type), intent(inout), target :: Atm logical, intent(in):: non_ortho integer, intent(in):: npx, npy, npz - integer, intent(in):: grid_type, c2l_order + integer, intent(in):: grid_type ! ! Super (composite) grid: @@ -675,7 +675,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) enddo ! Initialize cubed_sphere to lat-lon transformation: - call init_cubed_to_latlon( Atm%gridstruct, Atm%flagstruct%hydrostatic, agrid, grid_type, c2l_order, Atm%bd ) + call init_cubed_to_latlon( Atm%gridstruct, Atm%flagstruct%hydrostatic, agrid, grid_type, Atm%bd ) call global_mx(area, Atm%ng, Atm%gridstruct%da_min, Atm%gridstruct%da_max, Atm%bd) if( is_master() ) write(*,'(A, G20.8)') 'da_max/da_min=', Atm%gridstruct%da_max/Atm%gridstruct%da_min @@ -2252,12 +2252,11 @@ real(kind=R_GRID) function v_prod(v1, v2) end function v_prod - subroutine init_cubed_to_latlon( gridstruct, hydrostatic, agrid, grid_type, ord, bd ) + subroutine init_cubed_to_latlon( gridstruct, hydrostatic, agrid, grid_type, bd ) type(fv_grid_bounds_type), intent(IN) :: bd logical, intent(in):: hydrostatic real(kind=R_GRID), intent(in) :: agrid(bd%isd:bd%ied,bd%jsd:bd%jed,2) integer, intent(in) :: grid_type - integer, intent(in) :: ord type(fv_grid_type), intent(INOUT), target :: gridstruct integer i, j diff --git a/model/fv_mapz.F90 b/model/fv_mapz.F90 index cccbe7e2f..6e79e1632 100644 --- a/model/fv_mapz.F90 +++ b/model/fv_mapz.F90 @@ -19,48 +19,37 @@ !* If not, see . !*********************************************************************** -! SJL: Apr 12, 2012 -! This revision may actually produce rounding level differences due to the elimination of KS to compute -! pressure level for remapping. ! Linjiong Zhou: Nov 19, 2019 ! Revise the OpenMP code to avoid crash module fv_mapz_mod #ifdef OVERLOAD_R4 - use constantsR4_mod, only: pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor + use constantsR4_mod, only: pi=>pi_8, rdgas, grav, cp_air, cp_vapor #else - use constants_mod, only: pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor + use constants_mod, only: pi=>pi_8, rdgas, grav, cp_air, cp_vapor #endif use fv_arrays_mod, only: radius ! scaled for small earth - use tracer_manager_mod,only: get_tracer_index, adjust_mass + use tracer_manager_mod,only: get_tracer_index use field_manager_mod, only: MODEL_ATMOS use fv_grid_utils_mod, only: g_sum, ptop_min, cubed_to_latlon use fv_fill_mod, only: fillz - use mpp_domains_mod, only: mpp_update_domains, domain2d - use mpp_mod, only: FATAL, NOTE, mpp_error, get_unit, mpp_root_pe, mpp_pe + use mpp_domains_mod, only: domain2d + use mpp_mod, only: FATAL, NOTE, mpp_error use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, R_GRID, inline_mp_type use fv_timing_mod, only: timing_on, timing_off - use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max use intermediate_phys_mod, only: intermediate_phys - use gfdl_mp_mod, only: c_liq, c_ice + use fv_operators_mod, only: map_scalar, map1_ppm, mapn_tracer, map1_q2, map1_cubic + use fv_thermodynamics_mod, only: moist_cv, fv_thermo_type implicit none real, parameter:: consv_min = 0.001 ! below which no correction applies real, parameter:: t_min= 184. ! below which applies stricter constraint - real, parameter:: r3 = 1./3., r23 = 2./3., r12 = 1./12. - real, parameter:: cv_vap = 3.*rvgas ! 1384.5 real, parameter:: cv_air = cp_air - rdgas ! = rdgas * (7/2-1) = 2.5*rdgas=717.68 - real, parameter:: cp_vap = cp_vapor ! 1846. - real, parameter:: tice = 273.16 - - real, parameter :: w_max = 90. - real, parameter :: w_min = -60. real(kind=4) :: E_Flux = 0. private - public compute_total_energy, Lagrangian_to_Eulerian, moist_cv, moist_cp, & - rst_remap, mappm, E_Flux, remap_2d, map_scalar, consv_min, map1_q2 + public Lagrangian_to_Eulerian, E_Flux, consv_min contains @@ -69,14 +58,13 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, te_err, tw_err, & akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, remap_te, peln, te0_2d, & ng, ua, va, omga, te, ws, fill, reproduce_sum, & - ptop, ak, bk, pfull, gridstruct, domain, do_sat_adj, & + ptop, ak, bk, pfull, gridstruct, thermostruct, domain, do_sat_adj, & hydrostatic, hybrid_z, adiabatic, do_adiabatic_init, & - do_inline_mp, inline_mp, c2l_ord, bd, fv_debug, & - w_limiter, do_fast_phys, do_intermediate_phys, consv_checker, adj_mass_vmr) + do_inline_mp, inline_mp, bd, fv_debug, & + do_fast_phys, do_intermediate_phys, consv_checker, adj_mass_vmr) logical, intent(in):: last_step logical, intent(in):: fv_debug - logical, intent(in):: w_limiter logical, intent(in):: do_fast_phys logical, intent(in):: do_intermediate_phys logical, intent(in):: consv_checker @@ -95,7 +83,6 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & integer, intent(in):: kord_wz ! Mapping order/option for w integer, intent(in):: kord_tr(nq) ! Mapping order for tracers integer, intent(in):: kord_tm ! Mapping order for thermodynamics - integer, intent(in):: c2l_ord real, intent(in):: consv ! factor for TE conservation real, intent(in):: r_vir @@ -118,6 +105,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & real, intent(in) :: bk(km+1) real, intent(in):: pfull(km) type(fv_grid_type), intent(IN), target :: gridstruct + type(fv_thermo_type), intent(IN), target :: thermostruct type(domain2d), intent(INOUT) :: domain type(fv_grid_bounds_type), intent(IN) :: bd @@ -164,7 +152,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & real rcp, rg, rrg, bkh, dtmp, k1k, dlnp, tpe integer:: i,j,k - integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, w_diff, iq, n, kmp, kp, k_next + integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, iq, n, kmp, kp, k_next integer:: ccn_cm3, cin_cm3, aerosol k1k = rdgas/cv_air ! akap / (1.-akap) = rg/Cv=0.4 @@ -178,7 +166,6 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') graupel = get_tracer_index (MODEL_ATMOS, 'graupel') cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt') - w_diff = get_tracer_index (MODEL_ATMOS, 'w_diff') ccn_cm3 = get_tracer_index (MODEL_ATMOS, 'ccn_cm3') cin_cm3 = get_tracer_index (MODEL_ATMOS, 'cin_cm3') aerosol = get_tracer_index (MODEL_ATMOS, 'aerosol') @@ -188,7 +175,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & !$OMP graupel,q_con,sphum,cappa,r_vir,k1k,delp, & !$OMP delz,akap,pkz,te,u,v,ps, gridstruct, last_step, & !$OMP ak,bk,nq,isd,ied,jsd,jed,kord_tr,fill, adiabatic, & -!$OMP hs,w,ws,kord_wz,omga,rrg,kord_mt,pe4,w_limiter,cp,remap_te) & +!$OMP hs,w,ws,kord_wz,omga,rrg,kord_mt,pe4,cp,remap_te,thermostruct)& !$OMP private(gz,cvm,kp,k_next,bkh,dp2,dlnp,tpe, & !$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2,w2) @@ -220,24 +207,21 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & enddo enddo else - ! Transform "density pt" to "density temp" + ! Transform "density pt" to "density temp". (OK to have flag in outer loop) do k=1,km -#ifdef MOIST_CAPPA - call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) - do i=is,ie - q_con(i,j,k) = gz(i) - cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) - pt(i,j,k) = pt(i,j,k)*exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - enddo -#else - do i=is,ie - pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - ! Using dry pressure for the definition of the virtual potential temperature - ! pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)* & - ! pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)))) - enddo -#endif + if (thermostruct%moist_kappa) then + call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) + do i=is,ie + q_con(i,j,k) = gz(i) + cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) + pt(i,j,k) = pt(i,j,k)*exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + enddo + else + do i=is,ie + pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + enddo + endif !moist_kappa enddo endif ! hydro test @@ -245,7 +229,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & endif !kord_tm else !---------------------------------- - ! Compute cp*T + KE +phis + ! remap_te: Compute cp*T + KE +phis do i=is,ie phis(i,km+1) = hs(i,j) enddo @@ -274,29 +258,29 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & do i=is,ie phis(i,k) = phis(i,k+1) - grav*delz(i,j,k) enddo -#ifdef MOIST_CAPPA - call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) - do i=is,ie - q_con(i,j,k) = gz(i) - cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) - pkz(i,j,k) = exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - te(i,j,k) = cvm(i)*pt(i,j,k)*pkz(i,j,k)/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i))) + & - 0.5 * w(i,j,k)**2 + 0.25*gridstruct%rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & - v(i,j,k)**2+v(i+1,j,k)**2 - & - (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)) + & - 0.5*(phis(i,k+1)+phis(i,k)) - enddo -#else - do i=is,ie - pkz(i,j,k) = exp(k1k*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - te(i,j,k) = cv_air*pt(i,j,k)*pkz(i,j,k)/(1.+r_vir*q(i,j,k,sphum)) + & - 0.5 * w(i,j,k)**2 + 0.25*gridstruct%rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & - v(i,j,k)**2+v(i+1,j,k)**2 - & - (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)) + & - 0.5*(phis(i,k+1)+phis(i,k)) - enddo -#endif + if (thermostruct%moist_kappa) then + call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) + do i=is,ie + q_con(i,j,k) = gz(i) + cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) + pkz(i,j,k) = exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + te(i,j,k) = cvm(i)*pt(i,j,k)*pkz(i,j,k)/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i))) + & + 0.5 * w(i,j,k)**2 + 0.25*gridstruct%rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)) + & + 0.5*(phis(i,k+1)+phis(i,k)) + enddo + else + do i=is,ie + pkz(i,j,k) = exp(k1k*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + te(i,j,k) = cv_air*pt(i,j,k)*pkz(i,j,k)/(1.+r_vir*q(i,j,k,sphum)) + & + 0.5 * w(i,j,k)**2 + 0.25*gridstruct%rsin2(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)) + & + 0.5*(phis(i,k+1)+phis(i,k)) + enddo + endif enddo endif !end hydrostatic test @@ -436,60 +420,6 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & delz(i,j,k) = -delz(i,j,k)*dp2(i,k) enddo enddo - - !Fix excessive w - momentum conserving --- sjl - ! gz(:) used here as a temporary array - if ( w_limiter ) then - do k=1,km - do i=is,ie - w2(i,k) = w(i,j,k) - enddo - enddo - do k=1, km-1 - do i=is,ie - if ( w2(i,k) > w_max ) then - gz(i) = (w2(i,k)-w_max) * dp2(i,k) - w2(i,k ) = w_max - w2(i,k+1) = w2(i,k+1) + gz(i)/dp2(i,k+1) - !print*, ' W_LIMITER down: ', i,j,k, w2(i,k:k+1), w(i,j,k:k+1) - elseif ( w2(i,k) < w_min ) then - gz(i) = (w2(i,k)-w_min) * dp2(i,k) - w2(i,k ) = w_min - w2(i,k+1) = w2(i,k+1) + gz(i)/dp2(i,k+1) - !print*, ' W_LIMITER down: ', i,j,k, w2(i,k:k+1), w(i,j,k:k+1) - endif - enddo - enddo - do k=km, 2, -1 - do i=is,ie - if ( w2(i,k) > w_max ) then - gz(i) = (w2(i,k)-w_max) * dp2(i,k) - w2(i,k ) = w_max - w2(i,k-1) = w2(i,k-1) + gz(i)/dp2(i,k-1) - !print*, ' W_LIMITER up: ', i,j,k, w2(i,k-1:k), w(i,j,k-1:k) - elseif ( w2(i,k) < w_min ) then - gz(i) = (w2(i,k)-w_min) * dp2(i,k) - w2(i,k ) = w_min - w2(i,k-1) = w2(i,k-1) + gz(i)/dp2(i,k-1) - !print*, ' W_LIMITER up: ', i,j,k, w2(i,k-1:k), w(i,j,k-1:k) - endif - enddo - enddo - do i=is,ie - if (w2(i,1) > w_max*2. ) then - w2(i,1) = w_max*2 ! sink out of the top of the domain - !print*, ' W_LIMITER top limited: ', i,j,1, w2(i,1), w(i,j,1) - elseif (w2(i,1) < w_min*2. ) then - w2(i,1) = w_min*2. - !print*, ' W_LIMITER top limited: ', i,j,1, w2(i,1), w(i,j,1) - endif - enddo - do k=1,km - do i=is,ie - w(i,j,k) = w2(i,k) - enddo - enddo - endif endif ! 3.1) Update pressure variables @@ -524,43 +454,43 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & if ( hydrostatic ) then do k=1,km do i=is,ie - pkz(i,j,k) = (pk2(i,k+1)-pk2(i,k))/(akap*(peln(i,k+1,j)-peln(i,k,j))) + pkz(i,j,k) = (pk2(i,k+1)-pk2(i,k))/(akap*(peln(i,k+1,j)-peln(i,k,j))) !MOIST_CAPPA not supported enddo enddo else ! Note: pt at this stage is T_v or T_m , unless kord_tm > 0 do k=1,km -#ifdef MOIST_CAPPA - call moist_cv(is,ie+1,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, gz(is:ie+1), cvm(is:ie+1)) - if ( kord_tm < 0 ) then - do i=is,ie - q_con(i,j,k) = gz(i) - cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) - pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - enddo - else - do i=is,ie - q_con(i,j,k) = gz(i) - cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) - pkz(i,j,k) = exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - enddo - endif -#else - if ( kord_tm < 0 ) then - do i=is,ie - pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - ! Using dry pressure for the definition of the virtual potential temperature - ! pkz(i,j,k) = exp(akap*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)))) - enddo + if (thermostruct%moist_kappa) then + call moist_cv(is,ie+1,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, gz(is:ie+1), cvm(is:ie+1)) + if ( kord_tm < 0 ) then + do i=is,ie + q_con(i,j,k) = gz(i) + cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) + pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + enddo + else + do i=is,ie + q_con(i,j,k) = gz(i) + cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) + pkz(i,j,k) = exp(cappa(i,j,k)/(1.-cappa(i,j,k))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + enddo + endif else - do i=is,ie - pkz(i,j,k) = exp(k1k*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) - ! Using dry pressure for the definition of the virtual potential temperature - ! pkz(i,j,k) = exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)))) - enddo - endif -#endif + if ( kord_tm < 0 ) then + do i=is,ie + pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + ! Using dry pressure for the definition of the virtual potential temperature + ! pkz(i,j,k) = exp(akap*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)))) + enddo + else + do i=is,ie + pkz(i,j,k) = exp(k1k*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + ! Using dry pressure for the definition of the virtual potential temperature + ! pkz(i,j,k) = exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)))) + enddo + endif + endif !moist_kappa enddo endif if ( kord_tm > 0 ) then @@ -648,7 +578,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & phis(i,km+1) = hs(i,j) enddo ! calculate Tv from TE - if ( hydrostatic ) then + if ( hydrostatic ) then !MOIST_CAPPA not supported do k=km,1,-1 do i=is,ie tpe = te(i,j,k) - phis(i,k+1) - 0.25*gridstruct%rsin2(i,j)*( & @@ -662,27 +592,29 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & enddo ! end k-loop else do k=km,1,-1 -#ifdef MOIST_CAPPA - call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) - do i=is,ie - q_con(i,j,k) = gz(i) - cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) - enddo -#endif - do i=is,ie - phis(i,k) = phis(i,k+1) - delz(i,j,k)*grav - tpe = te(i,j,k) - 0.5*(phis(i,k)+phis(i,k+1)) - 0.5*w(i,j,k)**2 - 0.25*gridstruct%rsin2(i,j)*( & - u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & - (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j) ) -#ifdef MOIST_CAPPA - pt(i,j,k)= tpe / cvm(i)*(1.+r_vir*q(i,j,k,sphum))*(1.-gz(i)) - pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#else - pt(i,j,k)= tpe / cv_air *(1.+r_vir*q(i,j,k,sphum)) - pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#endif - enddo + if (thermostruct%moist_kappa) then + call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) + do i=is,ie + q_con(i,j,k) = gz(i) + cappa(i,j,k) = rdgas / ( rdgas + cvm(i)/(1.+r_vir*q(i,j,k,sphum)) ) + phis(i,k) = phis(i,k+1) - delz(i,j,k)*grav + tpe = te(i,j,k) - 0.5*(phis(i,k)+phis(i,k+1)) - 0.5*w(i,j,k)**2 - 0.25*gridstruct%rsin2(i,j)*( & + u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j) ) + pt(i,j,k)= tpe / cvm(i)*(1.+r_vir*q(i,j,k,sphum))*(1.-gz(i)) + pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + enddo + else + do i=is,ie + phis(i,k) = phis(i,k+1) - delz(i,j,k)*grav + tpe = te(i,j,k) - 0.5*(phis(i,k)+phis(i,k+1)) - 0.5*w(i,j,k)**2 - 0.25*gridstruct%rsin2(i,j)*( & + u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j) ) + pt(i,j,k)= tpe / cv_air *(1.+r_vir*q(i,j,k,sphum)) + pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) + enddo + endif enddo ! end k-loop endif @@ -717,7 +649,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & !$OMP parallel do default(none) shared(is,ie,js,je,km,ptop,u,v,pe,isd,ied,jsd,jed,te_2d,delp, & !$OMP hydrostatic,hs,rg,pt,peln,cp,delz,nwat,rainwat,liq_wat, & !$OMP ice_wat,snowwat,graupel,q_con,r_vir,sphum,w,pk,pkz,zsum1, & -!$OMP zsum0,te0_2d,gridstruct,q,kord_tm,te,remap_te) & +!$OMP zsum0,te0_2d,gridstruct,q,kord_tm,te,remap_te,thermostruct) & !$OMP private(cvm,gz,phis) do j=js,je if ( remap_te ) then @@ -761,25 +693,25 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & enddo do k=1,km -#ifdef USE_COND - call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) - do i=is,ie - ! KE using 3D winds: - q_con(i,j,k) = gz(i) - te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cvm(i)*pt(i,j,k)/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i))) + & - 0.5*(phis(i,k)+phis(i,k+1) + w(i,j,k)**2 + 0.5*gridstruct%rsin2(i,j)*( & - u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & - (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)))) - enddo -#else - do i=is,ie - te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cv_air*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)) + & - 0.5*(phis(i,k)+phis(i,k+1) + w(i,j,k)**2 + 0.5*gridstruct%rsin2(i,j)*( & - u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & - (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)))) - enddo -#endif + if (thermostruct%use_cond) then + call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) + do i=is,ie + ! KE using 3D winds: + q_con(i,j,k) = gz(i) + te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cvm(i)*pt(i,j,k)/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i))) + & + 0.5*(phis(i,k)+phis(i,k+1) + w(i,j,k)**2 + 0.5*gridstruct%rsin2(i,j)*( & + u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)))) + enddo + else + do i=is,ie + te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cv_air*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum)) + & + 0.5*(phis(i,k)+phis(i,k+1) + w(i,j,k)**2 + 0.5*gridstruct%rsin2(i,j)*( & + u(i,j,k)**2+u(i,j+1,k)**2 + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*gridstruct%cosa_s(i,j)))) + enddo + endif enddo ! k-loop endif ! end non-hydro endif ! end non remapping te @@ -847,9 +779,9 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & if (do_intermediate_phys) then call timing_on('INTERMEDIATE_PHYS') call intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, & - c2l_ord, mdt, consv, akap, ptop, pfull, hs, te0_2d, u, & + mdt, consv, akap, ptop, pfull, hs, te0_2d, u, & v, w, pt, delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, & - inline_mp, gridstruct, domain, bd, hydrostatic, do_adiabatic_init, & + inline_mp, gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, & do_inline_mp, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr) call timing_off('INTERMEDIATE_PHYS') endif @@ -860,34 +792,43 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & if ( last_step ) then ! 9a) Convert T_v/T_m to T if last_step -!!! if ( is_master() ) write(*,*) 'dtmp=', dtmp, nwat !$OMP parallel do default(none) shared(is,ie,js,je,km,isd,ied,jsd,jed,hydrostatic,pt,adiabatic,cp, & !$OMP nwat,rainwat,liq_wat,ice_wat,snowwat,graupel,r_vir,& -!$OMP sphum,pkz,dtmp,q) & +!$OMP sphum,pkz,dtmp,q,thermostruct) & !$OMP private(cvm,gz) do k=1,km do j=js,je if (hydrostatic) then !This is re-factored from AM4 so answers may be different do i=is,ie - pt(i,j,k) = (pt(i,j,k)+dtmp/cp*pkz(i,j,k)) / (1.+r_vir*q(i,j,k,sphum)) + pt(i,j,k) = (pt(i,j,k)+dtmp/cp*pkz(i,j,k)) / (1.+r_vir*q(i,j,k,sphum)) !use_cond not implemented enddo else -#ifdef USE_COND - call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) - do i=is,ie - pt(i,j,k) = (pt(i,j,k)+dtmp/cvm(i)*pkz(i,j,k))/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i))) - enddo -#else - if ( .not. adiabatic ) then + if (thermostruct%use_cond) then + call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, gz(is:ie), cvm(is:ie)) !gz is q_con do i=is,ie - pt(i,j,k) = (pt(i,j,k)+dtmp/cv_air*pkz(i,j,k)) / (1.+r_vir*q(i,j,k,sphum)) + pt(i,j,k) = (pt(i,j,k)+dtmp/cvm(i)*pkz(i,j,k))/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i))) enddo + else + if ( .not. adiabatic ) then + do i=is,ie + pt(i,j,k) = (pt(i,j,k)+dtmp/cv_air*pkz(i,j,k)) / (1.+r_vir*q(i,j,k,sphum)) + enddo + endif endif -#endif endif enddo ! j-loop enddo ! k-loop +!!$ if (hydrostatic) then +!!$ thermostruct%pt_is_virtual = .false. +!!$ else +!!$ if (thermostruct%use_cond) then +!!$ thermostruct%pt_is_virtual = .false. +!!$ thermostruct%pt_is_density = .false. +!!$ else +!!$ if (.not. adiabatic) thermostruct%pt_is_virtual = .false. +!!$ endif +!!$ endif else ! 9b) not last_step: convert T_v/T_m back to theta_v/theta_m for dyn_core !$OMP parallel do default(none) shared(is,ie,js,je,km,pkz,pt) @@ -898,148 +839,12 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & enddo enddo enddo + !thermostruct%pt_is_potential = .true. endif end subroutine Lagrangian_to_Eulerian - subroutine compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, & - u, v, w, delz, pt, delp, q, qc, q_con, pe, peln, hs, & - rsin2_l, cosa_s_l, & - r_vir, cp, rg, hlv, te_2d, ua, va, teq, & - moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te) -!------------------------------------------------------ -! Compute vertically integrated total energy per column -!------------------------------------------------------ -! !INPUT PARAMETERS: - integer, intent(in):: km, is, ie, js, je, isd, ied, jsd, jed, id_te - integer, intent(in):: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, nwat - real, intent(inout), dimension(isd:ied,jsd:jed,km):: ua, va - real, intent(in), dimension(isd:ied,jsd:jed,km):: pt, delp - real, intent(in), dimension(isd:ied,jsd:jed,km,*):: q - real, intent(in), dimension(isd:ied,jsd:jed,km):: qc, q_con - real, intent(inout):: u(isd:ied, jsd:jed+1,km) - real, intent(inout):: v(isd:ied+1,jsd:jed, km) - real, intent(in):: w(isd:,jsd:,1:) ! vertical velocity (m/s) - real, intent(in):: delz(is:,js:,1:) - real, intent(in):: hs(isd:ied,jsd:jed) ! surface geopotential - real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) ! pressure at layer edges - real, intent(in):: peln(is:ie,km+1,js:je) ! log(pe) - real, intent(in):: cp, rg, r_vir, hlv - real, intent(in) :: rsin2_l(isd:ied, jsd:jed) - real, intent(in) :: cosa_s_l(isd:ied, jsd:jed) - logical, intent(in):: moist_phys, hydrostatic -! Output: - real, intent(out):: te_2d(is:ie,js:je) ! vertically integrated TE - real, intent(out):: teq(is:ie,js:je) ! Moist TE -! Local - real, dimension(is:ie,km):: tv - real phiz(is:ie,km+1) - real cvm(is:ie), qd(is:ie) - integer i, j, k - -!---------------------- -! Output lat-lon winds: -!---------------------- -! call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, flagstruct%c2l_ord) - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,q_con,rg,peln,te_2d, & -!$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, & -!$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum) & -!$OMP private(phiz, tv, cvm, qd) - do j=js,je - - if ( hydrostatic ) then - - do i=is,ie - phiz(i,km+1) = hs(i,j) - enddo - do k=km,1,-1 - do i=is,ie -#ifdef USE_COND - tv(i,k) = pt(i,j,k)*(1.+qc(i,j,k))*(1-q_con(i,j,k)) -#else - tv(i,k) = pt(i,j,k)*(1.+qc(i,j,k)) -#endif - phiz(i,k) = phiz(i,k+1) + rg*tv(i,k)*(peln(i,k+1,j)-peln(i,k,j)) - enddo - enddo - - do i=is,ie - te_2d(i,j) = pe(i,km+1,j)*phiz(i,km+1) - pe(i,1,j)*phiz(i,1) - enddo - - do k=1,km - do i=is,ie - te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*tv(i,k) + & - 0.25*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & - v(i,j,k)**2+v(i+1,j,k)**2 - & - (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j))) - enddo - enddo - - else -!----------------- -! Non-hydrostatic: -!----------------- - do i=is,ie - phiz(i,km+1) = hs(i,j) - do k=km,1,-1 - phiz(i,k) = phiz(i,k+1) - grav*delz(i,j,k) - enddo - enddo - do i=is,ie - te_2d(i,j) = 0. - enddo - !TODO moist_phys doesn't seem to make a difference --- lmh 13may21 - if ( moist_phys ) then - do k=1,km -#ifdef MOIST_CAPPA - call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, qd, cvm) -#endif - do i=is,ie -#ifdef MOIST_CAPPA - te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cvm(i)*pt(i,j,k) + & -#else - te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + & -#endif - 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & - v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) - enddo - enddo - else - do k=1,km - do i=is,ie - te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + & - 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & - v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) - enddo - enddo - endif - endif - enddo - -!------------------------------------- -! Diganostics computation for moist TE -!------------------------------------- - if( id_te>0 ) then -!$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp) - do j=js,je - do i=is,ie - teq(i,j) = te_2d(i,j) - enddo - if ( moist_phys ) then - do k=1,km - do i=is,ie - teq(i,j) = teq(i,j) + hlv*q(i,j,k,sphum)*delp(i,j,k) - enddo - enddo - endif - enddo - endif - - end subroutine compute_total_energy subroutine pkez(km, ifirst, ilast, jfirst, jlast, j, & @@ -1099,2513 +904,4 @@ subroutine pkez(km, ifirst, ilast, jfirst, jlast, j, & end subroutine pkez - subroutine map_scalar( km, pe1, q1, qs, & - kn, pe2, q2, i1, i2, & - j, ibeg, iend, jbeg, jend, & - iv, kord, q_min) -! iv=1 - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == temp - ! 2 == remap temp with cs scheme - ! -2 or -3 == w with lower bc - integer, intent(in) :: kord ! Method order - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: ibeg, iend, jbeg, jend - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - real, intent(in) :: qs(i1:i2) ! bottom BC - real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input -! !INPUT/OUTPUT PARAMETERS: - real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output - real, intent(in):: q_min - -! !DESCRIPTION: -! IV = 0: constituents: enforce positivity in interface values and reconstruction -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! !LOCAL VARIABLES: - real dp1(i1:i2,km) - real q4(4,i1:i2,km) - real pl, pr, qsum, dp, esl - integer i, k, l, m, k0 - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - q4(1,i,k) = q1(i,j,k) - enddo - enddo - - ! Compute vertical subgrid distribution - if ( kord >7 ) then - call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min ) - else - call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) - endif - - do i=i1,i2 - k0 = 1 - do 555 k=1,kn - do l=k0,km -! locate the top edge: pe2(i,k) - if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then - pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) - if( pe2(i,k+1) <= pe1(i,l+1) ) then -! entire new grid is within the original grid - pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) - q2(i,j,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & - *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) - k0 = l - goto 555 - else -! Fractional area... - qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & - q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & - (r3*(1.+pl*(1.+pl)))) - do m=l+1,km -! locate the bottom edge: pe2(i,k+1) - if( pe2(i,k+1) > pe1(i,m+1) ) then -! Whole layer - qsum = qsum + dp1(i,m)*q4(1,i,m) - else - dp = pe2(i,k+1)-pe1(i,m) - esl = dp / dp1(i,m) - qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & - (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) - k0 = m - goto 123 - endif - enddo - goto 123 - endif - endif - enddo -123 q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) -555 continue - enddo - - end subroutine map_scalar - - - subroutine map1_ppm( km, pe1, q1, qs, & - kn, pe2, q2, i1, i2, & - j, ibeg, iend, jbeg, jend, & - iv, kord) - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? - ! 2 == remap temp with cs scheme - ! -1 == vertical velocity, with bottom BC - integer, intent(in) :: kord ! Method order - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: ibeg, iend, jbeg, jend - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - real, intent(in) :: qs(i1:i2) ! bottom BC (only used if iv == -2 ) - real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input -! !INPUT/OUTPUT PARAMETERS: - real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output - -! !DESCRIPTION: -! IV = 0: constituents -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! !LOCAL VARIABLES: - real dp1(i1:i2,km) - real q4(4,i1:i2,km) - real pl, pr, qsum, dp, esl - integer i, k, l, m, k0 - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - q4(1,i,k) = q1(i,j,k) - enddo - enddo - -! Compute vertical subgrid distribution - if ( kord >7 ) then - call cs_profile( qs, q4, dp1, km, i1, i2, iv, kord ) - else - call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) - endif - - do i=i1,i2 - k0 = 1 - do 555 k=1,kn - do l=k0,km -! locate the top edge: pe2(i,k) - if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then - pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) - if( pe2(i,k+1) <= pe1(i,l+1) ) then -! entire new grid is within the original grid - pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) - q2(i,j,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & - *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) - k0 = l - goto 555 - else -! Fractional area... - qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & - q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & - (r3*(1.+pl*(1.+pl)))) - do m=l+1,km -! locate the bottom edge: pe2(i,k+1) - if( pe2(i,k+1) > pe1(i,m+1) ) then -! Whole layer - qsum = qsum + dp1(i,m)*q4(1,i,m) - else - dp = pe2(i,k+1)-pe1(i,m) - esl = dp / dp1(i,m) - qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & - (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) - k0 = m - goto 123 - endif - enddo - goto 123 - endif - endif - enddo -123 q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) -555 continue - enddo - - end subroutine map1_ppm - - -!Multi-tracer remapping (much faster) -!ONLY supports cubic-spline remapping - subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, & - i1, i2, isd, ied, jsd, jed, & - q_min, fill) -! !INPUT PARAMETERS: - integer, intent(in):: km ! vertical dimension - integer, intent(in):: j, nq, i1, i2 - integer, intent(in):: isd, ied, jsd, jed - integer, intent(in):: kord(nq) - real, intent(in):: pe1(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real, intent(in):: pe2(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real, intent(in):: dp2(i1:i2,km) - real, intent(in):: q_min - logical, intent(in):: fill - real, intent(inout):: q1(isd:ied,jsd:jed,km,nq) ! Field input -! !LOCAL VARIABLES: - real:: q4(4,i1:i2,km,nq) - real:: q2(i1:i2,km,nq) ! Field output - real:: qsum(nq) - real:: dp1(i1:i2,km) - real:: qs(i1:i2) - real:: pl, pr, dp, esl, fac1, fac2 - integer:: i, k, l, m, k0, iq - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - enddo - enddo - - do iq=1,nq - do k=1,km - do i=i1,i2 - q4(1,i,k,iq) = q1(i,j,k,iq) - enddo - enddo - call scalar_profile( qs, q4(1,i1,1,iq), dp1, km, i1, i2, 0, kord(iq), q_min ) - enddo - -! Mapping - do 1000 i=i1,i2 - k0 = 1 - do 555 k=1,km - do 100 l=k0,km -! locate the top edge: pe2(i,k) - if(pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1)) then - pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) - if(pe2(i,k+1) <= pe1(i,l+1)) then -! entire new grid is within the original grid - pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) - fac1 = pr + pl - fac2 = r3*(pr*fac1 + pl*pl) - fac1 = 0.5*fac1 - do iq=1,nq - q2(i,k,iq) = q4(2,i,l,iq) + (q4(4,i,l,iq)+q4(3,i,l,iq)-q4(2,i,l,iq))*fac1 & - - q4(4,i,l,iq)*fac2 - enddo - k0 = l - goto 555 - else -! Fractional area... - dp = pe1(i,l+1) - pe2(i,k) - fac1 = 1. + pl - fac2 = r3*(1.+pl*fac1) - fac1 = 0.5*fac1 - do iq=1,nq - qsum(iq) = dp*(q4(2,i,l,iq) + (q4(4,i,l,iq)+ & - q4(3,i,l,iq) - q4(2,i,l,iq))*fac1 - q4(4,i,l,iq)*fac2) - enddo - do m=l+1,km -! locate the bottom edge: pe2(i,k+1) - if(pe2(i,k+1) > pe1(i,m+1) ) then - ! Whole layer.. - do iq=1,nq - qsum(iq) = qsum(iq) + dp1(i,m)*q4(1,i,m,iq) - enddo - else - dp = pe2(i,k+1)-pe1(i,m) - esl = dp / dp1(i,m) - fac1 = 0.5*esl - fac2 = 1.-r23*esl - do iq=1,nq - qsum(iq) = qsum(iq) + dp*( q4(2,i,m,iq) + fac1*( & - q4(3,i,m,iq)-q4(2,i,m,iq)+q4(4,i,m,iq)*fac2 ) ) - enddo - k0 = m - goto 123 - endif - enddo - goto 123 - endif - endif -100 continue -123 continue - do iq=1,nq - q2(i,k,iq) = qsum(iq) / dp2(i,k) - enddo -555 continue -1000 continue - - if (fill) call fillz(i2-i1+1, km, nq, q2, dp2) - - do iq=1,nq -! if (fill) call fillz(i2-i1+1, km, 1, q2(i1,1,iq), dp2) - do k=1,km - do i=i1,i2 - q1(i,j,k,iq) = q2(i,k,iq) - enddo - enddo - enddo - - end subroutine mapn_tracer - - - !This routine remaps a single tracer - subroutine map1_q2(km, pe1, q1, & - kn, pe2, q2, dp2, & - i1, i2, iv, kord, j, & - ibeg, iend, jbeg, jend, & - q_min ) - - -! !INPUT PARAMETERS: - integer, intent(in) :: j - integer, intent(in) :: i1, i2 - integer, intent(in) :: ibeg, iend, jbeg, jend - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? - integer, intent(in) :: kord - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - - real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input - real, intent(in) :: dp2(i1:i2,kn) - real, intent(in) :: q_min -! !INPUT/OUTPUT PARAMETERS: - real, intent(inout):: q2(i1:i2,kn) ! Field output -! !LOCAL VARIABLES: - real qs(i1:i2) - real dp1(i1:i2,km) - real q4(4,i1:i2,km) - real pl, pr, qsum, dp, esl - - integer i, k, l, m, k0 - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - q4(1,i,k) = q1(i,j,k) - enddo - enddo - -! Compute vertical subgrid distribution - if ( kord >7 ) then - call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min ) - else - call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) - endif - -! Mapping - do 1000 i=i1,i2 - k0 = 1 - do 555 k=1,kn - do 100 l=k0,km -! locate the top edge: pe2(i,k) - if(pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1)) then - pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) - if(pe2(i,k+1) <= pe1(i,l+1)) then -! entire new grid is within the original grid - pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) - q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & - *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) - k0 = l - goto 555 - else -! Fractional area... - qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & - q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & - (r3*(1.+pl*(1.+pl)))) - do m=l+1,km -! locate the bottom edge: pe2(i,k+1) - if(pe2(i,k+1) > pe1(i,m+1) ) then - ! Whole layer.. - qsum = qsum + dp1(i,m)*q4(1,i,m) - else - dp = pe2(i,k+1)-pe1(i,m) - esl = dp / dp1(i,m) - qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & - (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) - k0 = m - goto 123 - endif - enddo - goto 123 - endif - endif -100 continue -123 q2(i,k) = qsum / dp2(i,k) -555 continue -1000 continue - - end subroutine map1_q2 - - - !Currently this routine is only called with kord = 4, - ! --- lmh 9 june 21 - subroutine remap_2d(km, pe1, q1, & - kn, pe2, q2, & - i1, i2, & - iv, kord) - integer, intent(in):: i1, i2 - integer, intent(in):: iv ! Mode: 0 == constituents 1 ==others - integer, intent(in):: kord - integer, intent(in):: km ! Original vertical dimension - integer, intent(in):: kn ! Target vertical dimension - real, intent(in):: pe1(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real, intent(in):: pe2(i1:i2,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real, intent(in) :: q1(i1:i2,km) ! Field input - real, intent(out):: q2(i1:i2,kn) ! Field output -! !LOCAL VARIABLES: - real qs(i1:i2) - real dp1(i1:i2,km) - real q4(4,i1:i2,km) - real pl, pr, qsum, dp, esl - integer i, k, l, m, k0 - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - q4(1,i,k) = q1(i,k) - enddo - enddo - -! Compute vertical subgrid distribution - if ( kord >7 ) then - call cs_profile( qs, q4, dp1, km, i1, i2, iv, kord ) - else - call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) - endif - - do i=i1,i2 - k0 = 1 - do 555 k=1,kn -#ifdef OLD_TOP_EDGE - if( pe2(i,k+1) <= pe1(i,1) ) then -! Entire grid above old ptop - q2(i,k) = q4(2,i,1) - elseif( pe2(i,k) < pe1(i,1) .and. pe2(i,k+1)>pe1(i,1) ) then -! Partially above old ptop: - q2(i,k) = q1(i,1) -#else - if( pe2(i,k) <= pe1(i,1) ) then -! above old ptop: - q2(i,k) = q1(i,1) -#endif - else - do l=k0,km -! locate the top edge: pe2(i,k) - if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then - pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) - if(pe2(i,k+1) <= pe1(i,l+1)) then -! entire new grid is within the original grid - pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) - q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & - *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) - k0 = l - goto 555 - else -! Fractional area... - qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & - q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & - (r3*(1.+pl*(1.+pl)))) - do m=l+1,km -! locate the bottom edge: pe2(i,k+1) - if(pe2(i,k+1) > pe1(i,m+1) ) then - ! Whole layer.. - qsum = qsum + dp1(i,m)*q4(1,i,m) - else - dp = pe2(i,k+1)-pe1(i,m) - esl = dp / dp1(i,m) - qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & - (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) - k0 = m - goto 123 - endif - enddo - goto 123 - endif - endif - enddo -123 q2(i,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) - endif -555 continue - enddo - - end subroutine remap_2d - - !scalar_profile and cs_profile differ ONLY in that scalar_profile - ! accepts a qmin argument. (Unfortunately I was not able to make - ! qmin an optional argument in scalar_profile.) --- lmh summer 2020 - subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin) -! Optimized vertical profile reconstruction: -! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL - integer, intent(in):: i1, i2 - integer, intent(in):: km ! vertical dimension - integer, intent(in):: iv ! iv =-1: winds - ! iv = 0: positive definite scalars - ! iv = 1: others - integer, intent(in):: kord - real, intent(in) :: qs(i1:i2) - real, intent(in) :: delp(i1:i2,km) ! layer pressure thickness - real, intent(inout):: a4(4,i1:i2,km) ! Interpolated values - real, intent(in):: qmin -!----------------------------------------------------------------------- - logical, dimension(i1:i2,km):: extm, ext5, ext6 - real gam(i1:i2,km) - real q(i1:i2,km+1) - real d4(i1:i2) - real bet, a_bot, grat - real pmp_1, lac_1, pmp_2, lac_2, x0, x1 - integer i, k, im - - !Compute interface values (\hat{q}) - ! iv=-2 and -3 introduce the lower BC - ! iv=-2 also uses a simpler calculation - ! dropping a lot of metric terms - if ( iv .eq. -2 ) then - do i=i1,i2 - gam(i,2) = 0.5 - q(i,1) = 1.5*a4(1,i,1) - enddo - do k=2,km-1 - do i=i1, i2 - grat = delp(i,k-1) / delp(i,k) - bet = 2. + grat + grat - gam(i,k) - q(i,k) = (3.*(a4(1,i,k-1)+a4(1,i,k)) - q(i,k-1))/bet - gam(i,k+1) = grat / bet - enddo - enddo - do i=i1,i2 - grat = delp(i,km-1) / delp(i,km) - q(i,km) = (3.*(a4(1,i,km-1)+a4(1,i,km)) - grat*qs(i) - q(i,km-1)) / & - (2. + grat + grat - gam(i,km)) - q(i,km+1) = qs(i) - enddo - do k=km-1,1,-1 - do i=i1,i2 - q(i,k) = q(i,k) - gam(i,k+1)*q(i,k+1) - enddo - enddo - else - do i=i1,i2 - grat = delp(i,2) / delp(i,1) ! grid ratio - bet = grat*(grat+0.5) - q(i,1) = ( (grat+grat)*(grat+1.)*a4(1,i,1) + a4(1,i,2) ) / bet - gam(i,1) = ( 1. + grat*(grat+1.5) ) / bet - enddo - - do k=2,km - do i=i1,i2 - d4(i) = delp(i,k-1) / delp(i,k) - bet = 2. + d4(i) + d4(i) - gam(i,k-1) - q(i,k) = ( 3.*(a4(1,i,k-1)+d4(i)*a4(1,i,k)) - q(i,k-1) )/bet - gam(i,k) = d4(i) / bet - enddo - enddo - - do i=i1,i2 - a_bot = 1. + d4(i)*(d4(i)+1.5) - q(i,km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1,i,km)+a4(1,i,km-1)-a_bot*q(i,km)) & - / ( d4(i)*(d4(i)+0.5) - a_bot*gam(i,km) ) - enddo - - do k=km,1,-1 - do i=i1,i2 - q(i,k) = q(i,k) - gam(i,k)*q(i,k+1) - enddo - enddo - endif - -!Perfectly linear scheme - if ( abs(kord) == 17 ) then - do k=1,km - do i=i1,i2 - a4(2,i,k) = q(i,k ) - a4(3,i,k) = q(i,k+1) - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - enddo - return - endif - - im = i2 - i1 + 1 - - ! Apply *large-scale* constraints to \hat{q} - - !Upper BC for all schemes - do i=i1,i2 - q(i,2) = min( q(i,2), max(a4(1,i,1), a4(1,i,2)) ) - q(i,2) = max( q(i,2), min(a4(1,i,1), a4(1,i,2)) ) - enddo - - do k=2,km - do i=i1,i2 - gam(i,k) = a4(1,i,k) - a4(1,i,k-1) !\delta \bar{q} - enddo - enddo - -! Interior: - do k=3,km-1 - do i=i1,i2 - if ( abs(kord) >= 14 .or. gam(i,k-1)*gam(i,k+1)>0. ) then -! Apply large-scale constraint to ALL fields if not local max/min -! first guess interface values cannot exceeed values -! of adjacent cells - q(i,k) = min( q(i,k), max(a4(1,i,k-1),a4(1,i,k)) ) - q(i,k) = max( q(i,k), min(a4(1,i,k-1),a4(1,i,k)) ) - else - if ( gam(i,k-1) > 0. ) then -! There exists a local max - q(i,k) = max(q(i,k), min(a4(1,i,k-1),a4(1,i,k))) - else -! There exists a local min - q(i,k) = min(q(i,k), max(a4(1,i,k-1),a4(1,i,k))) - if ( iv==0 ) q(i,k) = max(0., q(i,k)) - endif - endif - enddo - enddo - -! Bottom BC for all schemes: - do i=i1,i2 - q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) ) - q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) ) - enddo - - !Set up in-cell reconstruction - !initially continuous (AL(k) = AR(k-1)) - do k=1,km - do i=i1,i2 - a4(2,i,k) = q(i,k ) - a4(3,i,k) = q(i,k+1) - enddo - enddo - - !Flags for different extremum/2dz conditions - ! estimated from first-guess edge values - do k=1,km - if ( k==1 .or. k==km ) then - do i=i1,i2 - extm(i,k) = (a4(2,i,k)-a4(1,i,k)) * (a4(3,i,k)-a4(1,i,k)) > 0. - enddo - else - do i=i1,i2 - extm(i,k) = gam(i,k)*gam(i,k+1) < 0. - enddo - endif - if ( abs(kord) > 9 ) then - do i=i1,i2 - x0 = 2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)) - x1 = abs(a4(2,i,k)-a4(3,i,k)) - a4(4,i,k) = 3.*x0 - ext5(i,k) = abs(x0) > x1 - ext6(i,k) = abs(a4(4,i,k)) > x1 - enddo - endif - enddo - -! Apply subgrid constraints: -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -! Top 2 and bottom 2 layers always use monotonic mapping - - select case (iv) - - case (0) - do i=i1,i2 - a4(2,i,1) = max(0., a4(2,i,1)) - enddo - case (-1) - do i=i1,i2 - if ( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - case (2) - do i=i1,i2 - a4(2,i,1) = a4(1,i,1) - a4(3,i,1) = a4(1,i,1) - a4(4,i,1) = 0. - enddo - end select !iv - - if ( iv/=2 ) then - do i=i1,i2 - a4(4,i,1) = 3.*(2.*a4(1,i,1) - (a4(2,i,1)+a4(3,i,1))) - enddo - call cs_limiters(im, extm(i1,1), a4(1,i1,1), 1) - endif - -! k=2 - do i=i1,i2 - a4(4,i,2) = 3.*(2.*a4(1,i,2) - (a4(2,i,2)+a4(3,i,2))) - enddo - call cs_limiters(im, extm(i1,2), a4(1,i1,2), 2) - -!------------------------------------- -! Huynh's 2nd constraint for interior: -!------------------------------------- - do k=3,km-2 - select case (abs(kord)) - - case (0:8) - do i=i1,i2 -! Left edges - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) -! Right edges - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - - case (9) - do i=i1,i2 - if ( extm(i,k) .and. extm(i,k-1) ) then -! grid-scale 2-delta-z wave detected - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else if ( extm(i,k) .and. extm(i,k+1) ) then -! grid-scale 2-delta-z wave detected - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else if ( extm(i,k) .and. a4(1,i,k) abs(a4(2,i,k)-a4(3,i,k)) ) then - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - endif - endif - enddo - case(10) !restored AM4 case 10 - do i=i1,i2 - if( extm(i,k) ) then - if( a4(1,i,k) ehance vertical mixing - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else -! True local extremum - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) - endif - else ! not a local extremum - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) -! Check within the smooth region if subgrid profile is non-monotonic - if( abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k)) ) then - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) - endif - endif - enddo - case(11) - do i=i1,i2 - if ( ext5(i,k) .and. (ext5(i,k-1).or.ext5(i,k+1).or.a4(1,i,k)= 14 .or. gam(i,k-1)*gam(i,k+1)>0. ) then -! Apply large-scale constraint to ALL fields if not local max/min -! OR for the strictly monotone schemes - q(i,k) = min( q(i,k), max(a4(1,i,k-1),a4(1,i,k)) ) - q(i,k) = max( q(i,k), min(a4(1,i,k-1),a4(1,i,k)) ) - else - if ( gam(i,k-1) > 0. ) then -! There exists a local max - q(i,k) = max(q(i,k), min(a4(1,i,k-1),a4(1,i,k))) - else -! There exists a local min - q(i,k) = min(q(i,k), max(a4(1,i,k-1),a4(1,i,k))) - if ( iv==0 ) q(i,k) = max(0., q(i,k)) ! positive-definite - endif - endif - enddo - enddo - -! Bottom: - do i=i1,i2 - q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) ) - q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) ) - enddo - - do k=1,km - do i=i1,i2 - a4(2,i,k) = q(i,k ) - a4(3,i,k) = q(i,k+1) - enddo - enddo - - do k=1,km - if ( k==1 .or. k==km ) then - do i=i1,i2 - extm(i,k) = (a4(2,i,k)-a4(1,i,k)) * (a4(3,i,k)-a4(1,i,k)) > 0. - enddo - else - do i=i1,i2 - extm(i,k) = gam(i,k)*gam(i,k+1) < 0. - enddo - endif - if ( abs(kord) > 9 ) then - do i=i1,i2 - x0 = 2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)) - x1 = abs(a4(2,i,k)-a4(3,i,k)) - a4(4,i,k) = 3.*x0 - ext5(i,k) = abs(x0) > x1 - ext6(i,k) = abs(a4(4,i,k)) > x1 - enddo - endif - enddo - -!--------------------------- -! Apply subgrid constraints: -!--------------------------- -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -! Top 2 and bottom 2 layers always use monotonic mapping - - select case (iv) - case (0) - do i=i1,i2 - a4(2,i,1) = max(0., a4(2,i,1)) - enddo - case(-1) - do i=i1,i2 - if ( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - case(2) - do i=i1,i2 - a4(2,i,1) = a4(1,i,1) - a4(3,i,1) = a4(1,i,1) - a4(4,i,1) = 0. - enddo - end select !iv - - if ( iv/=2 ) then - do i=i1,i2 - a4(4,i,1) = 3.*(2.*a4(1,i,1) - (a4(2,i,1)+a4(3,i,1))) - enddo - call cs_limiters(im, extm(i1,1), a4(1,i1,1), 1) - endif - -! k=2 - do i=i1,i2 - a4(4,i,2) = 3.*(2.*a4(1,i,2) - (a4(2,i,2)+a4(3,i,2))) - enddo - call cs_limiters(im, extm(i1,2), a4(1,i1,2), 2) - -!------------------------------------- -! Huynh's 2nd constraint for interior: -!------------------------------------- - do k=3,km-2 - select case (abs(kord)) - case (0:8) - do i=i1,i2 -! Left edges - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) -! Right edges - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - - case (9) - do i=i1,i2 - if ( extm(i,k) .and. extm(i,k-1) ) then ! c90_mp122 -! grid-scale 2-delta-z wave detected - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else if ( extm(i,k) .and. extm(i,k+1) ) then ! c90_mp122 -! grid-scale 2-delta-z wave detected - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) -! Check within the smooth region if subgrid profile is non-monotonic - if( abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k)) ) then - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) - endif - endif - enddo - case(10) !restored AM4 case 10 - do i=i1,i2 - if( extm(i,k) ) then - if( extm(i,k-1) .or. extm(i,k+1) ) then -! grid-scale 2-delta-z wave detected - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else -! True local extremum - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) - endif - else ! not a local extremum - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) -! Check within the smooth region if subgrid profile is non-monotonic - if( abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k)) ) then - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) - endif - endif - enddo - case (11) - do i=i1,i2 - if ( ext5(i,k) .and. (ext5(i,k-1) .or. ext5(i,k+1)) ) then -! Noisy region: - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - a4(4,i,k) = 0. - else - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - endif - enddo - case (12) !post-AM4 case 10 - do i=i1,i2 - if( ext5(i,k) ) then - if( ext5(i,k-1) .or. ext5(i,k+1) ) then - a4(2,i,k) = a4(1,i,k) - a4(3,i,k) = a4(1,i,k) - elseif ( ext6(i,k-1) .or. ext6(i,k+1) ) then - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - endif - elseif( ext6(i,k) ) then - if( ext5(i,k-1) .or. ext5(i,k+1) ) then - pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) - lac_1 = pmp_1 + 1.5*gam(i,k+2) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & - max(a4(1,i,k), pmp_1, lac_1) ) - pmp_2 = a4(1,i,k) + 2.*gam(i,k) - lac_2 = pmp_2 - 1.5*gam(i,k-1) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & - max(a4(1,i,k), pmp_2, lac_2) ) - endif - endif - enddo - do i=i1,i2 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - case (13) !former 14: no subgrid limiter - - do i=i1,i2 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - - case (14) !strict monotonicity constraint - call cs_limiters(im, extm(i1,k), a4(1,i1,k), 2) - case (15) - call cs_limiters(im, extm(i1,k), a4(1,i1,k), 1) - case default - call mpp_error(FATAL, 'kord not implemented') - end select - -! Additional constraint to ensure positivity - if ( iv==0 .and. abs(kord) <= 13 ) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 0) - - enddo ! k-loop - -!---------------------------------- -! Bottom layer subgrid constraints: -!---------------------------------- - select case (iv) - case (0) - do i=i1,i2 - a4(3,i,km) = max(0., a4(3,i,km)) - enddo - case (-1) - do i=i1,i2 - if ( a4(3,i,km)*a4(1,i,km) <= 0. ) a4(3,i,km) = 0. - enddo - end select - - do k=km-1,km - do i=i1,i2 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - if(k==(km-1)) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 2) - if(k== km ) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 1) - enddo - - end subroutine cs_profile - - - subroutine cs_limiters(im, extm, a4, iv) - integer, intent(in) :: im - integer, intent(in) :: iv - logical, intent(in) :: extm(im) - real , intent(inout) :: a4(4,im) ! PPM array -! !LOCAL VARIABLES: - real da1, da2, a6da - integer i - - if ( iv==0 ) then -! Positive definite constraint - do i=1,im - if( a4(1,i)<=0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then - if( (a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12) < 0. ) then -! local minimum is negative - if( a4(1,i) a4(2,i) ) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - endif - endif - enddo - elseif ( iv==1 ) then - do i=1,im - if( (a4(1,i)-a4(2,i))*(a4(1,i)-a4(3,i))>=0. ) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da < -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da > da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - enddo - else -! Standard PPM constraint - do i=1,im - if( extm(i) ) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da < -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da > da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - enddo - endif - end subroutine cs_limiters - - - - subroutine ppm_profile(a4, delp, km, i1, i2, iv, kord) - -! !INPUT PARAMETERS: - integer, intent(in):: iv ! iv =-1: winds - ! iv = 0: positive definite scalars - ! iv = 1: others - ! iv = 2: temp (if remap_t) and w (iv=-2) - integer, intent(in):: i1 ! Starting longitude - integer, intent(in):: i2 ! Finishing longitude - integer, intent(in):: km ! vertical dimension - integer, intent(in):: kord ! Order (or more accurately method no.): - ! - real , intent(in):: delp(i1:i2,km) ! layer pressure thickness - -! !INPUT/OUTPUT PARAMETERS: - real , intent(inout):: a4(4,i1:i2,km) ! Interpolated values - -! DESCRIPTION: -! -! Perform the piecewise parabolic reconstruction -! -! !REVISION HISTORY: -! S.-J. Lin revised at GFDL 2007 -!----------------------------------------------------------------------- -! local arrays: - real dc(i1:i2,km) - real h2(i1:i2,km) - real delq(i1:i2,km) - real df2(i1:i2,km) - real d4(i1:i2,km) - -! local scalars: - integer i, k, km1, lmt, it - real fac - real a1, a2, c1, c2, c3, d1, d2 - real qm, dq, lac, qmp, pmp - - km1 = km - 1 - it = i2 - i1 + 1 - - do k=2,km - do i=i1,i2 - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) - d4(i,k ) = delp(i,k-1) + delp(i,k) - enddo - enddo - - do k=2,km1 - do i=i1,i2 - c1 = (delp(i,k-1)+0.5*delp(i,k))/d4(i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/d4(i,k) - df2(i,k) = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (d4(i,k)+delp(i,k+1)) - dc(i,k) = sign( min(abs(df2(i,k)), & - max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))-a4(1,i,k), & - a4(1,i,k)-min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))), df2(i,k) ) - enddo - enddo - -!----------------------------------------------------------- -! 4th order interpolation of the provisional cell edge value -!----------------------------------------------------------- - - do k=3,km1 - do i=i1,i2 - c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k) - a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1)) - a2 = d4(i,k+1) / (d4(i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(d4(i,k-1)+d4(i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) - enddo - enddo - -! if(km>8 .and. kord>4) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4) - -! Area preserving cubic with 2nd deriv. = 0 at the boundaries -! Top - do i=i1,i2 - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) -! Top edge: -!------------------------------------------------------- - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) -!------------------------------------------------------- -! a4(2,i,1) = (12./7.)*a4(1,i,1)-(13./14.)*a4(1,i,2)+(3./14.)*a4(1,i,3) -!------------------------------------------------------- -! No over- and undershoot condition - a4(2,i,2) = max( a4(2,i,2), min(a4(1,i,1), a4(1,i,2)) ) - a4(2,i,2) = min( a4(2,i,2), max(a4(1,i,1), a4(1,i,2)) ) - dc(i,1) = 0.5*(a4(2,i,2) - a4(1,i,1)) - enddo - -! Enforce monotonicity within the top layer - - if( iv==0 ) then - do i=i1,i2 - a4(2,i,1) = max(0., a4(2,i,1)) - a4(2,i,2) = max(0., a4(2,i,2)) - enddo - elseif( iv==-1 ) then - do i=i1,i2 - if ( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - elseif( abs(iv)==2 ) then - do i=i1,i2 - a4(2,i,1) = a4(1,i,1) - a4(3,i,1) = a4(1,i,1) - enddo - endif - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do i=i1,i2 - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) -! Bottom edge: -!----------------------------------------------------- - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) -! dc(i,km) = 0.5*(a4(3,i,km) - a4(1,i,km)) -!----------------------------------------------------- -! a4(3,i,km) = (12./7.)*a4(1,i,km)-(13./14.)*a4(1,i,km-1)+(3./14.)*a4(1,i,km-2) -! No over- and under-shoot condition - a4(2,i,km) = max( a4(2,i,km), min(a4(1,i,km), a4(1,i,km1)) ) - a4(2,i,km) = min( a4(2,i,km), max(a4(1,i,km), a4(1,i,km1)) ) - dc(i,km) = 0.5*(a4(1,i,km) - a4(2,i,km)) - enddo - - -! Enforce constraint on the "slope" at the surface - -#ifdef BOT_MONO - do i=i1,i2 - a4(4,i,km) = 0 - if( a4(3,i,km) * a4(1,i,km) <= 0. ) a4(3,i,km) = 0. - d1 = a4(1,i,km) - a4(2,i,km) - d2 = a4(3,i,km) - a4(1,i,km) - if ( d1*d2 < 0. ) then - a4(2,i,km) = a4(1,i,km) - a4(3,i,km) = a4(1,i,km) - else - dq = sign(min(abs(d1),abs(d2),0.5*abs(delq(i,km-1))), d1) - a4(2,i,km) = a4(1,i,km) - dq - a4(3,i,km) = a4(1,i,km) + dq - endif - enddo -#else - if( iv==0 ) then - do i=i1,i2 - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - elseif( iv<0 ) then - do i=i1,i2 - if( a4(1,i,km)*a4(3,i,km) <= 0. ) a4(3,i,km) = 0. - enddo - endif -#endif - - do k=1,km1 - do i=i1,i2 - a4(3,i,k) = a4(2,i,k+1) - enddo - enddo - -!----------------------------------------------------------- -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -!----------------------------------------------------------- -! Top 2 and bottom 2 layers always use monotonic mapping - do k=1,2 - do i=i1,i2 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 0) - enddo - - if(kord >= 7) then -!----------------------- -! Huynh's 2nd constraint -!----------------------- - do k=2,km1 - do i=i1,i2 -! Method#1 -! h2(i,k) = delq(i,k) - delq(i,k-1) -! Method#2 - better - h2(i,k) = 2.*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1)) & - / ( delp(i,k)+0.5*(delp(i,k-1)+delp(i,k+1)) ) & - * delp(i,k)**2 -! Method#3 -!!! h2(i,k) = dc(i,k+1) - dc(i,k-1) - enddo - enddo - - fac = 1.5 ! original quasi-monotone - - do k=3,km-2 - do i=i1,i2 -! Right edges -! qmp = a4(1,i,k) + 2.0*delq(i,k-1) -! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1) -! - pmp = 2.*dc(i,k) - qmp = a4(1,i,k) + pmp - lac = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k) - a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), qmp, lac)), & - max(a4(1,i,k), qmp, lac) ) -! Left edges -! qmp = a4(1,i,k) - 2.0*delq(i,k) -! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k) -! - qmp = a4(1,i,k) - pmp - lac = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k) - a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), qmp, lac)), & - max(a4(1,i,k), qmp, lac)) -!------------- -! Recompute A6 -!------------- - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo -! Additional constraint to ensure positivity when kord=7 - if (iv == 0 .and. kord >= 6 ) & - call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 2) - enddo - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv == 0) lmt = min(2, lmt) - - do k=3,km-2 - if( kord /= 4) then - do i=i1,i2 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - endif - if(kord/=6) call ppm_limiters(dc(i1,k), a4(1,i1,k), it, lmt) - enddo - endif - - do k=km1,km - do i=i1,i2 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 0) - enddo - - end subroutine ppm_profile - - - subroutine ppm_limiters(dm, a4, itot, lmt) - -! !INPUT PARAMETERS: - real , intent(in):: dm(*) ! the linear slope - integer, intent(in) :: itot ! Total Longitudes - integer, intent(in) :: lmt ! 0: Standard PPM constraint - ! 1: Improved full monotonicity constraint (Lin) - ! 2: Positive definite constraint - ! 3: do nothing (return immediately) -! !INPUT/OUTPUT PARAMETERS: - real , intent(inout) :: a4(4,*) ! PPM array - ! AA <-- a4(1,i) - ! AL <-- a4(2,i) - ! AR <-- a4(3,i) - ! A6 <-- a4(4,i) -! !LOCAL VARIABLES: - real qmp - real da1, da2, a6da - real fmin - integer i - -! Developer: S.-J. Lin - - if ( lmt == 3 ) return - - if(lmt == 0) then -! Standard PPM constraint - do i=1,itot - if(dm(i) == 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da < -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da > da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - enddo - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin 2004) -! Note: no need to provide first guess of A6 <-- a4(4,i) - do i=1, itot - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - - elseif (lmt == 2) then - -! Positive definite constraint - do i=1,itot - if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if( fmin < 0. ) then - if(a4(1,i) a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - endif - enddo - - endif - - end subroutine ppm_limiters - - - - subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4) - integer, intent(in) :: km, i1, i2 - real , intent(in) :: dp(i1:i2,km) ! grid size - real , intent(in) :: dq(i1:i2,km) ! backward diff of q - real , intent(in) :: d4(i1:i2,km) ! backward sum: dp(k)+ dp(k-1) - real , intent(in) :: df2(i1:i2,km) ! first guess mismatch - real , intent(in) :: dm(i1:i2,km) ! monotonic mismatch -! !INPUT/OUTPUT PARAMETERS: - real , intent(inout) :: a4(4,i1:i2,km) ! first guess/steepened -! !LOCAL VARIABLES: - integer i, k - real alfa(i1:i2,km) - real f(i1:i2,km) - real rat(i1:i2,km) - real dg2 - -! Compute ratio of dq/dp - do k=2,km - do i=i1,i2 - rat(i,k) = dq(i,k-1) / d4(i,k) - enddo - enddo - -! Compute F - do k=2,km-1 - do i=i1,i2 - f(i,k) = (rat(i,k+1) - rat(i,k)) & - / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) ) - enddo - enddo - - do k=3,km-2 - do i=i1,i2 - if(f(i,k+1)*f(i,k-1)<0. .and. df2(i,k)/=0.) then - dg2 = (f(i,k+1)-f(i,k-1))*((dp(i,k+1)-dp(i,k-1))**2 & - + d4(i,k)*d4(i,k+1) ) - alfa(i,k) = max(0., min(0.5, -0.1875*dg2/df2(i,k))) - else - alfa(i,k) = 0. - endif - enddo - enddo - - do k=4,km-2 - do i=i1,i2 - a4(2,i,k) = (1.-alfa(i,k-1)-alfa(i,k)) * a4(2,i,k) + & - alfa(i,k-1)*(a4(1,i,k)-dm(i,k)) + & - alfa(i,k)*(a4(1,i,k-1)+dm(i,k-1)) - enddo - enddo - - end subroutine steepz - - -!This routine should be moved to fv_io.F90. - subroutine rst_remap(km, kn, is,ie,js,je, isd,ied,jsd,jed, nq, ntp, & - delp_r, u0_r, v0_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, & - delp, u0, v0, u, v, w, delz, pt, q, qdiag, & - ak_r, bk_r, ptop, ak, bk, hydrostatic, make_nh, & - domain, square_domain, is_ideal_case) -!------------------------------------ -! Assuming hybrid sigma-P coordinate: -!------------------------------------ -! !INPUT PARAMETERS: - integer, intent(in):: km ! Restart z-dimension - integer, intent(in):: kn ! Run time dimension - integer, intent(in):: nq, ntp ! number of tracers (including h2o) - integer, intent(in):: is,ie,isd,ied ! starting & ending X-Dir index - integer, intent(in):: js,je,jsd,jed ! starting & ending Y-Dir index - logical, intent(in):: hydrostatic, make_nh, square_domain, is_ideal_case - real, intent(IN) :: ptop - real, intent(in) :: ak_r(km+1) - real, intent(in) :: bk_r(km+1) - real, intent(in) :: ak(kn+1) - real, intent(in) :: bk(kn+1) - real, intent(in):: delp_r(is:ie,js:je,km) ! pressure thickness - real, intent(in):: u0_r(is:ie, js:je+1,km) ! initial (t=0) u-wind (m/s) - real, intent(in):: v0_r(is:ie+1,js:je ,km) ! initial (t=0) v-wind (m/s) - real, intent(in):: u_r(is:ie, js:je+1,km) ! u-wind (m/s) - real, intent(in):: v_r(is:ie+1,js:je ,km) ! v-wind (m/s) - real, intent(inout):: pt_r(is:ie,js:je,km) - real, intent(in):: w_r(is:ie,js:je,km) - real, intent(in):: q_r(is:ie,js:je,km,1:ntp) - real, intent(in):: qdiag_r(is:ie,js:je,km,ntp+1:nq) - real, intent(inout)::delz_r(is:ie,js:je,km) - type(domain2d), intent(INOUT) :: domain -! Output: - real, intent(out):: delp(isd:ied,jsd:jed,kn) ! pressure thickness - real, intent(out):: u0(isd:,jsd:,1:) ! initial (t=0) u-wind (m/s) - real, intent(out):: v0(isd:,jsd:,1:) ! initial (t=0) v-wind (m/s) - real, intent(out):: u(isd:ied ,jsd:jed+1,kn) ! u-wind (m/s) - real, intent(out):: v(isd:ied+1,jsd:jed ,kn) ! v-wind (m/s) - real, intent(out):: w(isd: ,jsd: ,1:) ! vertical velocity (m/s) - real, intent(out):: pt(isd:ied ,jsd:jed ,kn) ! temperature - real, intent(out):: q(isd:ied,jsd:jed,kn,1:ntp) - real, intent(out):: qdiag(isd:ied,jsd:jed,kn,ntp+1:nq) - real, intent(out):: delz(is:,js:,1:) ! delta-height (m) -!----------------------------------------------------------------------- - real r_vir, rgrav - real ps(isd:ied,jsd:jed) ! surface pressure - real pe1(is:ie,km+1) - real pe2(is:ie,kn+1) - real pv1(is:ie+1,km+1) - real pv2(is:ie+1,kn+1) - - integer i,j,k , iq - !CS operator replaces original mono PPM 4 --- lmh 19apr23 - integer, parameter:: kord=4 ! 13 - -#ifdef HYDRO_DELZ_REMAP - if (is_master() .and. .not. hydrostatic) then - print*, '' - print*, ' REMAPPING IC: INITIALIZING DELZ WITH HYDROSTATIC STATE ' - print*, '' - endif -#endif - -#ifdef HYDRO_DELZ_EXTRAP - if (is_master() .and. .not. hydrostatic) then - print*, '' - print*, ' REMAPPING IC: INITIALIZING DELZ WITH HYDROSTATIC STATE ABOVE INPUT MODEL TOP ' - print*, '' - endif -#endif - -#ifdef ZERO_W_EXTRAP - if (is_master() .and. .not. hydrostatic) then - print*, '' - print*, ' REMAPPING IC: INITIALIZING W TO ZERO ABOVE INPUT MODEL TOP ' - print*, '' - endif -#endif - - r_vir = rvgas/rdgas - 1. - rgrav = 1./grav - -!$OMP parallel do default(none) shared(is,ie,js,je,ps,ak_r) - do j=js,je - do i=is,ie - ps(i,j) = ak_r(1) - enddo - enddo - -! this OpenMP do-loop setup cannot work in it's current form.... -!$OMP parallel do default(none) shared(is,ie,js,je,km,ps,delp_r) - do j=js,je - do k=1,km - do i=is,ie - ps(i,j) = ps(i,j) + delp_r(i,j,k) - enddo - enddo - enddo - -! only one cell is needed - if ( square_domain ) then - call mpp_update_domains(ps, domain, whalo=1, ehalo=1, shalo=1, nhalo=1, complete=.true.) - else - call mpp_update_domains(ps, domain, complete=.true.) - endif - -! Compute virtual Temp -!$OMP parallel do default(none) shared(is,ie,js,je,km,pt_r,r_vir,q_r) - do k=1,km - do j=js,je - do i=is,ie - pt_r(i,j,k) = pt_r(i,j,k) * (1.+r_vir*q_r(i,j,k,1)) - enddo - enddo - enddo - -!$OMP parallel do default(none) shared(is,ie,js,je,km,ak_r,bk_r,ps,kn,ak,bk,u0_r,u_r,u0,u,delp, & -!$OMP ntp,nq,hydrostatic,make_nh,w_r,w,delz_r,delp_r,delz, & -!$OMP pt_r,pt,v0_r,v_r,v0,v,q,q_r,qdiag,qdiag_r,is_ideal_case) & -!$OMP private(pe1, pe2, pv1, pv2) - do 1000 j=js,je+1 -!------ -! map u -!------ - do k=1,km+1 - do i=is,ie - pe1(i,k) = ak_r(k) + 0.5*bk_r(k)*(ps(i,j-1)+ps(i,j)) - enddo - enddo - - do k=1,kn+1 - do i=is,ie - pe2(i,k) = ak(k) + 0.5*bk(k)*(ps(i,j-1)+ps(i,j)) - enddo - enddo - - if (is_ideal_case) then - call remap_2d(km, pe1, u0_r(is:ie,j:j,1:km), & - kn, pe2, u0(is:ie,j:j,1:kn), & - is, ie, -1, kord) - endif - - call remap_2d(km, pe1, u_r(is:ie,j:j,1:km), & - kn, pe2, u(is:ie,j:j,1:kn), & - is, ie, -1, kord) - - if ( j /= (je+1) ) then - -!--------------- -! Hybrid sigma-p -!--------------- - do k=1,km+1 - do i=is,ie - pe1(i,k) = ak_r(k) + bk_r(k)*ps(i,j) - enddo - enddo - - do k=1,kn+1 - do i=is,ie - pe2(i,k) = ak(k) + bk(k)*ps(i,j) - enddo - enddo - -!------------- -! Compute delp -!------------- - do k=1,kn - do i=is,ie - delp(i,j,k) = pe2(i,k+1) - pe2(i,k) - enddo - enddo - -!---------------- -! Map constituents -!---------------- - if( nq /= 0 ) then - do iq=1,ntp - call remap_2d(km, pe1, q_r(is:ie,j:j,1:km,iq:iq), & - kn, pe2, q(is:ie,j:j,1:kn,iq:iq), & - is, ie, 0, kord) - enddo - do iq=ntp+1,nq - call remap_2d(km, pe1, qdiag_r(is:ie,j:j,1:km,iq:iq), & - kn, pe2, qdiag(is:ie,j:j,1:kn,iq:iq), & - is, ie, 0, kord) - enddo - endif - - if ( .not. hydrostatic .and. .not. make_nh) then -! Remap vertical wind: - call remap_2d(km, pe1, w_r(is:ie,j:j,1:km), & - kn, pe2, w(is:ie,j:j,1:kn), & - is, ie, -1, kord) - -#ifdef ZERO_W_EXTRAP - do k=1,kn - do i=is,ie - if (pe2(i,k) < pe1(i,1)) then - w(i,j,k) = 0. - endif - enddo - enddo -#endif - -#ifndef HYDRO_DELZ_REMAP -! Remap delz for hybrid sigma-p coordinate - do k=1,km - do i=is,ie - delz_r(i,j,k) = -delz_r(i,j,k)/delp_r(i,j,k) ! ="specific volume"/grav - enddo - enddo - call remap_2d(km, pe1, delz_r(is:ie,j:j,1:km), & - kn, pe2, delz(is:ie,j:j,1:kn), & - is, ie, 1, kord) - do k=1,kn - do i=is,ie - delz(i,j,k) = -delz(i,j,k)*delp(i,j,k) - enddo - enddo -#endif - endif - -! Geopotential conserving remap of virtual temperature: - do k=1,km+1 - do i=is,ie - pe1(i,k) = log(pe1(i,k)) - enddo - enddo - do k=1,kn+1 - do i=is,ie - pe2(i,k) = log(pe2(i,k)) - enddo - enddo - - call remap_2d(km, pe1, pt_r(is:ie,j:j,1:km), & - kn, pe2, pt(is:ie,j:j,1:kn), & - is, ie, 1, kord) - -#ifdef HYDRO_DELZ_REMAP - !initialize delz from the hydrostatic state - do k=1,kn - do i=is,ie - delz(i,j,k) = (rdgas*rgrav)*pt(i,j,k)*(pe2(i,k)-pe2(i,k+1)) - enddo - enddo -#endif -#ifdef HYDRO_DELZ_EXTRAP - !initialize delz from the hydrostatic state - do k=1,kn - do i=is,ie - if (pe2(i,k) < pe1(i,1)) then - delz(i,j,k) = (rdgas*rgrav)*pt(i,j,k)*(pe2(i,k)-pe2(i,k+1)) - endif - enddo - enddo -#endif -!------ -! map v -!------ - do k=1,km+1 - do i=is,ie+1 - pv1(i,k) = ak_r(k) + 0.5*bk_r(k)*(ps(i-1,j)+ps(i,j)) - enddo - enddo - do k=1,kn+1 - do i=is,ie+1 - pv2(i,k) = ak(k) + 0.5*bk(k)*(ps(i-1,j)+ps(i,j)) - enddo - enddo - - if (is_ideal_case) then - call remap_2d(km, pv1, v0_r(is:ie+1,j:j,1:km), & - kn, pv2, v0(is:ie+1,j:j,1:kn), & - is, ie+1, -1, kord) - endif - - call remap_2d(km, pv1, v_r(is:ie+1,j:j,1:km), & - kn, pv2, v(is:ie+1,j:j,1:kn), & - is, ie+1, -1, kord) - - endif !(j < je+1) -1000 continue - -!$OMP parallel do default(none) shared(is,ie,js,je,kn,pt,r_vir,q) - do k=1,kn - do j=js,je - do i=is,ie - pt(i,j,k) = pt(i,j,k) / (1.+r_vir*q(i,j,k,1)) - enddo - enddo - enddo - - end subroutine rst_remap - - - !This routine is indended to remap between different # - ! of vertical levels - subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord) - -! IV = 0: constituents -! IV = 1: potential temp -! IV =-1: winds -! IV =-2: vertical velocity - -! Mass flux preserving mapping: q1(im,km) -> q2(im,kn) - -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate - - integer, intent(in):: i1, i2, km, kn, kord, iv - real, intent(in ):: pe1(i1:i2,km+1), pe2(i1:i2,kn+1) - real, intent(in ):: q1(i1:i2,km) ! input field - real, intent(out):: q2(i1:i2,kn) ! output field - -! local - real qs(i1:i2) - real dp1(i1:i2,km) - real a4(4,i1:i2,km) - integer i, k, l - integer k0, k1 - real pl, pr, tt, delp, qsum, dpsum, esl - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - a4(1,i,k) = q1(i,k) - enddo - enddo - - if ( kord >7 ) then - call cs_profile( qs, a4, dp1, km, i1, i2, iv, kord ) - else - call ppm_profile( a4, dp1, km, i1, i2, iv, kord ) - endif - - do 5555 i=i1,i2 - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k) .le. pe1(i,1)) then -! above old ptop - q2(i,k) = q1(i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = q1(i,km) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. & - pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = r3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) & - - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = r3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ & - a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* & - (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp > 0.) then -! Extended below old ps - qsum = qsum + delp * q1(i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - end subroutine mappm - - - subroutine moist_cv(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, qd, cvm, t1) - integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k - integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel - real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q - real, intent(out), dimension(is:ie):: cvm, qd ! qd is q_con - real, intent(in), optional:: t1(is:ie) -! - real, parameter:: t_i0 = 15. - real, dimension(is:ie):: qv, ql, qs - integer:: i - - select case (nwat) - - case(2) - if ( present(t1) ) then ! Special case for GFS physics - do i=is,ie - qd(i) = max(0., q(i,j,k,liq_wat)) - if ( t1(i) > tice ) then - qs(i) = 0. - elseif ( t1(i) < tice-t_i0 ) then - qs(i) = qd(i) - else - qs(i) = qd(i)*(tice-t1(i))/t_i0 - endif - ql(i) = qd(i) - qs(i) - qv(i) = max(0.,q(i,j,k,sphum)) - cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice - enddo - else - do i=is,ie - qv(i) = max(0.,q(i,j,k,sphum)) - qs(i) = max(0.,q(i,j,k,liq_wat)) - qd(i) = qs(i) - cvm(i) = (1.-qv(i))*cv_air + qv(i)*cv_vap - enddo - endif - case (3) - do i=is,ie - qv(i) = q(i,j,k,sphum) - ql(i) = q(i,j,k,liq_wat) - qs(i) = q(i,j,k,ice_wat) - qd(i) = ql(i) + qs(i) - cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice - enddo - case(4) ! K_warm_rain with fake ice - do i=is,ie - qv(i) = q(i,j,k,sphum) - qd(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) - cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + qd(i)*c_liq - enddo - case(5) - do i=is,ie - qv(i) = q(i,j,k,sphum) - ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) - qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) - qd(i) = ql(i) + qs(i) - cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice - enddo - case(6) - do i=is,ie - qv(i) = q(i,j,k,sphum) - ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) - qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q(i,j,k,graupel) - qd(i) = ql(i) + qs(i) - cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice - enddo - case default - !call mpp_error (NOTE, 'fv_mapz::moist_cv - using default cv_air') - do i=is,ie - qd(i) = 0. - cvm(i) = cv_air - enddo - end select - - end subroutine moist_cv - - subroutine moist_cp(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & - ice_wat, snowwat, graupel, q, qd, cpm, t1) - - integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k - integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel - real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q - real, intent(out), dimension(is:ie):: cpm, qd - real, intent(in), optional:: t1(is:ie) -! - real, parameter:: t_i0 = 15. - real, dimension(is:ie):: qv, ql, qs - integer:: i - - select case (nwat) - - case(2) - if ( present(t1) ) then ! Special case for GFS physics - do i=is,ie - qd(i) = max(0., q(i,j,k,liq_wat)) - if ( t1(i) > tice ) then - qs(i) = 0. - elseif ( t1(i) < tice-t_i0 ) then - qs(i) = qd(i) - else - qs(i) = qd(i)*(tice-t1(i))/t_i0 - endif - ql(i) = qd(i) - qs(i) - qv(i) = max(0.,q(i,j,k,sphum)) - cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice - enddo - else - do i=is,ie - qv(i) = max(0.,q(i,j,k,sphum)) - qs(i) = max(0.,q(i,j,k,liq_wat)) - qd(i) = qs(i) - cpm(i) = (1.-qv(i))*cp_air + qv(i)*cp_vapor - enddo - endif - - case(3) - do i=is,ie - qv(i) = q(i,j,k,sphum) - ql(i) = q(i,j,k,liq_wat) - qs(i) = q(i,j,k,ice_wat) - qd(i) = ql(i) + qs(i) - cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice - enddo - case(4) ! K_warm_rain scheme with fake ice - do i=is,ie - qv(i) = q(i,j,k,sphum) - qd(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) - cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + qd(i)*c_liq - enddo - case(5) - do i=is,ie - qv(i) = q(i,j,k,sphum) - ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) - qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) - qd(i) = ql(i) + qs(i) - cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice - enddo - case(6) - do i=is,ie - qv(i) = q(i,j,k,sphum) - ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) - qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q(i,j,k,graupel) - qd(i) = ql(i) + qs(i) - cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice - enddo - case default - !call mpp_error (NOTE, 'fv_mapz::moist_cp - using default cp_air') - do i=is,ie - qd(i) = 0. - cpm(i) = cp_air - enddo - end select - - end subroutine moist_cp -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping -! -! !INTERFACE: - subroutine map1_cubic( km, pe1, q1, & - kn, pe2, q2, i1, i2, & - j, ibeg, iend, jbeg, jend, akap, T_VAR, conserv) - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - real, intent(in) :: akap - integer, intent(in) :: T_VAR ! Thermodynamic variable to remap - ! 1:TE 2:T 3:PT - logical, intent(in) :: conserv - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: ibeg, iend, jbeg, jend - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - - real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - - real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input -! !INPUT/OUTPUT PARAMETERS: - real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output - -! !DESCRIPTION: -! -! Perform Cubic Interpolation a given latitude -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! -! !REVISION HISTORY: -! 2005.11.14 Takacs Initial Code -! 2016.07.20 Putman Modified to make genaric for any thermodynamic variable -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real qx(i1:i2,km) - real logpl1(i1:i2,km) - real logpl2(i1:i2,kn) - real dlogp1(i1:i2,km) - real vsum1(i1:i2) - real vsum2(i1:i2) - real am2,am1,ap0,ap1,P,PLP1,PLP0,PLM1,PLM2,DLP0,DLM1,DLM2 - - integer i, k, LM2,LM1,LP0,LP1 - -! Initialization -! -------------- - - select case (T_VAR) - case(1) - ! Total Energy Remapping in Log(P) - do k=1,km - qx(:,k) = q1(i1:i2,j,k) - logpl1(:,k) = log( 0.5*(pe1(:,k)+pe1(:,k+1)) ) - enddo - do k=1,kn - logpl2(:,k) = log( 0.5*(pe2(:,k)+pe2(:,k+1)) ) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - - case(2) - ! Temperature Remapping in Log(P) - do k=1,km - qx(:,k) = q1(i1:i2,j,k) - logpl1(:,k) = log( 0.5*(pe1(:,k)+pe1(:,k+1)) ) - enddo - do k=1,kn - logpl2(:,k) = log( 0.5*(pe2(:,k)+pe2(:,k+1)) ) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - - case(3) - ! Potential Temperature Remapping in P^KAPPA - do k=1,km - qx(:,k) = q1(i1:i2,j,k) - logpl1(:,k) = exp( akap*log( 0.5*(pe1(:,k)+pe1(:,k+1))) ) - enddo - do k=1,kn - logpl2(:,k) = exp( akap*log( 0.5*(pe2(:,k)+pe2(:,k+1))) ) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - - end select - - if (conserv) then -! Compute vertical integral of Input TE -! ------------------------------------- - vsum1(:) = 0.0 - do i=i1,i2 - do k=1,km - vsum1(i) = vsum1(i) + qx(i,k)*( pe1(i,k+1)-pe1(i,k) ) - enddo - vsum1(i) = vsum1(i) / ( pe1(i,km+1)-pe1(i,1) ) - enddo - - endif - -! Interpolate TE onto target Pressures -! ------------------------------------ - do i=i1,i2 - do k=1,kn - LM1 = 1 - LP0 = 1 - do while( LP0.le.km ) - if (logpl1(i,LP0).lt.logpl2(i,k)) then - LP0 = LP0+1 - else - exit - endif - enddo - LM1 = max(LP0-1,1) - LP0 = min(LP0, km) - -! Extrapolate Linearly in LogP above first model level -! ---------------------------------------------------- - if( LM1.eq.1 .and. LP0.eq.1 ) then - q2(i,j,k) = qx(i,1) + ( qx(i,2)-qx(i,1) )*( logpl2(i,k)-logpl1(i,1) ) & - /( logpl1(i,2)-logpl1(i,1) ) - -! Extrapolate Linearly in LogP below last model level -! --------------------------------------------------- - else if( LM1.eq.km .and. LP0.eq.km ) then - q2(i,j,k) = qx(i,km) + ( qx(i,km)-qx(i,km-1) )*( logpl2(i,k )-logpl1(i,km ) ) & - /( logpl1(i,km)-logpl1(i,km-1) ) - -! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km -! ----------------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km ) then - q2(i,j,k) = qx(i,LP0) + ( qx(i,LM1)-qx(i,LP0) )*( logpl2(i,k )-logpl1(i,LP0) ) & - /( logpl1(i,LM1)-logpl1(i,LP0) ) -! Interpolate Cubicly in LogP between other model levels -! ------------------------------------------------------ - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(i,k) - PLP1 = logpl1(i,LP1) - PLP0 = logpl1(i,LP0) - PLM1 = logpl1(i,LM1) - PLM2 = logpl1(i,LM2) - DLP0 = dlogp1(i,LP0) - DLM1 = dlogp1(i,LM1) - DLM2 = dlogp1(i,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - q2(i,j,k) = ap1*qx(i,LP1) + ap0*qx(i,LP0) + am1*qx(i,LM1) + am2*qx(i,LM2) - - endif - - enddo - enddo - if (conserv) then - -! Compute vertical integral of Output TE -! -------------------------------------- - vsum2(:) = 0.0 - do i=i1,i2 - do k=1,kn - vsum2(i) = vsum2(i) + q2(i,j,k)*( pe2(i,k+1)-pe2(i,k) ) - enddo - vsum2(i) = vsum2(i) / ( pe2(i,kn+1)-pe2(i,1) ) - enddo - -! Adjust Final TE to conserve -! --------------------------- - do i=i1,i2 - do k=1,kn - q2(i,j,k) = q2(i,j,k) + vsum1(i)-vsum2(i) -! q2(i,j,k) = q2(i,j,k) * vsum1(i)/vsum2(i) - enddo - enddo - - endif - - return -!EOC - end subroutine map1_cubic end module fv_mapz_mod diff --git a/model/fv_nesting.F90 b/model/fv_nesting.F90 index dcd94bbab..3b82ec432 100644 --- a/model/fv_nesting.F90 +++ b/model/fv_nesting.F90 @@ -43,7 +43,7 @@ module fv_nesting_mod use constants_mod, only: grav, pi=>pi_8, hlv, rdgas, cp_air, rvgas, cp_vapor, kappa #endif use fv_arrays_mod, only: radius ! scaled for small earth - use fv_mapz_mod, only: mappm + use fv_operators_mod, only: mappm use fv_timing_mod, only: timing_on, timing_off use fv_mp_mod, only: is_master use fv_mp_mod, only: mp_reduce_sum, global_nest_domain @@ -51,6 +51,7 @@ module fv_nesting_mod use sw_core_mod, only: divergence_corner, divergence_corner_nest use time_manager_mod, only: time_type use gfdl_mp_mod, only: c_liq, c_ice + use fv_thermodynamics_mod, only: fv_thermo_type implicit none logical :: RF_initialized = .false. @@ -74,14 +75,10 @@ module fv_nesting_mod subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & u, v, w, pt, delp, delz,q, uc, vc, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif + q_con, cappa, & nested, inline_q, make_nh, ng, & gridstruct, flagstruct, neststruct, & + thermostruct, & nest_timestep, tracer_nest_timestep, & domain, parent_grid, bd, nwat, ak, bk) @@ -103,18 +100,15 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) ! specific humidity and constituents real, intent(inout) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) ! (uc,vc) mostly used as the C grid winds real, intent(inout) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) -#ifdef USE_COND - real, intent(inout) :: q_con( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) -#ifdef MOIST_CAPPA - real, intent(inout) :: cappa( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) -#endif -#endif + real, intent(inout) :: q_con( bd%isd: ,bd%jsd: ,1:) + real, intent(inout) :: cappa( bd%isd: ,bd%jsd: ,1:) integer, intent(INOUT) :: nest_timestep, tracer_nest_timestep type(fv_atmos_type), pointer, intent(IN) :: parent_grid type(fv_grid_type), intent(INOUT) :: gridstruct type(fv_flags_type), intent(INOUT) :: flagstruct type(fv_nest_type), intent(INOUT), target :: neststruct + type(fv_thermo_type), intent(INOUT) :: thermostruct type(domain2d), intent(INOUT) :: domain real :: divg(bd%isd:bd%ied+1,bd%jsd:bd%jed+1, npz) real :: ua(bd%isd:bd%ied,bd%jsd:bd%jed) @@ -160,7 +154,7 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & if (neststruct%nested .and. (.not. (neststruct%first_step) .or. make_nh) ) then do_pd = .true. - call set_BCs_t0(ncnst, flagstruct%hydrostatic, neststruct) + call set_BCs_t0(ncnst, flagstruct%hydrostatic, neststruct, thermostruct) else !On first timestep the t0 BCs are not initialized and may contain garbage do_pd = .false. @@ -173,8 +167,7 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & !!! CLEANUP: could we make this a non-blocking operation? !!! Is this needed? it is on the initialization step. call mpp_update_domains(delp, domain) !This is needed to make sure delp is updated for pe calculations - call mpp_update_domains(u, v, & - domain, gridtype=DGRID_NE, complete=.true.) + call mpp_update_domains(u, v, domain, gridtype=DGRID_NE, complete=.true.) call timing_off('COMM_TOTAL') !$OMP parallel do default(none) shared(isd,jsd,ied,jed,is,ie,js,je,npx,npy,npz, & !$OMP gridstruct,flagstruct,bd,u,v,uc,vc,nested,divg) & @@ -399,6 +392,10 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & sphum = get_tracer_index (MODEL_ATMOS, 'sphum') if (flagstruct%hydrostatic) then + if (.not. neststruct%do_remap_BC(flagstruct%grid_number)) then + call allocate_fv_nest_BC_type(pe_eul_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1,ng,0,0,0,.false.) + call compute_peBC(neststruct%delp_BC, pe_eul_bc, npx, npy, npz, parent_grid%ptop, bd) + endif call setup_pt_BC(neststruct%pt_BC, pe_eul_BC, neststruct%q_BC(sphum), npx, npy, npz, zvir, bd) else if (neststruct%do_remap_BC(flagstruct%grid_number)) then @@ -423,13 +420,8 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & call setup_pt_NH_BC(neststruct%pt_BC, neststruct%delp_BC, neststruct%delz_BC, & neststruct%q_BC(sphum), neststruct%q_BC, ncnst, & -#ifdef USE_COND - neststruct%q_con_BC, & -#ifdef MOIST_CAPPA - neststruct%cappa_BC, & -#endif -#endif - npx, npy, npz, zvir, bd) + neststruct%q_con_BC, neststruct%cappa_BC, & + thermostruct, npx, npy, npz, zvir, bd) endif #endif @@ -518,6 +510,10 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & endif + if (flagstruct%hydrostatic .and. (.not. neststruct%do_remap_BC(flagstruct%grid_number))) then + call deallocate_fv_nest_BC_type(pe_eul_BC) + endif + !Correct halo values have now been set up for BCs; we can go ahead and apply them too call nested_grid_BC_apply_intT(delp, & 0, 0, npx, npy, npz, bd, 1., 1., & @@ -536,16 +532,16 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & 0, 0, npx, npy, npz, bd, 1., 1., & neststruct%w_BC, bctype=neststruct%nestbctype ) endif -#ifdef USE_COND - call nested_grid_BC_apply_intT(q_con, & - 0, 0, npx, npy, npz, bd, 1., 1., & - neststruct%q_con_BC, bctype=neststruct%nestbctype ) -#ifdef MOIST_CAPPA - call nested_grid_BC_apply_intT(cappa, & - 0, 0, npx, npy, npz, bd, 1., 1., & - neststruct%cappa_BC, bctype=neststruct%nestbctype ) -#endif -#endif + if (thermostruct%use_cond) then + call nested_grid_BC_apply_intT(q_con, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%q_con_BC, bctype=neststruct%nestbctype ) + if (thermostruct%moist_kappa) then + call nested_grid_BC_apply_intT(cappa, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%cappa_BC, bctype=neststruct%nestbctype ) + endif + endif #endif call nested_grid_BC_apply_intT(u, & 0, 1, npx, npy, npz, bd, 1., 1., & @@ -567,7 +563,7 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & endif if (neststruct%first_step) then - if (neststruct%nested) call set_BCs_t0(ncnst, flagstruct%hydrostatic, neststruct) + if (neststruct%nested) call set_BCs_t0(ncnst, flagstruct%hydrostatic, neststruct, thermostruct) neststruct%first_step = .false. if (.not. flagstruct%hydrostatic) flagstruct%make_nh= .false. else if (flagstruct%make_nh) then @@ -700,7 +696,7 @@ subroutine setup_pt_BC(pt_BC, pe_eul_BC, sphum_BC, npx, npy, npz, zvir, bd) jed = bd%jed if (is == 1) then - call setup_pt_BC_k(pt_BC%west_t1, sphum_BC%west_t1, pe_eul_BC%west_t1, zvir, isd, ied, isd, 0, jsd, jed, npz) + call setup_pt_BC_k(pt_BC%west_t1, sphum_BC%west_t1, pe_eul_BC%west_t1, zvir, isd, 0, isd, 0, jsd, jed, npz) end if if (js == 1) then @@ -720,7 +716,7 @@ subroutine setup_pt_BC(pt_BC, pe_eul_BC, sphum_BC, npx, npy, npz, zvir, bd) if (ie == npx-1) then - call setup_pt_BC_k(pt_BC%east_t1, sphum_BC%east_t1, pe_eul_BC%east_t1, zvir, isd, ied, npx, ied, jsd, jed, npz) + call setup_pt_BC_k(pt_BC%east_t1, sphum_BC%east_t1, pe_eul_BC%east_t1, zvir, npx, ied, npx, ied, jsd, jed, npz) end if if (je == npy-1) then @@ -746,6 +742,86 @@ end subroutine setup_pt_BC !!!! However these were NOT intended to delineate the dimensions of the data domain !!!! but instead were of the BC arrays. This is confusing especially in other locations !!!! where BCs and data arrays are both present. + + subroutine compute_peBC(delp_BC, pe_BC, npx, npy, npz, ptop_src, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(INOUT), target :: delp_BC + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_BC + integer, intent(IN) :: npx, npy, npz + real, intent(IN) :: ptop_src + + integer :: i,j,k, istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (is == 1) then + call compute_peBC_k(delp_BC%west_t1, pe_BC%west_t1, & + ptop_src, isd, 0, isd, 0, jsd, jed, npz) + end if + + if (ie == npx-1) then + call compute_peBC_k(delp_BC%east_t1, pe_BC%east_t1, & + ptop_src, npx, ied, npx, ied, jsd, jed, npz) + end if + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then + call compute_peBC_k(delp_BC%south_t1, pe_BC%south_t1, & + ptop_src, isd, ied, istart, iend, jsd, 0, npz) + end if + + if (je == npy-1) then + call compute_peBC_k(delp_BC%north_t1, pe_BC%north_t1, & + ptop_src, isd, ied, istart, iend, npy, jed, npz) + end if + + end subroutine compute_peBC + + + + + subroutine compute_peBC_k(delp, peBC, ptop_src, isd_BC, ied_BC, istart, iend, jstart, jend, npz) + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz + real, intent(INOUT) :: delp(isd_BC:ied_BC,jstart:jend,npz), peBC(isd_BC:ied_BC,jstart:jend,npz+1) + real, intent(IN) :: ptop_src + + integer :: i,j,k + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,peBC,ptop_src,delp,npz) + do j=jstart,jend + do i=istart,iend + peBC(i,j,1) = ptop_src + enddo + do k=1,npz + do i=istart,iend + peBC(i,j,k+1) = peBC(i,j,k) + delp(i,j,k) + enddo + enddo + enddo + + end subroutine compute_peBC_k + subroutine setup_pt_BC_k(ptBC, sphumBC, peBC, zvir, isd_BC, ied_BC, istart, iend, jstart, jend, npz) integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz @@ -1314,12 +1390,7 @@ end subroutine compute_delz_BC_k subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & -#ifdef USE_COND - q_con_BC, & -#ifdef MOIST_CAPPA - cappa_BC, & -#endif -#endif + q_con_BC, cappa_BC, thermostruct, & npx, npy, npz, zvir, bd) type(fv_grid_bounds_type), intent(IN) :: bd @@ -1327,12 +1398,10 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & type(fv_nest_BC_type_3d), intent(INOUT), target :: pt_BC integer, intent(IN) :: nq type(fv_nest_BC_type_3d), intent(IN), target :: q_BC(nq) -#ifdef USE_COND type(fv_nest_BC_type_3d), intent(INOUT), target :: q_con_BC -#ifdef MOIST_CAPPA type(fv_nest_BC_type_3d), intent(INOUT), target :: cappa_BC -#endif -#endif + type(fv_thermo_type), intent(INOUT) :: thermostruct + integer, intent(IN) :: npx, npy, npz real, intent(IN) :: zvir @@ -1484,12 +1553,7 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & call setup_pt_NH_BC_k(pt_BC%west_t1, sphum_BC%west_t1, delp_BC%west_t1, delz_BC%west_t1, & liq_watBC_west, rainwatBC_west, ice_watBC_west, snowwatBC_west, graupelBC_west, & -#ifdef USE_COND - q_con_BC%west_t1, & -#ifdef MOIST_CAPPA - cappa_BC%west_t1, & -#endif -#endif + q_con_BC%west_t1, cappa_BC%west_t1, thermostruct%use_cond, thermostruct%moist_kappa, & zvir, isd, 0, isd, 0, jsd, jed, npz) end if @@ -1508,12 +1572,7 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & call setup_pt_NH_BC_k(pt_BC%south_t1, sphum_BC%south_t1, delp_BC%south_t1, delz_BC%south_t1, & liq_watBC_south, rainwatBC_south, ice_watBC_south, snowwatBC_south, graupelBC_south, & -#ifdef USE_COND - q_con_BC%south_t1, & -#ifdef MOIST_CAPPA - cappa_BC%south_t1, & -#endif -#endif + q_con_BC%south_t1, cappa_BC%south_t1, thermostruct%use_cond, thermostruct%moist_kappa, & zvir, isd, ied, istart, iend, jsd, 0, npz) end if @@ -1522,12 +1581,7 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & call setup_pt_NH_BC_k(pt_BC%east_t1, sphum_BC%east_t1, delp_BC%east_t1, delz_BC%east_t1, & liq_watBC_east, rainwatBC_east, ice_watBC_east, snowwatBC_east, graupelBC_east, & -#ifdef USE_COND - q_con_BC%east_t1, & -#ifdef MOIST_CAPPA - cappa_BC%east_t1, & -#endif -#endif + q_con_BC%east_t1, cappa_BC%east_t1, thermostruct%use_cond, thermostruct%moist_kappa, & zvir, npx, ied, npx, ied, jsd, jed, npz) end if @@ -1545,12 +1599,7 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & call setup_pt_NH_BC_k(pt_BC%north_t1, sphum_BC%north_t1, delp_BC%north_t1, delz_BC%north_t1, & liq_watBC_north, rainwatBC_north, ice_watBC_north, snowwatBC_north, graupelBC_north, & -#ifdef USE_COND - q_con_BC%north_t1, & -#ifdef MOIST_CAPPA - cappa_BC%north_t1, & -#endif -#endif + q_con_BC%north_t1, cappa_BC%north_t1, thermostruct%use_cond, thermostruct%moist_kappa, & zvir, isd, ied, istart, iend, npy, jed, npz) end if @@ -1559,24 +1608,16 @@ end subroutine setup_pt_NH_BC subroutine setup_pt_NH_BC_k(ptBC,sphumBC,delpBC,delzBC, & liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & -#ifdef USE_COND - q_conBC, & -#ifdef MOIST_CAPPA - cappaBC, & -#endif -#endif + q_conBC, cappaBC, use_cond, moist_kappa, & zvir, isd_BC, ied_BC, istart, iend, jstart, jend, npz) integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz + logical, intent(IN) :: use_cond, moist_kappa real, intent(OUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: ptBC real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: sphumBC, delpBC, delzBC real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC -#ifdef USE_COND - real, intent(OUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: q_conBC -#ifdef MOIST_CAPPA - real, intent(OUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: cappaBC -#endif -#endif + real, intent(OUT), dimension(isd_BC:,jstart:,1:) :: q_conBC + real, intent(OUT), dimension(isd_BC:,jstart:,1:) :: cappaBC real, intent(IN) :: zvir integer :: i,j,k @@ -1589,42 +1630,61 @@ subroutine setup_pt_NH_BC_k(ptBC,sphumBC,delpBC,delzBC, & rdg = -rdgas / grav cv_air = cp_air - rdgas + if (use_cond) then + if (moist_kappa) then !$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,zvir,ptBC,sphumBC,delpBC,delzBC,liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & -#ifdef USE_COND -!$OMP q_conBC, & -#ifdef MOIST_CAPPA -!$OMP cappaBC, & -#endif -#endif -!$OMP rdg, cv_air) & +!$OMP q_conBC, cappaBC, rdg, cv_air) & !$OMP private(dp1,q_liq,q_sol,q_con,cvm,pkz) - do k=1,npz - do j=jstart,jend - do i=istart,iend - dp1 = zvir*sphumBC(i,j,k) -#ifdef USE_COND - q_liq = liq_watBC(i,j,k) + rainwatBC(i,j,k) - q_sol = ice_watBC(i,j,k) + snowwatBC(i,j,k) + graupelBC(i,j,k) - q_con = q_liq + q_sol - q_conBC(i,j,k) = q_con -#ifdef MOIST_CAPPA - cvm = (1.-(sphumBC(i,j,k)+q_con))*cv_air+sphumBC(i,j,k)*cv_vap+q_liq*c_liq+q_sol*c_ice - cappaBC(i,j,k) = rdgas/(rdgas + cvm/(1.+dp1)) - pkz = exp( cappaBC(i,j,k)*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) -#endif - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)*(1.-q_con)/pkz -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)/delzBC(i,j,k))) - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)/pkz -#endif - end do - end do - end do + do k=1,npz + do j=jstart,jend + do i=istart,iend + dp1 = zvir*sphumBC(i,j,k) + q_liq = liq_watBC(i,j,k) + rainwatBC(i,j,k) + q_sol = ice_watBC(i,j,k) + snowwatBC(i,j,k) + graupelBC(i,j,k) + q_con = q_liq + q_sol + q_conBC(i,j,k) = q_con + cvm = (1.-(sphumBC(i,j,k)+q_con))*cv_air+sphumBC(i,j,k)*cv_vap+q_liq*c_liq+q_sol*c_ice + cappaBC(i,j,k) = rdgas/(rdgas + cvm/(1.+dp1)) + pkz = exp( cappaBC(i,j,k)*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & + (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) + ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)*(1.-q_con)/pkz + end do + end do + end do + else +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,zvir,ptBC,sphumBC,delpBC,delzBC,liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & +!$OMP q_conBC, rdg, cv_air) & +!$OMP private(dp1,q_liq,q_sol,q_con,pkz) + do k=1,npz + do j=jstart,jend + do i=istart,iend + dp1 = zvir*sphumBC(i,j,k) + q_liq = liq_watBC(i,j,k) + rainwatBC(i,j,k) + q_sol = ice_watBC(i,j,k) + snowwatBC(i,j,k) + graupelBC(i,j,k) + q_con = q_liq + q_sol + q_conBC(i,j,k) = q_con + pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & + (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) + ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)*(1.-q_con)/pkz + end do + end do + end do + endif !moist_kappa + else +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,zvir,ptBC,sphumBC,delpBC,delzBC,liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & +!$OMP q_conBC, cappaBC, rdg, cv_air) & +!$OMP private(dp1,q_liq,q_sol,q_con,cvm,pkz) + do k=1,npz + do j=jstart,jend + do i=istart,iend + dp1 = zvir*sphumBC(i,j,k) + pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & + (1.+dp1)/delzBC(i,j,k))) + ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)/pkz + end do + end do + end do + endif !use_cond end subroutine setup_pt_NH_BC_k @@ -1646,11 +1706,12 @@ subroutine set_NH_BCs_t0(neststruct) end subroutine set_NH_BCs_t0 - subroutine set_BCs_t0(ncnst, hydrostatic, neststruct) + subroutine set_BCs_t0(ncnst, hydrostatic, neststruct, thermostruct) integer, intent(IN) :: ncnst logical, intent(IN) :: hydrostatic type(fv_nest_type), intent(INOUT) :: neststruct + type(fv_thermo_type), intent(INOUT) :: thermostruct integer :: n @@ -1674,18 +1735,18 @@ subroutine set_BCs_t0(ncnst, hydrostatic, neststruct) neststruct%pt_BC%north_t0 = neststruct%pt_BC%north_t1 neststruct%pt_BC%south_t0 = neststruct%pt_BC%south_t1 -#ifdef USE_COND - neststruct%q_con_BC%east_t0 = neststruct%q_con_BC%east_t1 - neststruct%q_con_BC%west_t0 = neststruct%q_con_BC%west_t1 - neststruct%q_con_BC%north_t0 = neststruct%q_con_BC%north_t1 - neststruct%q_con_BC%south_t0 = neststruct%q_con_BC%south_t1 -#ifdef MOIST_CAPPA - neststruct%cappa_BC%east_t0 = neststruct%cappa_BC%east_t1 - neststruct%cappa_BC%west_t0 = neststruct%cappa_BC%west_t1 - neststruct%cappa_BC%north_t0 = neststruct%cappa_BC%north_t1 - neststruct%cappa_BC%south_t0 = neststruct%cappa_BC%south_t1 -#endif -#endif + if (thermostruct%use_cond) then + neststruct%q_con_BC%east_t0 = neststruct%q_con_BC%east_t1 + neststruct%q_con_BC%west_t0 = neststruct%q_con_BC%west_t1 + neststruct%q_con_BC%north_t0 = neststruct%q_con_BC%north_t1 + neststruct%q_con_BC%south_t0 = neststruct%q_con_BC%south_t1 + if (thermostruct%moist_kappa) then + neststruct%cappa_BC%east_t0 = neststruct%cappa_BC%east_t1 + neststruct%cappa_BC%west_t0 = neststruct%cappa_BC%west_t1 + neststruct%cappa_BC%north_t0 = neststruct%cappa_BC%north_t1 + neststruct%cappa_BC%south_t0 = neststruct%cappa_BC%south_t1 + endif + endif if (.not. hydrostatic) then call set_NH_BCs_t0(neststruct) @@ -2784,7 +2845,7 @@ subroutine after_twoway_nest_update(npx, npy, npz, ng, ncnst, & call cubed_to_latlon(u, v, ua, va, & gridstruct, npx, npy, npz, & 1, gridstruct%grid_type, domain, & - gridstruct%bounded_domain, flagstruct%c2l_ord, bd) + gridstruct%bounded_domain, 4, bd) #ifndef SW_DYNAMICS diff --git a/model/fv_operators.F90 b/model/fv_operators.F90 new file mode 100644 index 000000000..fb0fe9357 --- /dev/null +++ b/model/fv_operators.F90 @@ -0,0 +1,2099 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** +module fv_operators_mod + + use mpp_mod, only: FATAL, mpp_error + use fv_fill_mod, only: fillz + + implicit none + real, parameter:: r3 = 1./3., r23 = 2./3., r12 = 1./12. + + private + public map_scalar ! For temperature/energy, enforces minimum + public map1_ppm ! For dynamical scalars, no minimum + public mapn_tracer! Efficient multi-remap of tracers defined wrt delp, includes fillz call + public map1_q2 ! Remaps tracers defined wrt delp, no fillz call + public remap_2d ! For remapping 2d fields and when input and output vertical coordinates differ + public mappm ! For remapping when input and output vertical coordinates differ + public map1_cubic ! GMAO cubic interpolation for total energy + +contains + + subroutine map_scalar( km, pe1, q1, qs, & + kn, pe2, q2, i1, i2, & + j, ibeg, iend, jbeg, jend, & + iv, kord, q_min) +! iv=1 + integer, intent(in) :: i1 ! Starting longitude + integer, intent(in) :: i2 ! Finishing longitude + integer, intent(in) :: iv ! Mode: 0 == constituents 1 == temp + ! 2 == remap temp with cs scheme + ! -2 or -3 == w with lower bc + integer, intent(in) :: kord ! Method order + integer, intent(in) :: j ! Current latitude + integer, intent(in) :: ibeg, iend, jbeg, jend + integer, intent(in) :: km ! Original vertical dimension + integer, intent(in) :: kn ! Target vertical dimension + real, intent(in) :: qs(i1:i2) ! bottom BC + real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the original vertical coordinate + real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the new vertical coordinate + real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input +! !INPUT/OUTPUT PARAMETERS: + real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output + real, intent(in):: q_min + +! !DESCRIPTION: +! IV = 0: constituents: enforce positivity in interface values and reconstruction +! pe1: pressure at layer edges (from model top to bottom surface) +! in the original vertical coordinate +! pe2: pressure at layer edges (from model top to bottom surface) +! in the new vertical coordinate +! !LOCAL VARIABLES: + real dp1(i1:i2,km) + real q4(4,i1:i2,km) + real pl, pr, qsum, dp, esl + integer i, k, l, m, k0 + + do k=1,km + do i=i1,i2 + dp1(i,k) = pe1(i,k+1) - pe1(i,k) + q4(1,i,k) = q1(i,j,k) + enddo + enddo + + ! Compute vertical subgrid distribution + if ( kord >7 ) then + call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min ) + else + call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) + endif + + do i=i1,i2 + k0 = 1 + do 555 k=1,kn + do l=k0,km +! locate the top edge: pe2(i,k) + if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then + pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) + if( pe2(i,k+1) <= pe1(i,l+1) ) then +! entire new grid is within the original grid + pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) + q2(i,j,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & + *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) + k0 = l + goto 555 + else +! Fractional area... + qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & + q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & + (r3*(1.+pl*(1.+pl)))) + do m=l+1,km +! locate the bottom edge: pe2(i,k+1) + if( pe2(i,k+1) > pe1(i,m+1) ) then +! Whole layer + qsum = qsum + dp1(i,m)*q4(1,i,m) + else + dp = pe2(i,k+1)-pe1(i,m) + esl = dp / dp1(i,m) + qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & + (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) + k0 = m + goto 123 + endif + enddo + goto 123 + endif + endif + enddo +123 q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) +555 continue + enddo + + end subroutine map_scalar + + + subroutine map1_ppm( km, pe1, q1, qs, & + kn, pe2, q2, i1, i2, & + j, ibeg, iend, jbeg, jend, & + iv, kord) + integer, intent(in) :: i1 ! Starting longitude + integer, intent(in) :: i2 ! Finishing longitude + integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? + ! 2 == remap temp with cs scheme + ! -1 == vertical velocity, with bottom BC + integer, intent(in) :: kord ! Method order + integer, intent(in) :: j ! Current latitude + integer, intent(in) :: ibeg, iend, jbeg, jend + integer, intent(in) :: km ! Original vertical dimension + integer, intent(in) :: kn ! Target vertical dimension + real, intent(in) :: qs(i1:i2) ! bottom BC (only used if iv == -2 ) + real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the original vertical coordinate + real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the new vertical coordinate + real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input +! !INPUT/OUTPUT PARAMETERS: + real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output + +! !DESCRIPTION: +! IV = 0: constituents +! pe1: pressure at layer edges (from model top to bottom surface) +! in the original vertical coordinate +! pe2: pressure at layer edges (from model top to bottom surface) +! in the new vertical coordinate +! !LOCAL VARIABLES: + real dp1(i1:i2,km) + real q4(4,i1:i2,km) + real pl, pr, qsum, dp, esl + integer i, k, l, m, k0 + + do k=1,km + do i=i1,i2 + dp1(i,k) = pe1(i,k+1) - pe1(i,k) + q4(1,i,k) = q1(i,j,k) + enddo + enddo + +! Compute vertical subgrid distribution + if ( kord >7 ) then + call cs_profile( qs, q4, dp1, km, i1, i2, iv, kord ) + else + call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) + endif + + do i=i1,i2 + k0 = 1 + do 555 k=1,kn + do l=k0,km +! locate the top edge: pe2(i,k) + if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then + pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) + if( pe2(i,k+1) <= pe1(i,l+1) ) then +! entire new grid is within the original grid + pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) + q2(i,j,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & + *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) + k0 = l + goto 555 + else +! Fractional area... + qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & + q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & + (r3*(1.+pl*(1.+pl)))) + do m=l+1,km +! locate the bottom edge: pe2(i,k+1) + if( pe2(i,k+1) > pe1(i,m+1) ) then +! Whole layer + qsum = qsum + dp1(i,m)*q4(1,i,m) + else + dp = pe2(i,k+1)-pe1(i,m) + esl = dp / dp1(i,m) + qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & + (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) + k0 = m + goto 123 + endif + enddo + goto 123 + endif + endif + enddo +123 q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) +555 continue + enddo + + end subroutine map1_ppm + + +!Multi-tracer remapping (much faster) +!ONLY supports cubic-spline remapping + subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, & + i1, i2, isd, ied, jsd, jed, & + q_min, fill) +! !INPUT PARAMETERS: + integer, intent(in):: km ! vertical dimension + integer, intent(in):: j, nq, i1, i2 + integer, intent(in):: isd, ied, jsd, jed + integer, intent(in):: kord(nq) + real, intent(in):: pe1(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the original vertical coordinate + real, intent(in):: pe2(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the new vertical coordinate + real, intent(in):: dp2(i1:i2,km) + real, intent(in):: q_min + logical, intent(in):: fill + real, intent(inout):: q1(isd:ied,jsd:jed,km,nq) ! Field input +! !LOCAL VARIABLES: + real:: q4(4,i1:i2,km,nq) + real:: q2(i1:i2,km,nq) ! Field output + real:: qsum(nq) + real:: dp1(i1:i2,km) + real:: qs(i1:i2) + real:: pl, pr, dp, esl, fac1, fac2 + integer:: i, k, l, m, k0, iq + + do k=1,km + do i=i1,i2 + dp1(i,k) = pe1(i,k+1) - pe1(i,k) + enddo + enddo + + do iq=1,nq + do k=1,km + do i=i1,i2 + q4(1,i,k,iq) = q1(i,j,k,iq) + enddo + enddo + call scalar_profile( qs, q4(1,i1,1,iq), dp1, km, i1, i2, 0, kord(iq), q_min ) + enddo + +! Mapping + do 1000 i=i1,i2 + k0 = 1 + do 555 k=1,km + do 100 l=k0,km +! locate the top edge: pe2(i,k) + if(pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1)) then + pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) + if(pe2(i,k+1) <= pe1(i,l+1)) then +! entire new grid is within the original grid + pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) + fac1 = pr + pl + fac2 = r3*(pr*fac1 + pl*pl) + fac1 = 0.5*fac1 + do iq=1,nq + q2(i,k,iq) = q4(2,i,l,iq) + (q4(4,i,l,iq)+q4(3,i,l,iq)-q4(2,i,l,iq))*fac1 & + - q4(4,i,l,iq)*fac2 + enddo + k0 = l + goto 555 + else +! Fractional area... + dp = pe1(i,l+1) - pe2(i,k) + fac1 = 1. + pl + fac2 = r3*(1.+pl*fac1) + fac1 = 0.5*fac1 + do iq=1,nq + qsum(iq) = dp*(q4(2,i,l,iq) + (q4(4,i,l,iq)+ & + q4(3,i,l,iq) - q4(2,i,l,iq))*fac1 - q4(4,i,l,iq)*fac2) + enddo + do m=l+1,km +! locate the bottom edge: pe2(i,k+1) + if(pe2(i,k+1) > pe1(i,m+1) ) then + ! Whole layer.. + do iq=1,nq + qsum(iq) = qsum(iq) + dp1(i,m)*q4(1,i,m,iq) + enddo + else + dp = pe2(i,k+1)-pe1(i,m) + esl = dp / dp1(i,m) + fac1 = 0.5*esl + fac2 = 1.-r23*esl + do iq=1,nq + qsum(iq) = qsum(iq) + dp*( q4(2,i,m,iq) + fac1*( & + q4(3,i,m,iq)-q4(2,i,m,iq)+q4(4,i,m,iq)*fac2 ) ) + enddo + k0 = m + goto 123 + endif + enddo + goto 123 + endif + endif +100 continue +123 continue + do iq=1,nq + q2(i,k,iq) = qsum(iq) / dp2(i,k) + enddo +555 continue +1000 continue + + if (fill) call fillz(i2-i1+1, km, nq, q2, dp2) + + do iq=1,nq +! if (fill) call fillz(i2-i1+1, km, 1, q2(i1,1,iq), dp2) + do k=1,km + do i=i1,i2 + q1(i,j,k,iq) = q2(i,k,iq) + enddo + enddo + enddo + + end subroutine mapn_tracer + + + !This routine remaps a single tracer + subroutine map1_q2(km, pe1, q1, & + kn, pe2, q2, dp2, & + i1, i2, iv, kord, j, & + ibeg, iend, jbeg, jend, & + q_min ) + + +! !INPUT PARAMETERS: + integer, intent(in) :: j + integer, intent(in) :: i1, i2 + integer, intent(in) :: ibeg, iend, jbeg, jend + integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? + integer, intent(in) :: kord + integer, intent(in) :: km ! Original vertical dimension + integer, intent(in) :: kn ! Target vertical dimension + + real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the original vertical coordinate + real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the new vertical coordinate + real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input + real, intent(in) :: dp2(i1:i2,kn) + real, intent(in) :: q_min +! !INPUT/OUTPUT PARAMETERS: + real, intent(inout):: q2(i1:i2,kn) ! Field output +! !LOCAL VARIABLES: + real qs(i1:i2) + real dp1(i1:i2,km) + real q4(4,i1:i2,km) + real pl, pr, qsum, dp, esl + + integer i, k, l, m, k0 + + do k=1,km + do i=i1,i2 + dp1(i,k) = pe1(i,k+1) - pe1(i,k) + q4(1,i,k) = q1(i,j,k) + enddo + enddo + +! Compute vertical subgrid distribution + if ( kord >7 ) then + call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min ) + else + call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) + endif + +! Mapping + do 1000 i=i1,i2 + k0 = 1 + do 555 k=1,kn + do 100 l=k0,km +! locate the top edge: pe2(i,k) + if(pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1)) then + pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) + if(pe2(i,k+1) <= pe1(i,l+1)) then +! entire new grid is within the original grid + pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) + q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & + *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) + k0 = l + goto 555 + else +! Fractional area... + qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & + q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & + (r3*(1.+pl*(1.+pl)))) + do m=l+1,km +! locate the bottom edge: pe2(i,k+1) + if(pe2(i,k+1) > pe1(i,m+1) ) then + ! Whole layer.. + qsum = qsum + dp1(i,m)*q4(1,i,m) + else + dp = pe2(i,k+1)-pe1(i,m) + esl = dp / dp1(i,m) + qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & + (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) + k0 = m + goto 123 + endif + enddo + goto 123 + endif + endif +100 continue +123 q2(i,k) = qsum / dp2(i,k) +555 continue +1000 continue + + end subroutine map1_q2 + + + !Currently this routine is only called with kord = 4, + ! --- lmh 9 june 21 + subroutine remap_2d(km, pe1, q1, & + kn, pe2, q2, & + i1, i2, & + iv, kord) + integer, intent(in):: i1, i2 + integer, intent(in):: iv ! Mode: 0 == constituents 1 ==others + integer, intent(in):: kord + integer, intent(in):: km ! Original vertical dimension + integer, intent(in):: kn ! Target vertical dimension + real, intent(in):: pe1(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the original vertical coordinate + real, intent(in):: pe2(i1:i2,kn+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the new vertical coordinate + real, intent(in) :: q1(i1:i2,km) ! Field input + real, intent(out):: q2(i1:i2,kn) ! Field output +! !LOCAL VARIABLES: + real qs(i1:i2) + real dp1(i1:i2,km) + real q4(4,i1:i2,km) + real pl, pr, qsum, dp, esl + integer i, k, l, m, k0 + + do k=1,km + do i=i1,i2 + dp1(i,k) = pe1(i,k+1) - pe1(i,k) + q4(1,i,k) = q1(i,k) + enddo + enddo + +! Compute vertical subgrid distribution + if ( kord >7 ) then + call cs_profile( qs, q4, dp1, km, i1, i2, iv, kord ) + else + call ppm_profile( q4, dp1, km, i1, i2, iv, kord ) + endif + + do i=i1,i2 + k0 = 1 + do 555 k=1,kn +#ifdef OLD_TOP_EDGE + if( pe2(i,k+1) <= pe1(i,1) ) then +! Entire grid above old ptop + q2(i,k) = q4(2,i,1) + elseif( pe2(i,k) < pe1(i,1) .and. pe2(i,k+1)>pe1(i,1) ) then +! Partially above old ptop: + q2(i,k) = q1(i,1) +#else + if( pe2(i,k) <= pe1(i,1) ) then +! above old ptop: + q2(i,k) = q1(i,1) +#endif + else + do l=k0,km +! locate the top edge: pe2(i,k) + if( pe2(i,k) >= pe1(i,l) .and. pe2(i,k) <= pe1(i,l+1) ) then + pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) + if(pe2(i,k+1) <= pe1(i,l+1)) then +! entire new grid is within the original grid + pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) + q2(i,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & + *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) + k0 = l + goto 555 + else +! Fractional area... + qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & + q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & + (r3*(1.+pl*(1.+pl)))) + do m=l+1,km +! locate the bottom edge: pe2(i,k+1) + if(pe2(i,k+1) > pe1(i,m+1) ) then + ! Whole layer.. + qsum = qsum + dp1(i,m)*q4(1,i,m) + else + dp = pe2(i,k+1)-pe1(i,m) + esl = dp / dp1(i,m) + qsum = qsum + dp*(q4(2,i,m)+0.5*esl* & + (q4(3,i,m)-q4(2,i,m)+q4(4,i,m)*(1.-r23*esl))) + k0 = m + goto 123 + endif + enddo + goto 123 + endif + endif + enddo +123 q2(i,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) + endif +555 continue + enddo + + end subroutine remap_2d + + !scalar_profile and cs_profile differ ONLY in that scalar_profile + ! accepts a qmin argument. (Unfortunately I was not able to make + ! qmin an optional argument in scalar_profile.) --- lmh summer 2020 + subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin) +! Optimized vertical profile reconstruction: +! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL + integer, intent(in):: i1, i2 + integer, intent(in):: km ! vertical dimension + integer, intent(in):: iv ! iv =-1: winds + ! iv = 0: positive definite scalars + ! iv = 1: others + integer, intent(in):: kord + real, intent(in) :: qs(i1:i2) + real, intent(in) :: delp(i1:i2,km) ! layer pressure thickness + real, intent(inout):: a4(4,i1:i2,km) ! Interpolated values + real, intent(in):: qmin +!----------------------------------------------------------------------- + logical, dimension(i1:i2,km):: extm, ext5, ext6 + real gam(i1:i2,km) + real q(i1:i2,km+1) + real d4(i1:i2) + real bet, a_bot, grat + real pmp_1, lac_1, pmp_2, lac_2, x0, x1 + integer i, k, im + + !Compute interface values (\hat{q}) + ! iv=-2 and -3 introduce the lower BC + ! iv=-2 also uses a simpler calculation + ! dropping a lot of metric terms + if ( iv .eq. -2 ) then + do i=i1,i2 + gam(i,2) = 0.5 + q(i,1) = 1.5*a4(1,i,1) + enddo + do k=2,km-1 + do i=i1, i2 + grat = delp(i,k-1) / delp(i,k) + bet = 2. + grat + grat - gam(i,k) + q(i,k) = (3.*(a4(1,i,k-1)+a4(1,i,k)) - q(i,k-1))/bet + gam(i,k+1) = grat / bet + enddo + enddo + do i=i1,i2 + grat = delp(i,km-1) / delp(i,km) + q(i,km) = (3.*(a4(1,i,km-1)+a4(1,i,km)) - grat*qs(i) - q(i,km-1)) / & + (2. + grat + grat - gam(i,km)) + q(i,km+1) = qs(i) + enddo + do k=km-1,1,-1 + do i=i1,i2 + q(i,k) = q(i,k) - gam(i,k+1)*q(i,k+1) + enddo + enddo + else + do i=i1,i2 + grat = delp(i,2) / delp(i,1) ! grid ratio + bet = grat*(grat+0.5) + q(i,1) = ( (grat+grat)*(grat+1.)*a4(1,i,1) + a4(1,i,2) ) / bet + gam(i,1) = ( 1. + grat*(grat+1.5) ) / bet + enddo + + do k=2,km + do i=i1,i2 + d4(i) = delp(i,k-1) / delp(i,k) + bet = 2. + d4(i) + d4(i) - gam(i,k-1) + q(i,k) = ( 3.*(a4(1,i,k-1)+d4(i)*a4(1,i,k)) - q(i,k-1) )/bet + gam(i,k) = d4(i) / bet + enddo + enddo + + do i=i1,i2 + a_bot = 1. + d4(i)*(d4(i)+1.5) + q(i,km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1,i,km)+a4(1,i,km-1)-a_bot*q(i,km)) & + / ( d4(i)*(d4(i)+0.5) - a_bot*gam(i,km) ) + enddo + + do k=km,1,-1 + do i=i1,i2 + q(i,k) = q(i,k) - gam(i,k)*q(i,k+1) + enddo + enddo + endif + +!Perfectly linear scheme + if ( abs(kord) == 17 ) then + do k=1,km + do i=i1,i2 + a4(2,i,k) = q(i,k ) + a4(3,i,k) = q(i,k+1) + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + enddo + return + endif + + im = i2 - i1 + 1 + + ! Apply *large-scale* constraints to \hat{q} + + !Upper BC for all schemes + do i=i1,i2 + q(i,2) = min( q(i,2), max(a4(1,i,1), a4(1,i,2)) ) + q(i,2) = max( q(i,2), min(a4(1,i,1), a4(1,i,2)) ) + enddo + + do k=2,km + do i=i1,i2 + gam(i,k) = a4(1,i,k) - a4(1,i,k-1) !\delta \bar{q} + enddo + enddo + +! Interior: + do k=3,km-1 + do i=i1,i2 + if ( abs(kord) >= 14 .or. gam(i,k-1)*gam(i,k+1)>0. ) then +! Apply large-scale constraint to ALL fields if not local max/min +! first guess interface values cannot exceeed values +! of adjacent cells + q(i,k) = min( q(i,k), max(a4(1,i,k-1),a4(1,i,k)) ) + q(i,k) = max( q(i,k), min(a4(1,i,k-1),a4(1,i,k)) ) + else + if ( gam(i,k-1) > 0. ) then +! There exists a local max + q(i,k) = max(q(i,k), min(a4(1,i,k-1),a4(1,i,k))) + else +! There exists a local min + q(i,k) = min(q(i,k), max(a4(1,i,k-1),a4(1,i,k))) + if ( iv==0 ) q(i,k) = max(0., q(i,k)) + endif + endif + enddo + enddo + +! Bottom BC for all schemes: + do i=i1,i2 + q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) ) + q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) ) + enddo + + !Set up in-cell reconstruction + !initially continuous (AL(k) = AR(k-1)) + do k=1,km + do i=i1,i2 + a4(2,i,k) = q(i,k ) + a4(3,i,k) = q(i,k+1) + enddo + enddo + + !Flags for different extremum/2dz conditions + ! estimated from first-guess edge values + do k=1,km + if ( k==1 .or. k==km ) then + do i=i1,i2 + extm(i,k) = (a4(2,i,k)-a4(1,i,k)) * (a4(3,i,k)-a4(1,i,k)) > 0. + enddo + else + do i=i1,i2 + extm(i,k) = gam(i,k)*gam(i,k+1) < 0. + enddo + endif + if ( abs(kord) > 9 ) then + do i=i1,i2 + x0 = 2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)) + x1 = abs(a4(2,i,k)-a4(3,i,k)) + a4(4,i,k) = 3.*x0 + ext5(i,k) = abs(x0) > x1 + ext6(i,k) = abs(a4(4,i,k)) > x1 + enddo + endif + enddo + +! Apply subgrid constraints: +! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) +! Top 2 and bottom 2 layers always use monotonic mapping + + select case (iv) + + case (0) + do i=i1,i2 + a4(2,i,1) = max(0., a4(2,i,1)) + enddo + case (-1) + do i=i1,i2 + if ( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. + enddo + case (2) + do i=i1,i2 + a4(2,i,1) = a4(1,i,1) + a4(3,i,1) = a4(1,i,1) + a4(4,i,1) = 0. + enddo + end select !iv + + if ( iv/=2 ) then + do i=i1,i2 + a4(4,i,1) = 3.*(2.*a4(1,i,1) - (a4(2,i,1)+a4(3,i,1))) + enddo + call cs_limiters(im, extm(i1,1), a4(1,i1,1), 1) + endif + +! k=2 + do i=i1,i2 + a4(4,i,2) = 3.*(2.*a4(1,i,2) - (a4(2,i,2)+a4(3,i,2))) + enddo + call cs_limiters(im, extm(i1,2), a4(1,i1,2), 2) + +!------------------------------------- +! Huynh's 2nd constraint for interior: +!------------------------------------- + do k=3,km-2 + select case (abs(kord)) + + case (0:8) + do i=i1,i2 +! Left edges + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) +! Right edges + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + + case (9) + do i=i1,i2 + if ( extm(i,k) .and. extm(i,k-1) ) then +! grid-scale 2-delta-z wave detected + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else if ( extm(i,k) .and. extm(i,k+1) ) then +! grid-scale 2-delta-z wave detected + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else if ( extm(i,k) .and. a4(1,i,k) abs(a4(2,i,k)-a4(3,i,k)) ) then + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + endif + endif + enddo + case(10) !restored AM4 case 10 + do i=i1,i2 + if( extm(i,k) ) then + if( a4(1,i,k) ehance vertical mixing + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else +! True local extremum + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) + endif + else ! not a local extremum + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) +! Check within the smooth region if subgrid profile is non-monotonic + if( abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k)) ) then + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) + endif + endif + enddo + case(11) + do i=i1,i2 + if ( ext5(i,k) .and. (ext5(i,k-1).or.ext5(i,k+1).or.a4(1,i,k)= 14 .or. gam(i,k-1)*gam(i,k+1)>0. ) then +! Apply large-scale constraint to ALL fields if not local max/min +! OR for the strictly monotone schemes + q(i,k) = min( q(i,k), max(a4(1,i,k-1),a4(1,i,k)) ) + q(i,k) = max( q(i,k), min(a4(1,i,k-1),a4(1,i,k)) ) + else + if ( gam(i,k-1) > 0. ) then +! There exists a local max + q(i,k) = max(q(i,k), min(a4(1,i,k-1),a4(1,i,k))) + else +! There exists a local min + q(i,k) = min(q(i,k), max(a4(1,i,k-1),a4(1,i,k))) + if ( iv==0 ) q(i,k) = max(0., q(i,k)) ! positive-definite + endif + endif + enddo + enddo + +! Bottom: + do i=i1,i2 + q(i,km) = min( q(i,km), max(a4(1,i,km-1), a4(1,i,km)) ) + q(i,km) = max( q(i,km), min(a4(1,i,km-1), a4(1,i,km)) ) + enddo + + do k=1,km + do i=i1,i2 + a4(2,i,k) = q(i,k ) + a4(3,i,k) = q(i,k+1) + enddo + enddo + + do k=1,km + if ( k==1 .or. k==km ) then + do i=i1,i2 + extm(i,k) = (a4(2,i,k)-a4(1,i,k)) * (a4(3,i,k)-a4(1,i,k)) > 0. + enddo + else + do i=i1,i2 + extm(i,k) = gam(i,k)*gam(i,k+1) < 0. + enddo + endif + if ( abs(kord) > 9 ) then + do i=i1,i2 + x0 = 2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)) + x1 = abs(a4(2,i,k)-a4(3,i,k)) + a4(4,i,k) = 3.*x0 + ext5(i,k) = abs(x0) > x1 + ext6(i,k) = abs(a4(4,i,k)) > x1 + enddo + endif + enddo + +!--------------------------- +! Apply subgrid constraints: +!--------------------------- +! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) +! Top 2 and bottom 2 layers always use monotonic mapping + + select case (iv) + case (0) + do i=i1,i2 + a4(2,i,1) = max(0., a4(2,i,1)) + enddo + case(-1) + do i=i1,i2 + if ( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. + enddo + case(2) + do i=i1,i2 + a4(2,i,1) = a4(1,i,1) + a4(3,i,1) = a4(1,i,1) + a4(4,i,1) = 0. + enddo + end select !iv + + if ( iv/=2 ) then + do i=i1,i2 + a4(4,i,1) = 3.*(2.*a4(1,i,1) - (a4(2,i,1)+a4(3,i,1))) + enddo + call cs_limiters(im, extm(i1,1), a4(1,i1,1), 1) + endif + +! k=2 + do i=i1,i2 + a4(4,i,2) = 3.*(2.*a4(1,i,2) - (a4(2,i,2)+a4(3,i,2))) + enddo + call cs_limiters(im, extm(i1,2), a4(1,i1,2), 2) + +!------------------------------------- +! Huynh's 2nd constraint for interior: +!------------------------------------- + do k=3,km-2 + select case (abs(kord)) + case (0:8) + do i=i1,i2 +! Left edges + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) +! Right edges + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + + case (9) + do i=i1,i2 + if ( extm(i,k) .and. extm(i,k-1) ) then ! c90_mp122 +! grid-scale 2-delta-z wave detected + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else if ( extm(i,k) .and. extm(i,k+1) ) then ! c90_mp122 +! grid-scale 2-delta-z wave detected + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) +! Check within the smooth region if subgrid profile is non-monotonic + if( abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k)) ) then + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) + endif + endif + enddo + case(10) !restored AM4 case 10 + do i=i1,i2 + if( extm(i,k) ) then + if( extm(i,k-1) .or. extm(i,k+1) ) then +! grid-scale 2-delta-z wave detected + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else +! True local extremum + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) + endif + else ! not a local extremum + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) +! Check within the smooth region if subgrid profile is non-monotonic + if( abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k)) ) then + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + a4(4,i,k) = 6.*a4(1,i,k) - 3.*(a4(2,i,k)+a4(3,i,k)) + endif + endif + enddo + case (11) + do i=i1,i2 + if ( ext5(i,k) .and. (ext5(i,k-1) .or. ext5(i,k+1)) ) then +! Noisy region: + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + a4(4,i,k) = 0. + else + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + endif + enddo + case (12) !post-AM4 case 10 + do i=i1,i2 + if( ext5(i,k) ) then + if( ext5(i,k-1) .or. ext5(i,k+1) ) then + a4(2,i,k) = a4(1,i,k) + a4(3,i,k) = a4(1,i,k) + elseif ( ext6(i,k-1) .or. ext6(i,k+1) ) then + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + endif + elseif( ext6(i,k) ) then + if( ext5(i,k-1) .or. ext5(i,k+1) ) then + pmp_1 = a4(1,i,k) - 2.*gam(i,k+1) + lac_1 = pmp_1 + 1.5*gam(i,k+2) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), pmp_1, lac_1)), & + max(a4(1,i,k), pmp_1, lac_1) ) + pmp_2 = a4(1,i,k) + 2.*gam(i,k) + lac_2 = pmp_2 - 1.5*gam(i,k-1) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), pmp_2, lac_2)), & + max(a4(1,i,k), pmp_2, lac_2) ) + endif + endif + enddo + do i=i1,i2 + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + case (13) !former 14: no subgrid limiter + + do i=i1,i2 + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + + case (14) !strict monotonicity constraint + call cs_limiters(im, extm(i1,k), a4(1,i1,k), 2) + case (15) + call cs_limiters(im, extm(i1,k), a4(1,i1,k), 1) + case default + call mpp_error(FATAL, 'kord not implemented') + end select + +! Additional constraint to ensure positivity + if ( iv==0 .and. abs(kord) <= 13 ) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 0) + + enddo ! k-loop + +!---------------------------------- +! Bottom layer subgrid constraints: +!---------------------------------- + select case (iv) + case (0) + do i=i1,i2 + a4(3,i,km) = max(0., a4(3,i,km)) + enddo + case (-1) + do i=i1,i2 + if ( a4(3,i,km)*a4(1,i,km) <= 0. ) a4(3,i,km) = 0. + enddo + end select + + do k=km-1,km + do i=i1,i2 + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + if(k==(km-1)) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 2) + if(k== km ) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 1) + enddo + + end subroutine cs_profile + + + subroutine cs_limiters(im, extm, a4, iv) + integer, intent(in) :: im + integer, intent(in) :: iv + logical, intent(in) :: extm(im) + real , intent(inout) :: a4(4,im) ! PPM array +! !LOCAL VARIABLES: + real da1, da2, a6da + integer i + + if ( iv==0 ) then +! Positive definite constraint + do i=1,im + if( a4(1,i)<=0.) then + a4(2,i) = a4(1,i) + a4(3,i) = a4(1,i) + a4(4,i) = 0. + else + if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then + if( (a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12) < 0. ) then +! local minimum is negative + if( a4(1,i) a4(2,i) ) then + a4(4,i) = 3.*(a4(2,i)-a4(1,i)) + a4(3,i) = a4(2,i) - a4(4,i) + else + a4(4,i) = 3.*(a4(3,i)-a4(1,i)) + a4(2,i) = a4(3,i) - a4(4,i) + endif + endif + endif + endif + enddo + elseif ( iv==1 ) then + do i=1,im + if( (a4(1,i)-a4(2,i))*(a4(1,i)-a4(3,i))>=0. ) then + a4(2,i) = a4(1,i) + a4(3,i) = a4(1,i) + a4(4,i) = 0. + else + da1 = a4(3,i) - a4(2,i) + da2 = da1**2 + a6da = a4(4,i)*da1 + if(a6da < -da2) then + a4(4,i) = 3.*(a4(2,i)-a4(1,i)) + a4(3,i) = a4(2,i) - a4(4,i) + elseif(a6da > da2) then + a4(4,i) = 3.*(a4(3,i)-a4(1,i)) + a4(2,i) = a4(3,i) - a4(4,i) + endif + endif + enddo + else +! Standard PPM constraint + do i=1,im + if( extm(i) ) then + a4(2,i) = a4(1,i) + a4(3,i) = a4(1,i) + a4(4,i) = 0. + else + da1 = a4(3,i) - a4(2,i) + da2 = da1**2 + a6da = a4(4,i)*da1 + if(a6da < -da2) then + a4(4,i) = 3.*(a4(2,i)-a4(1,i)) + a4(3,i) = a4(2,i) - a4(4,i) + elseif(a6da > da2) then + a4(4,i) = 3.*(a4(3,i)-a4(1,i)) + a4(2,i) = a4(3,i) - a4(4,i) + endif + endif + enddo + endif + end subroutine cs_limiters + + + + subroutine ppm_profile(a4, delp, km, i1, i2, iv, kord) + +! !INPUT PARAMETERS: + integer, intent(in):: iv ! iv =-1: winds + ! iv = 0: positive definite scalars + ! iv = 1: others + ! iv = 2: temp (if remap_t) and w (iv=-2) + integer, intent(in):: i1 ! Starting longitude + integer, intent(in):: i2 ! Finishing longitude + integer, intent(in):: km ! vertical dimension + integer, intent(in):: kord ! Order (or more accurately method no.): + ! + real , intent(in):: delp(i1:i2,km) ! layer pressure thickness + +! !INPUT/OUTPUT PARAMETERS: + real , intent(inout):: a4(4,i1:i2,km) ! Interpolated values + +! DESCRIPTION: +! +! Perform the piecewise parabolic reconstruction +! +! !REVISION HISTORY: +! S.-J. Lin revised at GFDL 2007 +!----------------------------------------------------------------------- +! local arrays: + real dc(i1:i2,km) + real h2(i1:i2,km) + real delq(i1:i2,km) + real df2(i1:i2,km) + real d4(i1:i2,km) + +! local scalars: + integer i, k, km1, lmt, it + real fac + real a1, a2, c1, c2, c3, d1, d2 + real qm, dq, lac, qmp, pmp + + km1 = km - 1 + it = i2 - i1 + 1 + + do k=2,km + do i=i1,i2 + delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) + d4(i,k ) = delp(i,k-1) + delp(i,k) + enddo + enddo + + do k=2,km1 + do i=i1,i2 + c1 = (delp(i,k-1)+0.5*delp(i,k))/d4(i,k+1) + c2 = (delp(i,k+1)+0.5*delp(i,k))/d4(i,k) + df2(i,k) = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & + (d4(i,k)+delp(i,k+1)) + dc(i,k) = sign( min(abs(df2(i,k)), & + max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))-a4(1,i,k), & + a4(1,i,k)-min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1))), df2(i,k) ) + enddo + enddo + +!----------------------------------------------------------- +! 4th order interpolation of the provisional cell edge value +!----------------------------------------------------------- + + do k=3,km1 + do i=i1,i2 + c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k) + a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1)) + a2 = d4(i,k+1) / (d4(i,k) + delp(i,k)) + a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(d4(i,k-1)+d4(i,k+1)) * & + ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & + delp(i,k-1)*a1*dc(i,k ) ) + enddo + enddo + +! if(km>8 .and. kord>4) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4) + +! Area preserving cubic with 2nd deriv. = 0 at the boundaries +! Top + do i=i1,i2 + d1 = delp(i,1) + d2 = delp(i,2) + qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) + dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) + c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) + c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1) + a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) +! Top edge: +!------------------------------------------------------- + a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) +!------------------------------------------------------- +! a4(2,i,1) = (12./7.)*a4(1,i,1)-(13./14.)*a4(1,i,2)+(3./14.)*a4(1,i,3) +!------------------------------------------------------- +! No over- and undershoot condition + a4(2,i,2) = max( a4(2,i,2), min(a4(1,i,1), a4(1,i,2)) ) + a4(2,i,2) = min( a4(2,i,2), max(a4(1,i,1), a4(1,i,2)) ) + dc(i,1) = 0.5*(a4(2,i,2) - a4(1,i,1)) + enddo + +! Enforce monotonicity within the top layer + + if( iv==0 ) then + do i=i1,i2 + a4(2,i,1) = max(0., a4(2,i,1)) + a4(2,i,2) = max(0., a4(2,i,2)) + enddo + elseif( iv==-1 ) then + do i=i1,i2 + if ( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. + enddo + elseif( abs(iv)==2 ) then + do i=i1,i2 + a4(2,i,1) = a4(1,i,1) + a4(3,i,1) = a4(1,i,1) + enddo + endif + +! Bottom +! Area preserving cubic with 2nd deriv. = 0 at the surface + do i=i1,i2 + d1 = delp(i,km) + d2 = delp(i,km1) + qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) + dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) + c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) + c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1) + a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) +! Bottom edge: +!----------------------------------------------------- + a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) +! dc(i,km) = 0.5*(a4(3,i,km) - a4(1,i,km)) +!----------------------------------------------------- +! a4(3,i,km) = (12./7.)*a4(1,i,km)-(13./14.)*a4(1,i,km-1)+(3./14.)*a4(1,i,km-2) +! No over- and under-shoot condition + a4(2,i,km) = max( a4(2,i,km), min(a4(1,i,km), a4(1,i,km1)) ) + a4(2,i,km) = min( a4(2,i,km), max(a4(1,i,km), a4(1,i,km1)) ) + dc(i,km) = 0.5*(a4(1,i,km) - a4(2,i,km)) + enddo + + +! Enforce constraint on the "slope" at the surface + +#ifdef BOT_MONO + do i=i1,i2 + a4(4,i,km) = 0 + if( a4(3,i,km) * a4(1,i,km) <= 0. ) a4(3,i,km) = 0. + d1 = a4(1,i,km) - a4(2,i,km) + d2 = a4(3,i,km) - a4(1,i,km) + if ( d1*d2 < 0. ) then + a4(2,i,km) = a4(1,i,km) + a4(3,i,km) = a4(1,i,km) + else + dq = sign(min(abs(d1),abs(d2),0.5*abs(delq(i,km-1))), d1) + a4(2,i,km) = a4(1,i,km) - dq + a4(3,i,km) = a4(1,i,km) + dq + endif + enddo +#else + if( iv==0 ) then + do i=i1,i2 + a4(2,i,km) = max(0.,a4(2,i,km)) + a4(3,i,km) = max(0.,a4(3,i,km)) + enddo + elseif( iv<0 ) then + do i=i1,i2 + if( a4(1,i,km)*a4(3,i,km) <= 0. ) a4(3,i,km) = 0. + enddo + endif +#endif + + do k=1,km1 + do i=i1,i2 + a4(3,i,k) = a4(2,i,k+1) + enddo + enddo + +!----------------------------------------------------------- +! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) +!----------------------------------------------------------- +! Top 2 and bottom 2 layers always use monotonic mapping + do k=1,2 + do i=i1,i2 + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 0) + enddo + + if(kord >= 7) then +!----------------------- +! Huynh's 2nd constraint +!----------------------- + do k=2,km1 + do i=i1,i2 +! Method#1 +! h2(i,k) = delq(i,k) - delq(i,k-1) +! Method#2 - better + h2(i,k) = 2.*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1)) & + / ( delp(i,k)+0.5*(delp(i,k-1)+delp(i,k+1)) ) & + * delp(i,k)**2 +! Method#3 +!!! h2(i,k) = dc(i,k+1) - dc(i,k-1) + enddo + enddo + + fac = 1.5 ! original quasi-monotone + + do k=3,km-2 + do i=i1,i2 +! Right edges +! qmp = a4(1,i,k) + 2.0*delq(i,k-1) +! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1) +! + pmp = 2.*dc(i,k) + qmp = a4(1,i,k) + pmp + lac = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k) + a4(3,i,k) = min(max(a4(3,i,k), min(a4(1,i,k), qmp, lac)), & + max(a4(1,i,k), qmp, lac) ) +! Left edges +! qmp = a4(1,i,k) - 2.0*delq(i,k) +! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k) +! + qmp = a4(1,i,k) - pmp + lac = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k) + a4(2,i,k) = min(max(a4(2,i,k), min(a4(1,i,k), qmp, lac)), & + max(a4(1,i,k), qmp, lac)) +!------------- +! Recompute A6 +!------------- + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo +! Additional constraint to ensure positivity when kord=7 + if (iv == 0 .and. kord >= 6 ) & + call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 2) + enddo + + else + + lmt = kord - 3 + lmt = max(0, lmt) + if (iv == 0) lmt = min(2, lmt) + + do k=3,km-2 + if( kord /= 4) then + do i=i1,i2 + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + endif + if(kord/=6) call ppm_limiters(dc(i1,k), a4(1,i1,k), it, lmt) + enddo + endif + + do k=km1,km + do i=i1,i2 + a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) + enddo + call ppm_limiters(dc(i1,k), a4(1,i1,k), it, 0) + enddo + + end subroutine ppm_profile + + + subroutine ppm_limiters(dm, a4, itot, lmt) + +! !INPUT PARAMETERS: + real , intent(in):: dm(*) ! the linear slope + integer, intent(in) :: itot ! Total Longitudes + integer, intent(in) :: lmt ! 0: Standard PPM constraint + ! 1: Improved full monotonicity constraint (Lin) + ! 2: Positive definite constraint + ! 3: do nothing (return immediately) +! !INPUT/OUTPUT PARAMETERS: + real , intent(inout) :: a4(4,*) ! PPM array + ! AA <-- a4(1,i) + ! AL <-- a4(2,i) + ! AR <-- a4(3,i) + ! A6 <-- a4(4,i) +! !LOCAL VARIABLES: + real qmp + real da1, da2, a6da + real fmin + integer i + +! Developer: S.-J. Lin + + if ( lmt == 3 ) return + + if(lmt == 0) then +! Standard PPM constraint + do i=1,itot + if(dm(i) == 0.) then + a4(2,i) = a4(1,i) + a4(3,i) = a4(1,i) + a4(4,i) = 0. + else + da1 = a4(3,i) - a4(2,i) + da2 = da1**2 + a6da = a4(4,i)*da1 + if(a6da < -da2) then + a4(4,i) = 3.*(a4(2,i)-a4(1,i)) + a4(3,i) = a4(2,i) - a4(4,i) + elseif(a6da > da2) then + a4(4,i) = 3.*(a4(3,i)-a4(1,i)) + a4(2,i) = a4(3,i) - a4(4,i) + endif + endif + enddo + + elseif (lmt == 1) then + +! Improved full monotonicity constraint (Lin 2004) +! Note: no need to provide first guess of A6 <-- a4(4,i) + do i=1, itot + qmp = 2.*dm(i) + a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) + a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) + a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) + enddo + + elseif (lmt == 2) then + +! Positive definite constraint + do i=1,itot + if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then + fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 + if( fmin < 0. ) then + if(a4(1,i) a4(2,i)) then + a4(4,i) = 3.*(a4(2,i)-a4(1,i)) + a4(3,i) = a4(2,i) - a4(4,i) + else + a4(4,i) = 3.*(a4(3,i)-a4(1,i)) + a4(2,i) = a4(3,i) - a4(4,i) + endif + endif + endif + enddo + + endif + + end subroutine ppm_limiters + + + + subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4) + integer, intent(in) :: km, i1, i2 + real , intent(in) :: dp(i1:i2,km) ! grid size + real , intent(in) :: dq(i1:i2,km) ! backward diff of q + real , intent(in) :: d4(i1:i2,km) ! backward sum: dp(k)+ dp(k-1) + real , intent(in) :: df2(i1:i2,km) ! first guess mismatch + real , intent(in) :: dm(i1:i2,km) ! monotonic mismatch +! !INPUT/OUTPUT PARAMETERS: + real , intent(inout) :: a4(4,i1:i2,km) ! first guess/steepened +! !LOCAL VARIABLES: + integer i, k + real alfa(i1:i2,km) + real f(i1:i2,km) + real rat(i1:i2,km) + real dg2 + +! Compute ratio of dq/dp + do k=2,km + do i=i1,i2 + rat(i,k) = dq(i,k-1) / d4(i,k) + enddo + enddo + +! Compute F + do k=2,km-1 + do i=i1,i2 + f(i,k) = (rat(i,k+1) - rat(i,k)) & + / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) ) + enddo + enddo + + do k=3,km-2 + do i=i1,i2 + if(f(i,k+1)*f(i,k-1)<0. .and. df2(i,k)/=0.) then + dg2 = (f(i,k+1)-f(i,k-1))*((dp(i,k+1)-dp(i,k-1))**2 & + + d4(i,k)*d4(i,k+1) ) + alfa(i,k) = max(0., min(0.5, -0.1875*dg2/df2(i,k))) + else + alfa(i,k) = 0. + endif + enddo + enddo + + do k=4,km-2 + do i=i1,i2 + a4(2,i,k) = (1.-alfa(i,k-1)-alfa(i,k)) * a4(2,i,k) + & + alfa(i,k-1)*(a4(1,i,k)-dm(i,k)) + & + alfa(i,k)*(a4(1,i,k-1)+dm(i,k-1)) + enddo + enddo + + end subroutine steepz + + !This routine is indended to remap between different # + ! of vertical levels + subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord) + +! IV = 0: constituents +! IV = 1: potential temp +! IV =-1: winds +! IV =-2: vertical velocity + +! Mass flux preserving mapping: q1(im,km) -> q2(im,kn) + +! pe1: pressure at layer edges (from model top to bottom surface) +! in the original vertical coordinate +! pe2: pressure at layer edges (from model top to bottom surface) +! in the new vertical coordinate + + integer, intent(in):: i1, i2, km, kn, kord, iv + real, intent(in ):: pe1(i1:i2,km+1), pe2(i1:i2,kn+1) + real, intent(in ):: q1(i1:i2,km) ! input field + real, intent(out):: q2(i1:i2,kn) ! output field + +! local + real qs(i1:i2) + real dp1(i1:i2,km) + real a4(4,i1:i2,km) + integer i, k, l + integer k0, k1 + real pl, pr, tt, delp, qsum, dpsum, esl + + do k=1,km + do i=i1,i2 + dp1(i,k) = pe1(i,k+1) - pe1(i,k) + a4(1,i,k) = q1(i,k) + enddo + enddo + + if ( kord >7 ) then + call cs_profile( qs, a4, dp1, km, i1, i2, iv, kord ) + else + call ppm_profile( a4, dp1, km, i1, i2, iv, kord ) + endif + + do 5555 i=i1,i2 + k0 = 1 + do 555 k=1,kn + + if(pe2(i,k) .le. pe1(i,1)) then +! above old ptop + q2(i,k) = q1(i,1) + elseif(pe2(i,k) .ge. pe1(i,km+1)) then +! Entire grid below old ps + q2(i,k) = q1(i,km) + else + + do 45 L=k0,km +! locate the top edge at pe2(i,k) + if( pe2(i,k) .ge. pe1(i,L) .and. & + pe2(i,k) .le. pe1(i,L+1) ) then + k0 = L + PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) + if(pe2(i,k+1) .le. pe1(i,L+1)) then + +! entire new grid is within the original grid + PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) + TT = r3*(PR*(PR+PL)+PL**2) + q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) & + - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT + goto 555 + else +! Fractional area... + delp = pe1(i,L+1) - pe2(i,k) + TT = r3*(1.+PL*(1.+PL)) + qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ & + a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) + dpsum = delp + k1 = L + 1 + goto 111 + endif + endif +45 continue + +111 continue + do 55 L=k1,km + if( pe2(i,k+1) .gt. pe1(i,L+1) ) then + +! Whole layer.. + + qsum = qsum + dp1(i,L)*q1(i,L) + dpsum = dpsum + dp1(i,L) + else + delp = pe2(i,k+1)-pe1(i,L) + esl = delp / dp1(i,L) + qsum = qsum + delp * (a4(2,i,L)+0.5*esl* & + (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) + dpsum = dpsum + delp + k0 = L + goto 123 + endif +55 continue + delp = pe2(i,k+1) - pe1(i,km+1) + if(delp > 0.) then +! Extended below old ps + qsum = qsum + delp * q1(i,km) + dpsum = dpsum + delp + endif +123 q2(i,k) = qsum / dpsum + endif +555 continue +5555 continue + + end subroutine mappm + +!----------------------------------------------------------------------- +!BOP +! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping +! +! !INTERFACE: + subroutine map1_cubic( km, pe1, q1, & + kn, pe2, q2, i1, i2, & + j, ibeg, iend, jbeg, jend, akap, T_VAR, conserv) + implicit none + +! !INPUT PARAMETERS: + integer, intent(in) :: i1 ! Starting longitude + integer, intent(in) :: i2 ! Finishing longitude + real, intent(in) :: akap + integer, intent(in) :: T_VAR ! Thermodynamic variable to remap + ! 1:TE 2:T 3:PT + logical, intent(in) :: conserv + integer, intent(in) :: j ! Current latitude + integer, intent(in) :: ibeg, iend, jbeg, jend + integer, intent(in) :: km ! Original vertical dimension + integer, intent(in) :: kn ! Target vertical dimension + + real, intent(in) :: pe1(i1:i2,km+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the original vertical coordinate + real, intent(in) :: pe2(i1:i2,kn+1) ! pressure at layer edges + ! (from model top to bottom surface) + ! in the new vertical coordinate + + real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input +! !INPUT/OUTPUT PARAMETERS: + real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output + +! !DESCRIPTION: +! +! Perform Cubic Interpolation a given latitude +! pe1: pressure at layer edges (from model top to bottom surface) +! in the original vertical coordinate +! pe2: pressure at layer edges (from model top to bottom surface) +! in the new vertical coordinate +! +! !REVISION HISTORY: +! 2005.11.14 Takacs Initial Code +! 2016.07.20 Putman Modified to make genaric for any thermodynamic variable +! +!EOP +!----------------------------------------------------------------------- +!BOC +! +! !LOCAL VARIABLES: + real qx(i1:i2,km) + real logpl1(i1:i2,km) + real logpl2(i1:i2,kn) + real dlogp1(i1:i2,km) + real vsum1(i1:i2) + real vsum2(i1:i2) + real am2,am1,ap0,ap1,P,PLP1,PLP0,PLM1,PLM2,DLP0,DLM1,DLM2 + + integer i, k, LM2,LM1,LP0,LP1 + +! Initialization +! -------------- + + select case (T_VAR) + case(1) + ! Total Energy Remapping in Log(P) + do k=1,km + qx(:,k) = q1(i1:i2,j,k) + logpl1(:,k) = log( 0.5*(pe1(:,k)+pe1(:,k+1)) ) + enddo + do k=1,kn + logpl2(:,k) = log( 0.5*(pe2(:,k)+pe2(:,k+1)) ) + enddo + + do k=1,km-1 + dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) + enddo + + case(2) + ! Temperature Remapping in Log(P) + do k=1,km + qx(:,k) = q1(i1:i2,j,k) + logpl1(:,k) = log( 0.5*(pe1(:,k)+pe1(:,k+1)) ) + enddo + do k=1,kn + logpl2(:,k) = log( 0.5*(pe2(:,k)+pe2(:,k+1)) ) + enddo + + do k=1,km-1 + dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) + enddo + + case(3) + ! Potential Temperature Remapping in P^KAPPA + do k=1,km + qx(:,k) = q1(i1:i2,j,k) + logpl1(:,k) = exp( akap*log( 0.5*(pe1(:,k)+pe1(:,k+1))) ) + enddo + do k=1,kn + logpl2(:,k) = exp( akap*log( 0.5*(pe2(:,k)+pe2(:,k+1))) ) + enddo + + do k=1,km-1 + dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) + enddo + + end select + + if (conserv) then +! Compute vertical integral of Input TE +! ------------------------------------- + vsum1(:) = 0.0 + do i=i1,i2 + do k=1,km + vsum1(i) = vsum1(i) + qx(i,k)*( pe1(i,k+1)-pe1(i,k) ) + enddo + vsum1(i) = vsum1(i) / ( pe1(i,km+1)-pe1(i,1) ) + enddo + + endif + +! Interpolate TE onto target Pressures +! ------------------------------------ + do i=i1,i2 + do k=1,kn + LM1 = 1 + LP0 = 1 + do while( LP0.le.km ) + if (logpl1(i,LP0).lt.logpl2(i,k)) then + LP0 = LP0+1 + else + exit + endif + enddo + LM1 = max(LP0-1,1) + LP0 = min(LP0, km) + +! Extrapolate Linearly in LogP above first model level +! ---------------------------------------------------- + if( LM1.eq.1 .and. LP0.eq.1 ) then + q2(i,j,k) = qx(i,1) + ( qx(i,2)-qx(i,1) )*( logpl2(i,k)-logpl1(i,1) ) & + /( logpl1(i,2)-logpl1(i,1) ) + +! Extrapolate Linearly in LogP below last model level +! --------------------------------------------------- + else if( LM1.eq.km .and. LP0.eq.km ) then + q2(i,j,k) = qx(i,km) + ( qx(i,km)-qx(i,km-1) )*( logpl2(i,k )-logpl1(i,km ) ) & + /( logpl1(i,km)-logpl1(i,km-1) ) + +! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km +! ----------------------------------------------------------------- + else if( LM1.eq.1 .or. LP0.eq.km ) then + q2(i,j,k) = qx(i,LP0) + ( qx(i,LM1)-qx(i,LP0) )*( logpl2(i,k )-logpl1(i,LP0) ) & + /( logpl1(i,LM1)-logpl1(i,LP0) ) +! Interpolate Cubicly in LogP between other model levels +! ------------------------------------------------------ + else + LP1 = LP0+1 + LM2 = LM1-1 + P = logpl2(i,k) + PLP1 = logpl1(i,LP1) + PLP0 = logpl1(i,LP0) + PLM1 = logpl1(i,LM1) + PLM2 = logpl1(i,LM2) + DLP0 = dlogp1(i,LP0) + DLM1 = dlogp1(i,LM1) + DLM2 = dlogp1(i,LM2) + + ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) + ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) + am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) + am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) + + q2(i,j,k) = ap1*qx(i,LP1) + ap0*qx(i,LP0) + am1*qx(i,LM1) + am2*qx(i,LM2) + + endif + + enddo + enddo + if (conserv) then + +! Compute vertical integral of Output TE +! -------------------------------------- + vsum2(:) = 0.0 + do i=i1,i2 + do k=1,kn + vsum2(i) = vsum2(i) + q2(i,j,k)*( pe2(i,k+1)-pe2(i,k) ) + enddo + vsum2(i) = vsum2(i) / ( pe2(i,kn+1)-pe2(i,1) ) + enddo + +! Adjust Final TE to conserve +! --------------------------- + do i=i1,i2 + do k=1,kn + q2(i,j,k) = q2(i,j,k) + vsum1(i)-vsum2(i) +! q2(i,j,k) = q2(i,j,k) * vsum1(i)/vsum2(i) + enddo + enddo + + endif + + return +!EOC + end subroutine map1_cubic + + +end module fv_operators_mod diff --git a/model/fv_regional_bc.F90 b/model/fv_regional_bc.F90 index 43ffc92a5..2cd4d2d31 100644 --- a/model/fv_regional_bc.F90 +++ b/model/fv_regional_bc.F90 @@ -65,7 +65,7 @@ module fv_regional_mod use fv_grid_utils_mod, only: g_sum,mid_pt_sphere,get_unit_vect2 & ,get_latlon_vector,inner_prod & ,cell_center2 - use fv_mapz_mod, only: mappm, moist_cp, moist_cv + use fv_operators_mod, only: mappm use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max use fv_fill_mod, only: fillz use fv_eta_mod, only: get_eta_level @@ -176,15 +176,9 @@ module fv_regional_mod type fv_regional_BC_variables real,dimension(:,:,:),allocatable :: delp_BC, divgd_BC, u_BC, v_BC, uc_BC, vc_BC real,dimension(:,:,:,:),allocatable :: q_BC -#ifndef SW_DYNAMICS real,dimension(:,:,:),allocatable :: pt_BC, w_BC, delz_BC -#ifdef USE_COND real,dimension(:,:,:),allocatable :: q_con_BC -#ifdef MOIST_CAPPA real,dimension(:,:,:),allocatable :: cappa_BC -#endif -#endif -#endif end type fv_regional_BC_variables type fv_domain_sides @@ -491,6 +485,8 @@ subroutine setup_regional_BC(Atm & ,klev_out & ,ntracers & ,BC_t1%north & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa & ,delz_auxiliary%north ) ! call allocate_regional_BC_arrays('north' & @@ -510,7 +506,9 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_north_uvw & ,klev_out & ,ntracers & - ,BC_t0%north ) + ,BC_t0%north & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa ) ! bc_north_t0=>BC_t0%north bc_north_t1=>BC_t1%north @@ -536,6 +534,8 @@ subroutine setup_regional_BC(Atm & ,klev_out & ,ntracers & ,BC_t1%south & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa & ,delz_auxiliary%south ) ! call allocate_regional_BC_arrays('south' & @@ -555,7 +555,9 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_south_uvw & ,klev_out & ,ntracers & - ,BC_t0%south ) + ,BC_t0%south & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa ) ! bc_south_t0=>BC_t0%south bc_south_t1=>BC_t1%south @@ -581,6 +583,8 @@ subroutine setup_regional_BC(Atm & ,klev_out & ,ntracers & ,BC_t1%east & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa & ,delz_auxiliary%east ) ! call allocate_regional_BC_arrays('east ' & @@ -600,7 +604,9 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_east_uvw & ,klev_out & ,ntracers & - ,BC_t0%east ) + ,BC_t0%east & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa ) ! bc_east_t0=>BC_t0%east bc_east_t1=>BC_t1%east @@ -626,6 +632,8 @@ subroutine setup_regional_BC(Atm & ,klev_out & ,ntracers & ,BC_t1%west & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa & ,delz_auxiliary%west ) ! call allocate_regional_BC_arrays('west ' & @@ -645,7 +653,9 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_west_uvw & ,klev_out & ,ntracers & - ,BC_t0%west ) + ,BC_t0%west & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa) ! bc_west_t0=>BC_t0%west bc_west_t1=>BC_t1%west @@ -1296,7 +1306,9 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & call regional_bc_t1_to_t0(BC_t1, BC_t0 & ! ,Atm%npz & !<-- Move BC t1 data to t0. ,ntracers & - ,Atm%regional_bc_bounds ) ! + ,Atm%regional_bc_bounds & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa) ! bc_hour=bc_hour+bc_update_interval ! @@ -1535,7 +1547,9 @@ subroutine read_new_bc_data(Atm, Time, Time_step_atmos, p_split & call regional_bc_t1_to_t0(BC_t1, BC_t0 & ,Atm%npz & ,ntracers & - ,Atm%regional_bc_bounds ) + ,Atm%regional_bc_bounds & + ,Atm%thermostruct%use_cond & + ,Atm%thermostruct%moist_kappa ) ! !----------------------------------------------------------------------- !*** Fill time level t1 from the BC file containing data from @@ -2434,24 +2448,21 @@ subroutine regional_bc_data(Atm,bc_hour & !*** Fill the total condensate in the regional boundary array. !----------------------------------------------------------------------- ! -#ifdef USE_COND - call fill_q_con_BC -#endif + if (Atm%thermostruct%use_cond) call fill_q_con_BC ! !----------------------------------------------------------------------- !*** Fill moist kappa in the regional domain boundary array. !----------------------------------------------------------------------- ! -#ifdef MOIST_CAPPA - call fill_cappa_BC -#endif + if (Atm%thermostruct%moist_kappa) call fill_cappa_BC ! !----------------------------------------------------------------------- !*** Convert the boundary region sensible temperature array to !*** FV3's modified virtual potential temperature. !----------------------------------------------------------------------- ! - call convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) + call convert_to_virt_pot_temp(isd,ied,jsd,jed,npz,& + Atm%thermostruct%use_cond, Atm%thermostruct%moist_kappa) ! !----------------------------------------------------------------------- !*** If nudging of the specific humidity has been selected then @@ -2849,7 +2860,6 @@ end subroutine fill_divgd_BC !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! -#ifdef USE_COND subroutine fill_q_con_BC ! !----------------------------------------------------------------------- @@ -2937,13 +2947,11 @@ subroutine fill_q_con_BC !----------------------------------------------------------------------- ! end subroutine fill_q_con_BC -#endif ! !----------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! -#ifdef MOIST_CAPPA subroutine fill_cappa_BC ! !----------------------------------------------------------------------- @@ -3076,7 +3084,6 @@ subroutine compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) !----------------------------------------------------------------------- ! end subroutine compute_cappa -#endif ! !----------------------------------------------------------------------- ! @@ -3393,7 +3400,8 @@ subroutine allocate_regional_BC_arrays(side & ,klev & ,ntracers & ,BC_side & - ,delz_side ) + ,use_cond,moist_kappa & + ,delz_side) ! !----------------------------------------------------------------------- implicit none @@ -3412,6 +3420,7 @@ subroutine allocate_regional_BC_arrays(side & character(len=5),intent(in) :: side !<-- Which side are we allocating? ! logical,intent(in) :: north_bc,south_bc,east_bc,west_bc !<-- Which sides is this task on? + logical,intent(in) :: use_cond, moist_kappa ! type(fv_regional_BC_variables),intent(out) :: BC_side ! @@ -3444,12 +3453,12 @@ subroutine allocate_regional_BC_arrays(side & allocate(delz_side (is_0:ie_0,js_0:je_0,klev)) ; delz_side=real_snan endif endif -#ifdef USE_COND - allocate(BC_side%q_con_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%q_con_BC=real_snan -#ifdef MOIST_CAPPA - allocate(BC_side%cappa_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%cappa_BC=real_snan -#endif -#endif + if (use_cond) then + allocate(BC_side%q_con_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%q_con_BC=real_snan + if (moist_kappa) then + allocate(BC_side%cappa_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%cappa_BC=real_snan + endif + endif #endif ! !-------------------- @@ -4040,16 +4049,13 @@ end subroutine remap_dwinds_regional_bc !--------------------------------------------------------------------- subroutine set_regional_BCs(delp,w,pt & -#ifdef USE_COND ,q_con & -#endif -#ifdef MOIST_CAPPA ,cappa & -#endif ,q & ,u,v,uc,vc & ,bd, nlayers & - ,fcst_time ) + ,fcst_time & + ,use_cond,moist_kappa) ! !--------------------------------------------------------------------- !*** Select the boundary variables' boundary data at the two @@ -4071,6 +4077,7 @@ subroutine set_regional_BCs(delp,w,pt & ! type(fv_grid_bounds_type),intent(in) :: bd !<-- Task subdomain indices ! + logical, intent(IN) :: use_cond, moist_kappa !---------------------- !*** Output variables !---------------------- @@ -4080,18 +4087,12 @@ subroutine set_regional_BCs(delp,w,pt & ,pt ! real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: w -#ifdef USE_COND real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: q_con -#endif ! real,dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz,ntracers),intent(out) :: q ! -#ifdef MOIST_CAPPA - real,dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz),intent(out) :: cappa -!#else -! real,dimension(isd:isd,jsd:jsd,1),intent(out) :: cappa -#endif + real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: cappa ! real,dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz),intent(out) :: u,vc ! @@ -4131,7 +4132,7 @@ subroutine set_regional_BCs(delp,w,pt & ,bd%isd & ,bd%ied+1 & ,bd%jsd & - ,bd%js-1) + ,bd%js-1, use_cond, moist_kappa) endif ! if(south_bc)then @@ -4148,7 +4149,7 @@ subroutine set_regional_BCs(delp,w,pt & ,bd%isd & ,bd%ied+1 & ,bd%je+1 & - ,bd%jed ) + ,bd%jed, use_cond, moist_kappa ) endif ! if(east_bc)then @@ -4165,7 +4166,7 @@ subroutine set_regional_BCs(delp,w,pt & ,bd%isd & ,bd%is-1 & ,bd%js & - ,bd%je ) + ,bd%je, use_cond, moist_kappa ) endif ! if(west_bc)then @@ -4182,7 +4183,7 @@ subroutine set_regional_BCs(delp,w,pt & ,bd%ie+2 & ,bd%ied+1 & ,bd%js & - ,bd%je ) + ,bd%je, use_cond, moist_kappa ) endif ! !--------------------------------------------------------------------- @@ -4195,7 +4196,8 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & ,side & ,i1,i2,j1,j2 & ,i1_uvs,i2_uvs,j1_uvs,j2_uvs & - ,i1_uvw,i2_uvw,j1_uvw,j2_uvw ) + ,i1_uvw,i2_uvw,j1_uvw,j2_uvw & + ,use_cond,moist_kappa) ! !--------------------------------------------------------------------- !*** Apply boundary values to the prognostic arrays at the @@ -4216,6 +4218,7 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & integer,intent(in) :: i1,i2,j1,j2 & ,i1_uvs,i2_uvs,j1_uvs,j2_uvs & ,i1_uvw,i2_uvw,j1_uvw,j2_uvw + logical, intent(in) :: use_cond, moist_kappa ! !--------------------- !*** Local arguments @@ -4265,7 +4268,7 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & +(side_t1%delp_BC(i,j,k)-side_t0%delp_BC(i,j,k)) & *fraction_interval #ifndef SW_DYNAMICS - pt(i,j,k)=side_t0%pt_BC(i,j,k) & + pt(i,j,k)=side_t0%pt_BC(i,j,k) & +(side_t1%pt_BC(i,j,k)-side_t0%pt_BC(i,j,k)) & *fraction_interval ! delz(i,j,k)=side_t0%delz_BC(i,j,k) & @@ -4274,17 +4277,17 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & delz_ptr(i,j,k)=side_t0%delz_BC(i,j,k) & +(side_t1%delz_BC(i,j,k)-side_t0%delz_BC(i,j,k)) & *fraction_interval -#ifdef MOIST_CAPPA - cappa(i,j,k)=side_t0%cappa_BC(i,j,k) & + if (moist_kappa) then + cappa(i,j,k)=side_t0%cappa_BC(i,j,k) & +(side_t1%cappa_BC(i,j,k)-side_t0%cappa_BC(i,j,k)) & *fraction_interval -#endif -#ifdef USE_COND - q_con(i,j,k)=side_t0%q_con_BC(i,j,k) & + endif + if (use_cond) then + q_con(i,j,k)=side_t0%q_con_BC(i,j,k) & +(side_t1%q_con_BC(i,j,k)-side_t0%q_con_BC(i,j,k)) & *fraction_interval -#endif - w(i,j,k)=side_t0%w_BC(i,j,k) & + endif + w(i,j,k)=side_t0%w_BC(i,j,k) & +(side_t1%w_BC(i,j,k)-side_t0%w_BC(i,j,k)) & *fraction_interval #endif @@ -4724,16 +4727,12 @@ subroutine retrieve_bc_variable_data(bc_vbl_name & case ('divgd') bc_t0=>bc_side_t0%divgd_BC bc_t1=>bc_side_t1%divgd_BC -#ifdef MOIST_CAPPA case ('cappa') bc_t0=>bc_side_t0%cappa_BC bc_t1=>bc_side_t1%cappa_BC -#endif -#ifdef USE_COND case ('q_con') bc_t0=>bc_side_t0%q_con_BC bc_t1=>bc_side_t1%q_con_BC -#endif case ('q') if(iq<1)then call mpp_error(FATAL,' iq<1 is not a valid index for q_BC array in retrieve_bc_variable_data') @@ -4977,7 +4976,8 @@ end subroutine bc_time_interpolation !--------------------------------------------------------------------- ! subroutine regional_bc_t1_to_t0(BC_t1,BC_t0 & - ,nlev,ntracers,bnds ) + ,nlev,ntracers,bnds & + ,use_cond,moist_kappa) ! !--------------------------------------------------------------------- !*** BC data has been read into the time level t1 object. Now @@ -5000,6 +5000,7 @@ subroutine regional_bc_t1_to_t0(BC_t1,BC_t0 & ! type(fv_domain_sides),target,intent(inout) :: BC_t0 ! + logical, intent(in) :: use_cond, moist_kappa !--------------------- !*** Local variables !--------------------- @@ -5133,24 +5134,38 @@ subroutine regional_bc_t1_to_t0(BC_t1,BC_t0 & enddo enddo ! +#ifndef SW_DYNAMICS do k=1,nlev do j=js_c,je_c do i=is_c,ie_c -#ifndef SW_DYNAMICS bc_side_t0%w_BC(i,j,k) =bc_side_t1%w_BC(i,j,k) bc_side_t0%pt_BC(i,j,k) =bc_side_t1%pt_BC(i,j,k) bc_side_t0%delz_BC(i,j,k) =bc_side_t1%delz_BC(i,j,k) -#ifdef USE_COND - bc_side_t0%q_con_BC(i,j,k)=bc_side_t1%q_con_BC(i,j,k) -#ifdef MOIST_CAPPA - bc_side_t0%cappa_BC(i,j,k)=bc_side_t1%cappa_BC(i,j,k) -#endif -#endif -#endif enddo enddo enddo +#endif +! + if (use_cond) then + do k=1,nlev + do j=js_c,je_c + do i=is_c,ie_c + bc_side_t0%q_con_BC(i,j,k)=bc_side_t1%q_con_BC(i,j,k) + enddo + enddo + enddo + if (moist_kappa) then + do k=1,nlev + do j=js_c,je_c + do i=is_c,ie_c + bc_side_t0%cappa_BC(i,j,k)=bc_side_t1%cappa_BC(i,j,k) + enddo + enddo + enddo + endif + endif ! + do k=1,nlev do j=js_s,je_s do i=is_s,ie_s @@ -5185,7 +5200,7 @@ end subroutine regional_bc_t1_to_t0 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- ! - subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) + subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz,use_cond,moist_kappa) ! !----------------------------------------------------------------------- !*** Convert the incoming sensible temperature to virtual potential @@ -5199,6 +5214,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) !------------------------ ! integer,intent(in) :: isd,ied,jsd,jed,npz + logical,intent(in) :: use_cond, moist_kappa ! !--------------------- !*** Local variables @@ -5209,12 +5225,8 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) real :: rdg ! real,dimension(:,:,:),pointer :: delp,delz,pt -#ifdef USE_COND real,dimension(:,:,:),pointer :: q_con -#endif -#ifdef MOIST_CAPPA real,dimension(:,:,:),pointer ::cappa -#endif ! real,dimension(:,:,:,:),pointer :: q ! @@ -5235,16 +5247,12 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) j2=regional_bounds%je_north q =>BC_t1%north%q_BC #ifndef SW_DYNAMICS -#ifdef USE_COND q_con=>BC_t1%north%q_con_BC -#endif delp =>BC_t1%north%delp_BC delz =>BC_t1%north%delz_BC -#ifdef MOIST_CAPPA cappa=>BC_t1%north%cappa_BC -#endif pt =>BC_t1%north%pt_BC - call compute_vpt !<-- Compute the virtual potential temperature. + call compute_vpt(use_cond,moist_kappa) !<-- Compute the virtual potential temperature. #endif endif ! @@ -5255,16 +5263,12 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) j2=regional_bounds%je_south q =>BC_t1%south%q_BC #ifndef SW_DYNAMICS -#ifdef USE_COND q_con=>BC_t1%south%q_con_BC -#endif delp =>BC_t1%south%delp_BC delz =>BC_t1%south%delz_BC -#ifdef MOIST_CAPPA cappa=>BC_t1%south%cappa_BC -#endif pt =>BC_t1%south%pt_BC - call compute_vpt !<-- Compute the virtual potential temperature. + call compute_vpt(use_cond,moist_kappa) !<-- Compute the virtual potential temperature. #endif endif ! @@ -5275,16 +5279,12 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) j2=regional_bounds%je_east q =>BC_t1%east%q_BC #ifndef SW_DYNAMICS -#ifdef USE_COND q_con=>BC_t1%east%q_con_BC -#endif delp =>BC_t1%east%delp_BC delz =>BC_t1%east%delz_BC -#ifdef MOIST_CAPPA cappa=>BC_t1%east%cappa_BC -#endif pt =>BC_t1%east%pt_BC - call compute_vpt !<-- Compute the virtual potential temperature. + call compute_vpt(use_cond,moist_kappa) !<-- Compute the virtual potential temperature. #endif endif ! @@ -5295,16 +5295,12 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) j2=regional_bounds%je_west q =>BC_t1%west%q_BC #ifndef SW_DYNAMICS -#ifdef USE_COND q_con=>BC_t1%west%q_con_BC -#endif delp =>BC_t1%west%delp_BC delz =>BC_t1%west%delz_BC -#ifdef MOIST_CAPPA cappa=>BC_t1%west%cappa_BC -#endif pt =>BC_t1%west%pt_BC - call compute_vpt !<-- Compute the virtual potential temperature. + call compute_vpt(use_cond,moist_kappa) !<-- Compute the virtual potential temperature. #endif endif ! @@ -5314,7 +5310,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) !----------------------------------------------------------------------- ! - subroutine compute_vpt + subroutine compute_vpt(use_cond, moist_kappa) ! !----------------------------------------------------------------------- !*** Compute the virtual potential temperature as done in fv_dynamics. @@ -5324,6 +5320,7 @@ subroutine compute_vpt !*** Local variables !--------------------- ! + logical, intent(in) :: use_cond, moist_kappa integer :: i,j,k ! real :: cvm,dp1,pkz @@ -5332,31 +5329,45 @@ subroutine compute_vpt !*********************************************************************** !----------------------------------------------------------------------- ! - do k=1,npz -! - do j=j1,j2 - do i=i1,i2 - dp1 = zvir*q(i,j,k,sphum_index) -#ifdef USE_COND -#ifdef MOIST_CAPPA - cvm=(1.-q(i,j,k,sphum_index)+q_con(i,j,k))*cv_air & - +q(i,j,k,sphum_index)*cv_vap+q(i,j,k,liq_water_index)*c_liq - pkz=exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k) & - *(1.+dp1)*(1.-q_con(i,j,k))/delz(i,j,k))) -#else - pkz=exp(kappa*log(rdg*delp(i,j,k)*pt(i,j,k) & - *(1.+dp1)*(1.-q_con(i,j,k))/delz(i,j,k))) -#endif - pt(i,j,k)=pt(i,j,k)*(1.+dp1)*(1.-q_con(i,j,k))/pkz -#else - pkz=exp(kappa*log(rdg*delp(i,j,k)*pt(i,j,k) & - *(1.+dp1)/delz(i,j,k))) - pt(i,j,k)=pt(i,j,k)*(1.+dp1)/pkz -#endif - enddo - enddo -! - enddo + if (use_cond) then + + if (moist_kappa) then + do k=1,npz + do j=j1,j2 + do i=i1,i2 + dp1 = zvir*q(i,j,k,sphum_index) + cvm=(1.-q(i,j,k,sphum_index)+q_con(i,j,k))*cv_air & + +q(i,j,k,sphum_index)*cv_vap+q(i,j,k,liq_water_index)*c_liq + pkz=exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k) & + *(1.+dp1)*(1.-q_con(i,j,k))/delz(i,j,k))) + pt(i,j,k)=pt(i,j,k)*(1.+dp1)*(1.-q_con(i,j,k))/pkz + enddo + enddo + enddo + else + do k=1,npz + do j=j1,j2 + do i=i1,i2 + dp1 = zvir*q(i,j,k,sphum_index) + pkz=exp(kappa*log(rdg*delp(i,j,k)*pt(i,j,k) & + *(1.+dp1)*(1.-q_con(i,j,k))/delz(i,j,k))) + pt(i,j,k)=pt(i,j,k)*(1.+dp1)*(1.-q_con(i,j,k))/pkz + enddo + enddo + enddo + endif !moist_kappa + else + do k=1,npz + do j=j1,j2 + do i=i1,i2 + dp1 = zvir*q(i,j,k,sphum_index) + pkz=exp(kappa*log(rdg*delp(i,j,k)*pt(i,j,k) & + *(1.+dp1)/delz(i,j,k))) + pt(i,j,k)=pt(i,j,k)*(1.+dp1)/pkz + enddo + enddo + enddo + endif !use_cond ! !----------------------------------------------------------------------- ! diff --git a/model/fv_sg.F90 b/model/fv_sg.F90 index 8b30a66f1..b47ba844b 100644 --- a/model/fv_sg.F90 +++ b/model/fv_sg.F90 @@ -38,7 +38,7 @@ module fv_sg_mod implicit none private -public fv_subgrid_z, neg_adj3 +public fv_sg_SHiELD, fv_sg_AM5, neg_adj3 real, parameter:: esl = 0.621971831 real, parameter:: tice = 273.16 @@ -60,7 +60,11 @@ module fv_sg_mod real, parameter:: t2_min = 165. real, parameter:: t2_max = 315. real, parameter:: t3_max = 325. +#ifdef ENG_CNV_OLD real, parameter:: Lv0 = hlv0 - dc_vap*t_ice ! = 3.147782e6 +#else + real, parameter:: Lv0 = hlv0 - dc_vap*t_ice - rvgas*t_ice ! = 3.147782e6 +#endif real, parameter:: Li0 = hlf0 - dc_ice*t_ice ! = -2.431928e5 real, parameter:: zvir = rvgas/rdgas - 1. ! = 0.607789855 @@ -69,15 +73,15 @@ module fv_sg_mod contains -#ifdef GFS_PHYS - subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & - tau, nwat, delp, pe, peln, pkz, ta, qa, ua, va, & - hydrostatic, w, delz, u_dt, v_dt, t_dt, k_bot ) + subroutine fv_sg_SHiELD( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & + fv_sg_adj, fv_sg_adj_weak, nwat, delp, pe, peln, pkz, ta, qa, ua, va, & + hydrostatic, w, delz, u_dt, v_dt, k_bot_full ) ! Dry convective adjustment-mixing !------------------------------------------- integer, intent(in):: is, ie, js, je, km, nq, nwat integer, intent(in):: isd, ied, jsd, jed - integer, intent(in):: tau ! Relaxation time scale + integer, intent(in):: fv_sg_adj ! Relaxation time scale + integer, intent(in):: fv_sg_adj_weak ! Relaxation time scale real, intent(in):: dt ! model time step real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) real, intent(in):: peln(is :ie, km+1,js :je) @@ -85,7 +89,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & real, intent(in):: delz(is:,js:,1:) ! Delta z at each model level real, intent(in):: pkz(is:ie,js:je,km) logical, intent(in):: hydrostatic - integer, intent(in), optional:: k_bot + integer, intent(in), optional:: k_bot_full ! real, intent(inout):: ua(isd:ied,jsd:jed,km) real, intent(inout):: va(isd:ied,jsd:jed,km) @@ -94,13 +98,13 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & real, intent(inout):: qa(isd:ied,jsd:jed,km,nq) ! Specific humidity & tracers real, intent(inout):: u_dt(isd:ied,jsd:jed,km) real, intent(inout):: v_dt(isd:ied,jsd:jed,km) - real, intent(inout):: t_dt(is:ie,js:je,km) !---------------------------Local variables----------------------------- real, dimension(is:ie,km):: u0, v0, w0, t0, hd, te, gz, tvm, pm, den real q0(is:ie,km,nq), qcon(is:ie,km) + real fra(km) real, dimension(is:ie):: gzh, lcp2, icp2, cvm, cpm, qs real ri_ref, ri, pt1, pt2, ratio, tv, cv, tmp, q_liq, q_sol - real tv1, tv2, g2, h0, mc, fra, rk, rz, rdt, tvd, tv_surf + real tv1, tv2, g2, h0, mc, rk, rz, rdt, tvd, tv_surf real dh, dq, qsw, dqsdt, tcp3, t_max, t_min integer i, j, k, kk, n, m, iq, km1, im, kbot real, parameter:: ustar2 = 1.E-4 @@ -116,9 +120,9 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & rdt = 1./ dt im = ie-is+1 - if ( present(k_bot) ) then - if ( k_bot < 3 ) return - kbot = k_bot + if ( present(k_bot_full) .and. fv_sg_adj_weak <= 0.) then + !if ( k_bot_full < 3 ) return + kbot = k_bot_full else kbot = km endif @@ -128,7 +132,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & t_min = t2_min endif - if ( k_bot < min(km,24) ) then + if ( k_bot_full < min(km,24) ) then t_max = t2_max else t_max = t3_max @@ -154,16 +158,24 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & ! volume and mass is locally conserved). !------------------------------------------------------------------------ m = 3 - fra = dt/real(tau) + do k=1,km + if ( k <= k_bot_full) then + fra(k) = dt/real(fv_sg_adj) + else if (fv_sg_adj_weak > 0.) then + fra(k) = dt/real(fv_sg_adj_weak) + else + fra(k) = 0. + endif + enddo !$OMP parallel do default(none) shared(im,is,ie,js,je,nq,kbot,qa,ta,sphum,ua,va,delp,peln, & !$OMP hydrostatic,pe,delz,g2,w,liq_wat,rainwat,ice_wat, & -!$OMP snowwat,cv_air,m,graupel,pkz,rk,rz,fra, t_max, t_min, & -!$OMP u_dt,rdt,v_dt,xvir,nwat) & +!$OMP snowwat,cv_air,m,graupel,pkz,rk,rz,fra, & +!$OMP t_max,t_min,u_dt,rdt,v_dt,xvir,nwat) & !$OMP private(kk,lcp2,icp2,tcp3,dh,dq,den,qs,qsw,dqsdt,qcon,q0, & !$OMP t0,u0,v0,w0,h0,pm,gzh,tvm,tmp,cpm,cvm,q_liq,q_sol, & !$OMP tv,gz,hd,te,ratio,pt1,pt2,tv1,tv2,ri_ref, ri,mc,km1) - do 1000 j=js,je + do j=js,je do iq=1, nq do k=1,kbot @@ -441,31 +453,29 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo ! n-loop !-------------------- - if ( fra < 1. ) then - do k=1, kbot - do i=is,ie - t0(i,k) = ta(i,j,k) + (t0(i,k) - ta(i,j,k))*fra - u0(i,k) = ua(i,j,k) + (u0(i,k) - ua(i,j,k))*fra - v0(i,k) = va(i,j,k) + (v0(i,k) - va(i,j,k))*fra - enddo + do k=1, kbot + do i=is,ie + t0(i,k) = ta(i,j,k) + (t0(i,k) - ta(i,j,k))*fra(k) + u0(i,k) = ua(i,j,k) + (u0(i,k) - ua(i,j,k))*fra(k) + v0(i,k) = va(i,j,k) + (v0(i,k) - va(i,j,k))*fra(k) enddo + enddo - if ( .not. hydrostatic ) then - do k=1,kbot - do i=is,ie - w0(i,k) = w(i,j,k) + (w0(i,k) - w(i,j,k))*fra - enddo + if ( .not. hydrostatic ) then + do k=1,kbot + do i=is,ie + w0(i,k) = w(i,j,k) + (w0(i,k) - w(i,j,k))*fra(k) enddo - endif + enddo + endif - do iq=1,nq - do k=1,kbot - do i=is,ie - q0(i,k,iq) = qa(i,j,k,iq) + (q0(i,k,iq) - qa(i,j,k,iq))*fra - enddo + do iq=1,nq + do k=1,kbot + do i=is,ie + q0(i,k,iq) = qa(i,j,k,iq) + (q0(i,k,iq) - qa(i,j,k,iq))*fra(k) enddo enddo - endif + enddo do k=1,kbot do i=is,ie @@ -490,14 +500,13 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo endif -1000 continue +enddo - end subroutine fv_subgrid_z + end subroutine fv_sg_SHiELD -#else - subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & - tau, nwat, delp, pe, peln, pkz, ta, qa, ua, va, & - hydrostatic, w, delz, u_dt, v_dt, t_dt, q_dt, k_bot ) + subroutine fv_sg_AM5( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & + tau, nwat, delp, pe, peln, pkz, ta, qa, ua, va, & + hydrostatic, w, delz, u_dt, v_dt, t_dt, q_dt, k_bot ) ! Dry convective adjustment-mixing !------------------------------------------- integer, intent(in):: is, ie, js, je, km, nq, nwat @@ -519,8 +528,8 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & real, intent(inout):: qa(isd:ied,jsd:jed,km,nq) ! Specific humidity & tracers real, intent(inout):: u_dt(isd:ied,jsd:jed,km) real, intent(inout):: v_dt(isd:ied,jsd:jed,km) - real, intent(inout):: t_dt(is:ie,js:je,km) - real, intent(inout):: q_dt(is:ie,js:je,km,nq) + real, intent(inout):: t_dt(is:ie,js:je,km) !not used + real, intent(inout):: q_dt(is:ie,js:je,km,nq) !not used! !---------------------------Local variables----------------------------- real, dimension(is:ie,km):: u0, v0, w0, t0, hd, te, gz, tvm, pm, den real q0(is:ie,km,nq), qcon(is:ie,km) @@ -579,7 +588,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & !$OMP private(kk,lcp2,icp2,tcp3,dh,dq,den,qs,qsw,dqsdt,qcon,q0, & !$OMP t0,u0,v0,w0,h0,pm,gzh,tvm,tmp,cpm,cvm, q_liq,q_sol,& !$OMP tv,gz,hd,te,ratio,pt1,pt2,tv1,tv2,ri_ref, ri,mc,km1) - do 1000 j=js,je + do j=js,je do iq=1, nq do k=1,kbot @@ -951,11 +960,10 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo endif -1000 continue +enddo - end subroutine fv_subgrid_z -#endif + end subroutine fv_sg_AM5 subroutine neg_adj3(is, ie, js, je, ng, kbot, hydrostatic, & peln, delz, pt, dp, qv, ql, qr, qi, qs, qg, qa, check_negative) @@ -995,10 +1003,15 @@ subroutine neg_adj3(is, ie, js, je, ng, kbot, hydrostatic, & if ( hydrostatic ) then d0_vap = cp_vapor - c_liq + lv00 = hlv0 - d0_vap*t_ice else d0_vap = cv_vap - c_liq +#ifdef ENG_CNV_OLD + lv00 = hlv0 - d0_vap*t_ice +#else + lv00 = hlv0 - d0_vap*t_ice - rvgas*t_ice +#endif endif - lv00 = hlv0 - d0_vap*t_ice !$OMP parallel do default(none) shared(is,ie,js,je,kbot,qv,ql,qi,qs,qr,qg,dp,pt, & !$OMP lv00, d0_vap,hydrostatic,peln,delz,cv_air,sat_adj) & diff --git a/model/fv_thermodynamics.F90 b/model/fv_thermodynamics.F90 new file mode 100644 index 000000000..2fc9d7f69 --- /dev/null +++ b/model/fv_thermodynamics.F90 @@ -0,0 +1,442 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +! Linjiong Zhou: Nov 19, 2019 +! Revise the OpenMP code to avoid crash +module fv_thermodynamics_mod + + use constants_mod, only: grav, cp_air, cp_vapor, rvgas, rdgas + use gfdl_mp_mod, only: c_liq, c_ice + use field_manager_mod, only: MODEL_ATMOS + use tracer_manager_mod, only: get_tracer_name + use fv_arrays_mod, only: fv_grid_bounds_type, fv_thermo_type, fv_flags_type + use mpp_mod, only: mpp_error, FATAL, input_nml_file + use fms_mod, only: check_nml_error + + implicit none + real, parameter:: cv_vap = 3.*rvgas ! 1384.5 + real, parameter:: cv_air = cp_air - rdgas ! = rdgas * (7/2-1) = 2.5*rdgas=717.68 + real, parameter:: tice = 273.16 + + public fv_thermo_init, compute_total_energy, moist_cv, moist_cp, compute_q_con + +contains + + + subroutine fv_thermo_init(thermostruct,flagstruct) + + type(fv_thermo_type), intent(INOUT), target :: thermostruct + type(fv_flags_type), intent(INOUT) :: flagstruct + + integer :: f_unit, ios, ierr, dum + logical, pointer :: use_cond, moist_kappa + namelist /fv_thermo_nml/ use_cond, moist_kappa + + use_cond => thermostruct%use_cond + moist_kappa => thermostruct%moist_kappa + + !For hydrostatic dynamics, set default to .false. for both + ! to maintain compatibility with the usual hydrostatic configuration + if (flagstruct%hydrostatic) then + use_cond = .false. + moist_kappa = .false. + endif + + + !read namelist + read (input_nml_file,fv_thermo_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_thermo_nml') + + if (moist_kappa .and. .not. use_cond) then + call mpp_error(FATAL, " moist_kappa = .true. and use_cond = .false. not supported.") + endif + + if (flagstruct%hydrostatic .and. moist_kappa) then + call mpp_error(FATAL, " moist_kappa not yet supported for hydrostatic simulation.") + endif + + if (flagstruct%hydrostatic .and. use_cond) then + call mpp_error(FATAL, " use_cond not yet supported for hydrostatic simulation.") + endif + + thermostruct%is_initialized = .true. + + end subroutine fv_thermo_init + + + + subroutine compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, & + u, v, w, delz, pt, delp, q, qc, q_con, pe, peln, hs, & + rsin2_l, cosa_s_l, & + r_vir, cp, rg, hlv, te_2d, ua, va, teq, & + moist_phys, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, hydrostatic, & + moist_kappa, id_te) +!------------------------------------------------------ +! Compute vertically integrated total energy per column +!------------------------------------------------------ +! !INPUT PARAMETERS: + integer, intent(in):: km, is, ie, js, je, isd, ied, jsd, jed, id_te + integer, intent(in):: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, nwat + real, intent(inout), dimension(isd:ied,jsd:jed,km):: ua, va + real, intent(in), dimension(isd:ied,jsd:jed,km):: pt, delp + real, intent(in), dimension(isd:ied,jsd:jed,km,*):: q + real, intent(in), dimension(isd:ied,jsd:jed,km):: qc, q_con !virtual adjustment zvir*qv + real, intent(inout):: u(isd:ied, jsd:jed+1,km) + real, intent(inout):: v(isd:ied+1,jsd:jed, km) + real, intent(in):: w(isd:,jsd:,1:) ! vertical velocity (m/s) + real, intent(in):: delz(is:,js:,1:) + real, intent(in):: hs(isd:ied,jsd:jed) ! surface geopotential + real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) ! pressure at layer edges + real, intent(in):: peln(is:ie,km+1,js:je) ! log(pe) + real, intent(in):: cp, rg, r_vir, hlv + real, intent(in) :: rsin2_l(isd:ied, jsd:jed) + real, intent(in) :: cosa_s_l(isd:ied, jsd:jed) + logical, intent(in):: moist_phys, hydrostatic, moist_kappa +! Output: + real, intent(out):: te_2d(is:ie,js:je) ! vertically integrated TE + real, intent(out):: teq(is:ie,js:je) ! Moist TE +! Local + real, dimension(is:ie,km):: tv + real phiz(is:ie,km+1) + real cvm(is:ie), qd(is:ie) + integer i, j, k + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,q_con,rg,peln,te_2d, & +!$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, & +!$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum,moist_kappa) & +!$OMP private(phiz, tv, cvm, qd) + do j=js,je + + if ( hydrostatic ) then + + do i=is,ie + phiz(i,km+1) = hs(i,j) + enddo + do k=km,1,-1 + do i=is,ie +#ifdef USE_COND + tv(i,k) = pt(i,j,k)*(1.+qc(i,j,k))*(1-q_con(i,j,k)) +#else + tv(i,k) = pt(i,j,k)*(1.+qc(i,j,k)) +#endif + phiz(i,k) = phiz(i,k+1) + rg*tv(i,k)*(peln(i,k+1,j)-peln(i,k,j)) + enddo + enddo + + do i=is,ie + te_2d(i,j) = pe(i,km+1,j)*phiz(i,km+1) - pe(i,1,j)*phiz(i,1) + enddo + + do k=1,km + do i=is,ie + te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*tv(i,k) + & + 0.25*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & + v(i,j,k)**2+v(i+1,j,k)**2 - & + (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j))) + enddo + enddo + + else +!----------------- +! Non-hydrostatic: +!----------------- + do i=is,ie + phiz(i,km+1) = hs(i,j) + do k=km,1,-1 + phiz(i,k) = phiz(i,k+1) - grav*delz(i,j,k) + enddo + enddo + do i=is,ie + te_2d(i,j) = 0. + enddo + !TODO moist_phys doesn't seem to make a difference --- lmh 13may21 + if ( moist_phys ) then + do k=1,km + if (moist_kappa) then + call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, qd, cvm) + do i=is,ie + te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cvm(i)*pt(i,j,k) + & + 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & + v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) + enddo + else + do i=is,ie + te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + & + 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & + v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) + enddo + endif + enddo + else + do k=1,km + do i=is,ie + te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + & + 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & + v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) + enddo + enddo + endif + endif + enddo + +!------------------------------------- +! Diganostics computation for moist TE +!------------------------------------- + if( id_te>0 ) then +!$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp) + do j=js,je + do i=is,ie + teq(i,j) = te_2d(i,j) + enddo + if ( moist_phys ) then + do k=1,km + do i=is,ie + teq(i,j) = teq(i,j) + hlv*q(i,j,k,sphum)*delp(i,j,k) + enddo + enddo + endif + enddo + endif + + end subroutine compute_total_energy + +#ifdef THERMO_PROTOTYPE + subroutine fv_thermodynamics_init + + !set up heat capacities for each tracer + + do n=1,min(ncnst,nwat) + tracer_name = ... + if ( 'sphum' == trim(tracer_name)) then + dcv(n) = cv_vap - cv_air + dcp(n) = cp_vap - cp_air + else if ( ANY( (/'liq_wat','rainwat'/) == trim(tracer_name)) ) then + dcv(n) = c_liq - cv_air + dcp(n) = c_liq - cp_air + else if ( ANY( (/'ice_wat', 'snowwat', 'graupel', 'hailwat'/) == trim(tracer_name)) ) then + dcv(n) = c_ice - cv_air + dcp(n) = c_ice - cp_air + endif + enddo + + end subroutine fv_thermodynamics_init +#endif + + + subroutine moist_cv(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, q_con, cvm, t1) + integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k + integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel + real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q + real, intent(out), dimension(is:ie):: cvm, q_con + real, intent(in), optional:: t1(is:ie) +! + real, parameter:: t_i0 = 15. + real, dimension(is:ie):: qv, ql, qs + integer:: i + + select case (nwat) + + case(2) + if ( present(t1) ) then ! Special case for GFS physics + do i=is,ie + q_con(i) = max(0., q(i,j,k,liq_wat)) + if ( t1(i) > tice ) then + qs(i) = 0. + elseif ( t1(i) < tice-t_i0 ) then + qs(i) = q_con(i) + else + qs(i) = q_con(i)*(tice-t1(i))/t_i0 + endif + ql(i) = q_con(i) - qs(i) + qv(i) = max(0.,q(i,j,k,sphum)) + cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice + enddo + else + do i=is,ie + qv(i) = max(0.,q(i,j,k,sphum)) + qs(i) = max(0.,q(i,j,k,liq_wat)) + q_con(i) = qs(i) + cvm(i) = (1.-qv(i))*cv_air + qv(i)*cv_vap + enddo + endif + case (3) + do i=is,ie + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + qs(i) = q(i,j,k,ice_wat) + q_con(i) = ql(i) + qs(i) + cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice + enddo + case(4) ! K_warm_rain with fake ice + do i=is,ie + qv(i) = q(i,j,k,sphum) + q_con(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + q_con(i)*c_liq + enddo + case(5) + do i=is,ie + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q_con(i) = ql(i) + qs(i) + cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice + enddo + case(6) + do i=is,ie + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q(i,j,k,graupel) + q_con(i) = ql(i) + qs(i) + cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice + enddo + case default + !call mpp_error (NOTE, 'fv_mapz::moist_cv - using default cv_air') + do i=is,ie + q_con(i) = 0. + cvm(i) = cv_air + enddo + end select + + end subroutine moist_cv + + subroutine moist_cp(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & + ice_wat, snowwat, graupel, q, q_con, cpm, t1) + + integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k + integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel + real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q + real, intent(out), dimension(is:ie):: cpm, q_con + real, intent(in), optional:: t1(is:ie) +! + real, parameter:: t_i0 = 15. + real, dimension(is:ie):: qv, ql, qs + integer:: i + + select case (nwat) + + case(2) + if ( present(t1) ) then ! Special case for GFS physics + do i=is,ie + q_con(i) = max(0., q(i,j,k,liq_wat)) + if ( t1(i) > tice ) then + qs(i) = 0. + elseif ( t1(i) < tice-t_i0 ) then + qs(i) = q_con(i) + else + qs(i) = q_con(i)*(tice-t1(i))/t_i0 + endif + ql(i) = q_con(i) - qs(i) + qv(i) = max(0.,q(i,j,k,sphum)) + cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice + enddo + else + do i=is,ie + qv(i) = max(0.,q(i,j,k,sphum)) + qs(i) = max(0.,q(i,j,k,liq_wat)) + q_con(i) = qs(i) + cpm(i) = (1.-qv(i))*cp_air + qv(i)*cp_vapor + enddo + endif + + case(3) + do i=is,ie + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + qs(i) = q(i,j,k,ice_wat) + q_con(i) = ql(i) + qs(i) + cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice + enddo + case(4) ! K_warm_rain scheme with fake ice + do i=is,ie + qv(i) = q(i,j,k,sphum) + q_con(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + q_con(i)*c_liq + enddo + case(5) + do i=is,ie + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q_con(i) = ql(i) + qs(i) + cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice + enddo + case(6) + do i=is,ie + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q(i,j,k,graupel) + q_con(i) = ql(i) + qs(i) + cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice + enddo + case default + !call mpp_error (NOTE, 'fv_mapz::moist_cp - using default cp_air') + do i=is,ie + q_con(i) = 0. + cpm(i) = cp_air + enddo + end select + + end subroutine moist_cp + + subroutine compute_q_con(bd, npz, nwat, nq, q, q_con) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: npz, nwat, nq + real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq):: q + real, intent(out), dimension(bd%is:bd%ie,bd%js:bd%je,npz):: q_con + + integer:: n, dum + character(len=32) :: tracer_name + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + !Not optimized for OpenMP yet + + q_con = 0. + do n=1,nwat + dum = get_tracer_name(MODEL_ATMOS, n, tracer_name) + select case (trim(tracer_name)) + case('liq_wat','rainwat') + q_con = q_con + q(is:ie,js:je,:,n) + case('ice_wat','snowwat','graupel','hailwat') + q_con = q_con + q(is:ie,js:je,:,n) + end select + enddo + + end subroutine compute_q_con + +! subroutine compute_moist_kappa(!! +! +! end subroutine compute_moist_kappa + + +end module fv_thermodynamics_mod diff --git a/model/fv_tracer2d.F90 b/model/fv_tracer2d.F90 index 4dcaf80f8..c548f3215 100644 --- a/model/fv_tracer2d.F90 +++ b/model/fv_tracer2d.F90 @@ -38,8 +38,6 @@ module fv_tracer2d_mod public :: tracer_2d, tracer_2d_nested, tracer_2d_1L -real, allocatable, dimension(:,:,:) :: nest_fx_west_accum, nest_fx_east_accum, nest_fx_south_accum, nest_fx_north_accum - contains !----------------------------------------------------------------------- @@ -49,7 +47,7 @@ module fv_tracer2d_mod subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & - nq, hord, q_split, dt, id_divg, q_pack, dp1_pack, nord_tr, trdm, lim_fac) + nq, hord, q_split, dt, id_divg_mean, q_pack, dp1_pack, nord_tr, trdm, lim_fac) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npx @@ -58,7 +56,7 @@ subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, n integer, intent(IN) :: nq ! number of tracers to be advected integer, intent(IN) :: hord, nord_tr integer, intent(IN) :: q_split - integer, intent(IN) :: id_divg + integer, intent(IN) :: id_divg_mean real , intent(IN) :: dt, trdm real , intent(IN) :: lim_fac type(group_halo_update_type), intent(inout) :: q_pack, dp1_pack @@ -81,7 +79,7 @@ subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, n real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) real :: cmax(npz) - real :: frac + real :: frac(npz), rdt integer :: nsplt integer :: i,j,k,it,iq @@ -148,7 +146,7 @@ subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, n endif enddo ! k-loop - if (trdm>1.e-4) then + if (trdm>1.e-4) then call timing_on('COMM_TOTAL') call timing_on('COMM_TRACER') call complete_group_halo_update(dp1_pack, domain) @@ -159,35 +157,37 @@ subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, n call mp_reduce_max(cmax,npz) !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx, & -!$OMP cy,yfx,mfx,mfy,cmax) & -!$OMP private(nsplt, frac) +!$OMP cy,yfx,mfx,mfy,cmax,frac) & +!$OMP private(nsplt) do k=1,npz nsplt = int(1. + cmax(k)) if ( nsplt > 1 ) then - frac = 1. / real(nsplt) + frac(k) = 1. / real(nsplt) do j=jsd,jed do i=is,ie+1 - cx(i,j,k) = cx(i,j,k) * frac - xfx(i,j,k) = xfx(i,j,k) * frac + cx(i,j,k) = cx(i,j,k) * frac(k) + xfx(i,j,k) = xfx(i,j,k) * frac(k) enddo enddo do j=js,je do i=is,ie+1 - mfx(i,j,k) = mfx(i,j,k) * frac + mfx(i,j,k) = mfx(i,j,k) * frac(k) enddo enddo do j=js,je+1 do i=isd,ied - cy(i,j,k) = cy(i,j,k) * frac - yfx(i,j,k) = yfx(i,j,k) * frac + cy(i,j,k) = cy(i,j,k) * frac(k) + yfx(i,j,k) = yfx(i,j,k) * frac(k) enddo enddo do j=js,je+1 do i=is,ie - mfy(i,j,k) = mfy(i,j,k) * frac + mfy(i,j,k) = mfy(i,j,k) * frac(k) enddo enddo + else + frac(k) = 1. endif enddo @@ -277,11 +277,25 @@ subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, n enddo ! time-split loop enddo ! k-loop + if ( id_divg_mean > 0 ) then + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,frac,dt) & +!$OMP private(rdt) + do k=1,npz + rdt = 1./(dt*frac(k)) + do j=js,je + do i=is,ie + dp1(i,j,k) = (xfx(i+1,j,k)-xfx(i,j,k) + yfx(i,j+1,k)-yfx(i,j,k))*rarea(i,j)*rdt + enddo + enddo + enddo + endif + end subroutine tracer_2d_1L subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & - nq, hord, q_split, dt, id_divg, q_pack, dp1_pack, nord_tr, trdm, lim_fac) + nq, hord, q_split, dt, id_divg_mean, q_pack, dp1_pack, nord_tr, trdm, lim_fac) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npx @@ -290,7 +304,7 @@ subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, integer, intent(IN) :: nq ! number of tracers to be advected integer, intent(IN) :: hord, nord_tr integer, intent(IN) :: q_split - integer, intent(IN) :: id_divg + integer, intent(IN) :: id_divg_mean real , intent(IN) :: dt, trdm real , intent(IN) :: lim_fac type(group_halo_update_type), intent(inout) :: q_pack, dp1_pack @@ -313,7 +327,7 @@ subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) real :: cmax(npz) real :: c_global - real :: frac, rdt + real :: frac(npz), rdt integer :: ksplt(npz) integer :: nsplt integer :: i,j,k,it,iq @@ -384,7 +398,6 @@ subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, ksplt(k) = 1 enddo - !-------------------------------------------------------------------------------- ! Determine global nsplt: @@ -406,8 +419,7 @@ subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, !-------------------------------------------------------------------------------- if( nsplt /= 1 ) then -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,mfx,cy,yfx,mfy,cmax,nsplt,ksplt) & -!$OMP private( frac ) +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,mfx,cy,yfx,mfy,cmax,nsplt,ksplt,frac) do k=1,npz #ifdef GLOBAL_CFL @@ -415,33 +427,37 @@ subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, #else ksplt(k) = int(1. + cmax(k)) #endif - frac = 1. / real(ksplt(k)) + frac(k) = 1. / real(ksplt(k)) do j=jsd,jed do i=is,ie+1 - cx(i,j,k) = cx(i,j,k) * frac - xfx(i,j,k) = xfx(i,j,k) * frac + cx(i,j,k) = cx(i,j,k) * frac(k) + xfx(i,j,k) = xfx(i,j,k) * frac(k) enddo enddo do j=js,je do i=is,ie+1 - mfx(i,j,k) = mfx(i,j,k) * frac + mfx(i,j,k) = mfx(i,j,k) * frac(k) enddo enddo do j=js,je+1 do i=isd,ied - cy(i,j,k) = cy(i,j,k) * frac - yfx(i,j,k) = yfx(i,j,k) * frac + cy(i,j,k) = cy(i,j,k) * frac(k) + yfx(i,j,k) = yfx(i,j,k) * frac(k) enddo enddo do j=js,je+1 do i=is,ie - mfy(i,j,k) = mfy(i,j,k) * frac + mfy(i,j,k) = mfy(i,j,k) * frac(k) enddo enddo enddo + else + do k=1,npz + frac(k) = 1.0 + enddo endif if (trdm>1.e-4) then @@ -524,12 +540,25 @@ subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, enddo ! nsplt + if ( id_divg_mean > 0 ) then + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,frac,dt) & +!$OMP private(rdt) + do k=1,npz + rdt = 1./(dt*frac(k)) + do j=js,je + do i=is,ie + dp1(i,j,k) = (xfx(i+1,j,k)-xfx(i,j,k) + yfx(i,j+1,k)-yfx(i,j,k))*rarea(i,j)*rdt + enddo + enddo + enddo + endif end subroutine tracer_2d subroutine tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & - nq, hord, q_split, dt, id_divg, q_pack, dp1_pack, nord_tr, trdm, & + nq, hord, q_split, dt, id_divg_mean, q_pack, dp1_pack, nord_tr, trdm, & k_split, neststruct, parent_grid, n_map, lim_fac) type(fv_grid_bounds_type), intent(IN) :: bd @@ -539,7 +568,7 @@ subroutine tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, np integer, intent(IN) :: nq ! number of tracers to be advected integer, intent(IN) :: hord, nord_tr integer, intent(IN) :: q_split, k_split, n_map - integer, intent(IN) :: id_divg + integer, intent(IN) :: id_divg_mean real , intent(IN) :: dt, trdm real , intent(IN) :: lim_fac type(group_halo_update_type), intent(inout) :: q_pack, dp1_pack @@ -786,8 +815,8 @@ subroutine tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, np enddo ! nsplt - if ( id_divg > 0 ) then - rdt = 1./(frac*dt) + if ( id_divg_mean > 0 ) then + rdt = 1./dt !$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,rdt) do k=1,npz diff --git a/model/fv_update_phys.F90 b/model/fv_update_phys.F90 index afb9c0039..cdeba0745 100644 --- a/model/fv_update_phys.F90 +++ b/model/fv_update_phys.F90 @@ -41,7 +41,7 @@ module fv_update_phys_mod use fv_eta_mod, only: get_eta_level use fv_timing_mod, only: timing_on, timing_off use fv_diagnostics_mod, only: prt_maxmin, range_check, Mw_air!_0d - use fv_mapz_mod, only: moist_cv, moist_cp + use fv_thermodynamics_mod, only: moist_cv, moist_cp #if defined (ATMOS_NUDGE) use atmos_nudge_mod, only: get_atmos_nudge, do_ps #elif defined (CLIMATE_NUDGE) @@ -505,16 +505,17 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, if ( nudge ) then ! Initialize nudged diagnostics -#if defined (ATMOS_NUDGE) -!-------------------------------------------- -! All fields will be updated; tendencies added -!-------------------------------------------- - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = pt(is:ie,js:je,:) if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = ps(is:ie,js:je) if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = delp(is:ie,js:je,:) if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = ua(is:ie,js:je,:) if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = va(is:ie,js:je,:) + if (allocated(nudge_diag%nudge_qv_dt)) nudge_diag%nudge_qv_dt = q(is:ie,js:je,:,sphum) + +#if defined (ATMOS_NUDGE) +!-------------------------------------------- +! All fields will be updated; tendencies added +!-------------------------------------------- call get_atmos_nudge ( Time, dt, is, ie, js, je, & npz, ng, ps(is:ie,js:je), ua(is:ie, js:je,:), & @@ -538,23 +539,11 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, enddo endif - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = (pt(is:ie,js:je,:) - nudge_diag%nudge_t_dt) / dt - if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = (ps(is:ie,js:je) - nudge_diag%nudge_ps_dt) / dt - if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = (delp(is:ie,js:je,:) - nudge_diag%nudge_delp_dt) / dt - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = (ua(is:ie,js:je,:) - nudge_diag%nudge_u_dt) / dt - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = (va(is:ie,js:je,:) - nudge_diag%nudge_v_dt) / dt - #elif defined (CLIMATE_NUDGE) !-------------------------------------------- ! All fields will be updated; tendencies added !-------------------------------------------- - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = pt(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = ps(is:ie,js:je) - if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = delp(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = ua(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = va(is:ie,js:je,:) - call fv_climate_nudge ( Time, dt, is, ie, js, je, npz, pfull, & lona(is:ie,js:je), lata(is:ie,js:je), phis(is:ie,js:je), & ak, bk, & @@ -578,21 +567,10 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, enddo enddo endif - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = (pt(is:ie,js:je,:) - nudge_diag%nudge_t_dt) / dt - if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = (ps(is:ie,js:je) - nudge_diag%nudge_ps_dt) / dt - if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = (delp(is:ie,js:je,:) - nudge_diag%nudge_delp_dt) / dt - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = (ua(is:ie,js:je,:) - nudge_diag%nudge_u_dt) / dt - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = (va(is:ie,js:je,:) - nudge_diag%nudge_v_dt) / dt #elif defined (ADA_NUDGE) ! All fields will be updated except winds; wind tendencies added - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = pt(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = ps(is:ie,js:je) - if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = delp(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = u_dt(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = v_dt(is:ie,js:je,:) - !$omp parallel do default(shared) do j=js,je do k=2,npz+1 @@ -607,22 +585,10 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, call fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt_nudge, & zvir, ak, bk, ts, ps, delp, ua, va, pt, & nwat, q, phis, gridstruct, bd, domain ) - - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = (pt(is:ie,js:je,:) - nudge_diag%nudge_t_dt) / dt - if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = (ps(is:ie,js:je) - nudge_diag%nudge_ps_dt) / dt - if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = (delp(is:ie,js:je,:) - nudge_diag%nudge_delp_dt) / dt - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = (u_dt(is:ie,js:je,:) - nudge_diag%nudge_u_dt) - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = (v_dt(is:ie,js:je,:) - nudge_diag%nudge_v_dt) #else ! All fields will be updated except winds; wind tendencies added - if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = pt(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = ps(is:ie,js:je) - if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = delp(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = u_dt(is:ie,js:je,:) - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = v_dt(is:ie,js:je,:) - !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ps) do j=js,je do k=2,npz+1 @@ -638,13 +604,14 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, zvir, ak, bk, ts, ps, delp, ua, va, pt, & nwat, q, phis, gridstruct, bd, domain ) + +#endif if (allocated(nudge_diag%nudge_t_dt)) nudge_diag%nudge_t_dt = (pt(is:ie,js:je,:) - nudge_diag%nudge_t_dt) / dt if (allocated(nudge_diag%nudge_ps_dt)) nudge_diag%nudge_ps_dt = (ps(is:ie,js:je) - nudge_diag%nudge_ps_dt) / dt if (allocated(nudge_diag%nudge_delp_dt)) nudge_diag%nudge_delp_dt = (delp(is:ie,js:je,:) - nudge_diag%nudge_delp_dt) / dt - if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = (u_dt(is:ie,js:je,:) - nudge_diag%nudge_u_dt) - if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = (v_dt(is:ie,js:je,:) - nudge_diag%nudge_v_dt) - -#endif + if (allocated(nudge_diag%nudge_u_dt)) nudge_diag%nudge_u_dt = (ua(is:ie,js:je,:) - nudge_diag%nudge_u_dt) / dt + if (allocated(nudge_diag%nudge_v_dt)) nudge_diag%nudge_v_dt = (va(is:ie,js:je,:) - nudge_diag%nudge_v_dt) / dt + if (allocated(nudge_diag%nudge_qv_dt)) nudge_diag%nudge_qv_dt = (q(is:ie,js:je,:,sphum) - nudge_diag%nudge_qv_dt) / dt endif ! end nudging @@ -770,7 +737,8 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, #ifdef GFS_PHYS call cubed_to_latlon(u, v, ua, va, gridstruct, & - npx, npy, npz, 1, gridstruct%grid_type, domain, gridstruct%bounded_domain, flagstruct%c2l_ord, bd) + npx, npy, npz, 1, gridstruct%grid_type, & + domain, gridstruct%bounded_domain, 4, bd) #endif if ( flagstruct%fv_debug ) then diff --git a/model/gfdl_mp.F90 b/model/gfdl_mp.F90 index 1eef85da2..286619e13 100644 --- a/model/gfdl_mp.F90 +++ b/model/gfdl_mp.F90 @@ -202,7 +202,7 @@ module gfdl_mp_mod ! 2: binary cloud scheme ! 3: extension of 0 - integer :: irain_f = 0 ! cloud water to rain auto conversion scheme + integer :: irain_f = 0 ! cloud water to rain autoconversion scheme ! 0: subgrid variability based scheme ! 1: no subgrid varaibility @@ -226,7 +226,6 @@ module gfdl_mp_mod integer :: rewflag = 1 ! cloud water effective radius scheme ! 1: Martin et al. (1994) ! 2: Martin et al. (1994), GFDL revision - ! 3: Kiehl et al. (1994) ! 4: effective radius integer :: reiflag = 5 ! cloud ice effective radius scheme @@ -300,6 +299,7 @@ module gfdl_mp_mod logical :: snow_grauple_combine = .true. ! combine snow and graupel logical :: prog_ccn = .false. ! do prognostic ccn (Yi Ming's method) + logical :: prog_cin = .false. ! do prognostic cin logical :: fix_negative = .true. ! fix negative water species @@ -329,6 +329,11 @@ module gfdl_mp_mod logical :: do_subgrid_proc = .true. ! do temperature sentive high vertical resolution processes + logical :: fast_fr_mlt = .true. ! do freezing and melting in fast microphysics + logical :: fast_dep_sub = .true. ! do deposition and sublimation in fast microphysics + + logical :: do_mp_diag = .false. ! enable microphysical quantities diagnostic + real :: mp_time = 150.0 ! maximum microphysics time step (s) real :: n0w_sig = 1.1 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) @@ -379,7 +384,6 @@ module gfdl_mp_mod real :: rh_inc = 0.25 ! rh increment for complete evaporation of cloud water and cloud ice real :: rh_inr = 0.25 ! rh increment for minimum evaporation of rain - real :: rh_ins = 0.25 ! rh increment for sublimation of snow real :: tau_r2g = 900.0 ! rain freezing to graupel time scale (s) real :: tau_i2s = 1000.0 ! cloud ice to snow autoconversion time scale (s) @@ -407,8 +411,6 @@ module gfdl_mp_mod real :: ql_mlt = 2.0e-3 ! maximum cloud water allowed from melted cloud ice (kg/kg) real :: qs_mlt = 1.0e-6 ! maximum cloud water allowed from melted snow (kg/kg) - real :: ql_gen = 1.0e-3 ! maximum cloud water generation during remapping step (kg/kg) - real :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg) real :: qi0_max = 1.0e-4 ! maximum cloud ice value (autoconverted to snow) (kg/m^3) @@ -520,12 +522,12 @@ module gfdl_mp_mod t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, & vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, & - rh_inc, rh_ins, rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, & + rh_inc, rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, & ccn_l, ccn_o, igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, & - tau_l2r, qi_lim, ql_gen, do_hail, inflag, c_psacw, c_psaci, c_pracs, & + tau_l2r, qi_lim, do_hail, inflag, c_psacw, c_psaci, c_pracs, & c_psacr, c_pgacr, c_pgacs, c_pgacw, c_pgaci, z_slope_liq, z_slope_ice, & prog_ccn, c_pracw, c_praci, rad_snow, rad_graupel, rad_rain, cld_min, & - sedflag, sed_fac, do_sedi_uv, do_sedi_w, do_sedi_heat, icloud_f, & + prog_cin, sedflag, sed_fac, do_sedi_uv, do_sedi_w, do_sedi_heat, icloud_f, & irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, do_cond_timescale, & mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, use_rhc_revap, tau_wbf, & do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, rhc_cevap, & @@ -538,7 +540,8 @@ module gfdl_mp_mod alinw, alini, alinr, alins, aling, alinh, blinw, blini, blinr, blins, bling, blinh, & do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, & snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, & - cp_heating, nconds, do_evap_timescale, delay_cond_evap, do_subgrid_proc + cp_heating, nconds, do_evap_timescale, delay_cond_evap, do_subgrid_proc, & + fast_fr_mlt, fast_dep_sub, do_mp_diag contains @@ -604,7 +607,11 @@ end subroutine gfdl_mp_init subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, & hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & - prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, last_step, do_inline_mp) + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, & + mpper, mppdi, mppd1, mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, & + mppfr, mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, & + mpprs, mpprg, mppxr, mppxs, mppxg, last_step, do_inline_mp, & + use_cond, moist_kappa) implicit none @@ -615,6 +622,7 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & integer, intent (in) :: is, ie, ks, ke logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp + logical, intent (in) :: use_cond, moist_kappa real, intent (in) :: dtm @@ -629,6 +637,12 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & real, intent (inout), dimension (is:, ks:) :: q_con, cappa real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr @@ -641,7 +655,11 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & - prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, .false., .true.) + prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, do_inline_mp, .false., .true., & + use_cond, moist_kappa) end subroutine gfdl_mp_driver @@ -1124,7 +1142,15 @@ subroutine setup_mhc_lhc (hydrostatic) d1_vap = d0_vap / c_air d1_ice = dc_ice / c_air - lv00 = (hlv - d0_vap * tice) / c_air + if (hydrostatic) then + lv00 = (hlv - d0_vap * tice) / c_air + else +#ifdef ENG_CNV_OLD + lv00 = (hlv - d0_vap * tice) / c_air +#else + lv00 = (hlv - d0_vap * tice - rvgas * tice) / c_air +#endif + endif li00 = (hlf - dc_ice * tice) / c_air li20 = lv00 + li00 @@ -1141,7 +1167,11 @@ end subroutine setup_mhc_lhc subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & - prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, do_mp_fast, do_mp_full) + prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, do_inline_mp, do_mp_fast, do_mp_full, & + use_cond, moist_kappa) implicit none @@ -1152,7 +1182,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & integer, intent (in) :: is, ie, ks, ke logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp - logical, intent (in) :: do_mp_fast, do_mp_full + logical, intent (in) :: do_mp_fast, do_mp_full, use_cond, moist_kappa real, intent (in) :: dtm @@ -1167,6 +1197,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & real, intent (inout), dimension (is:, ks:) :: q_con, cappa real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 real, intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr @@ -1178,7 +1214,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & integer :: i, k - real :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2 + real :: rh_adj, rh_rain, ccn0, cin0, q1, q2 real :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni real, dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0 @@ -1186,14 +1222,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & real, dimension (ks:ke) :: den, pz, denfac, ccn, cin real, dimension (ks:ke) :: u, v, w - real, dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw - real, dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi - real, dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr - real, dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs - real, dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg - - real, dimension (is:ie) :: condensation, deposition - real, dimension (is:ie) :: evaporation, sublimation + real, dimension (ks:ke) :: pcw, edw, oew, rrw, tvw + real, dimension (ks:ke) :: pci, edi, oei, rri, tvi + real, dimension (ks:ke) :: pcr, edr, oer, rrr, tvr + real, dimension (ks:ke) :: pcs, eds, oes, rrs, tvs + real, dimension (ks:ke) :: pcg, edg, oeg, rrg, tvg real (kind = r8) :: con_r8, c8, cp8 @@ -1213,18 +1246,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & dts = dtm / real (ntimes) ! ----------------------------------------------------------------------- - ! initialization of total energy difference and condensation diag + ! initialization of total energy difference ! ----------------------------------------------------------------------- dte = 0.0 - cond = 0.0 adj_vmr = 1.0 - condensation = 0.0 - deposition = 0.0 - evaporation = 0.0 - sublimation = 0.0 - ! ----------------------------------------------------------------------- ! unit convert to mm/day ! ----------------------------------------------------------------------- @@ -1354,18 +1381,26 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & (10. ** 2.24 * (qnl (i, k) * den (k) * 1.e9) ** 0.257) + & (1. - min (1., abs (hs (i)) / (10. * grav))) * & (10. ** 2.06 * (qnl (i, k) * den (k) * 1.e9) ** 0.48) - ni = qni (i, k) ccn (k) = max (10.0, nl) * 1.e6 - cin (k) = max (10.0, ni) * 1.e6 ccn (k) = ccn (k) / den (k) - cin (k) = cin (k) / den (k) enddo else ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + & ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6 - cin0 = 0.0 do k = ks, ke ccn (k) = ccn0 / den (k) + enddo + endif + + if (prog_cin) then + do k = ks, ke + ni = qni (i, k) + cin (k) = max (10.0, ni) * 1.e6 + cin (k) = cin (k) / den (k) + enddo + else + cin0 = 0.0 + do k = ks, ke cin (k) = cin0 / den (k) enddo endif @@ -1393,9 +1428,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & ! ----------------------------------------------------------------------- if (fix_negative) & - call neg_adj (ks, ke, tz, dp, qvz, qlz, qrz, qiz, qsz, qgz, cond) - - condensation (i) = condensation (i) + cond * convt + call neg_adj (ks, ke, tz, dp, qvz, qlz, qrz, qiz, qsz, qgz, mppcw (i), & + mppfr (i), convt) ! ----------------------------------------------------------------------- ! fast microphysics loop @@ -1404,8 +1438,9 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (do_mp_fast) then call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & - ccn, cin, condensation (i), deposition (i), evaporation (i), & - sublimation (i), denfac, convt, last_step) + ccn, cin, mppcw (i), mppew (i), mppdi (i), mppds (i), mppdg (i), & + mppsi (i), mppss (i), mppsg (i), mppfw (i), mppfr (i), mppmi (i), & + mppms (i), mppar (i), mppas (i), denfac, convt, last_step) endif @@ -1419,8 +1454,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte (i), & water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & - condensation (i), deposition (i), evaporation (i), sublimation (i), & - convt, last_step) + mppcw (i), mppew (i), mppe1 (i), mpper (i), mppdi (i), mppd1 (i), & + mppds (i), mppdg (i), mppsi (i), mpps1 (i), mppss (i), mppsg (i), & + mppfw (i), mppfr (i), mppmi (i), mppms (i), mppmg (i), mppm1 (i), & + mppm2 (i), mppm3 (i), mppar (i), mppas (i), mppag (i), mpprs (i), & + mpprg (i), mppxr (i), mppxs (i), mppxg (i), convt, last_step) endif @@ -1439,67 +1477,71 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & ! mass-weighted terminal velocity (tv) ! ======================================================================= - pcw (i, :) = 0.0 - edw (i, :) = 0.0 - oew (i, :) = 0.0 - rrw (i, :) = 0.0 - tvw (i, :) = 0.0 - pci (i, :) = 0.0 - edi (i, :) = 0.0 - oei (i, :) = 0.0 - rri (i, :) = 0.0 - tvi (i, :) = 0.0 - pcr (i, :) = 0.0 - edr (i, :) = 0.0 - oer (i, :) = 0.0 - rrr (i, :) = 0.0 - tvr (i, :) = 0.0 - pcs (i, :) = 0.0 - eds (i, :) = 0.0 - oes (i, :) = 0.0 - rrs (i, :) = 0.0 - tvs (i, :) = 0.0 - pcg (i, :) = 0.0 - edg (i, :) = 0.0 - oeg (i, :) = 0.0 - rrg (i, :) = 0.0 - tvg (i, :) = 0.0 + if (do_mp_diag) then + + pcw (:) = 0.0 + edw (:) = 0.0 + oew (:) = 0.0 + rrw (:) = 0.0 + tvw (:) = 0.0 + pci (:) = 0.0 + edi (:) = 0.0 + oei (:) = 0.0 + rri (:) = 0.0 + tvi (:) = 0.0 + pcr (:) = 0.0 + edr (:) = 0.0 + oer (:) = 0.0 + rrr (:) = 0.0 + tvr (:) = 0.0 + pcs (:) = 0.0 + eds (:) = 0.0 + oes (:) = 0.0 + rrs (:) = 0.0 + tvs (:) = 0.0 + pcg (:) = 0.0 + edg (:) = 0.0 + oeg (:) = 0.0 + rrg (:) = 0.0 + tvg (:) = 0.0 - do k = ks, ke - if (qlz (k) .gt. qcmin) then - call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (i, k), & - edaw, edbw, edw (i, k), oeaw, oebw, oew (i, k), rraw, rrbw, rrw (i, k), & - tvaw, tvbw, tvw (i, k)) - endif - if (qiz (k) .gt. qcmin) then - call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (i, k), & - edai, edbi, edi (i, k), oeai, oebi, oei (i, k), rrai, rrbi, rri (i, k), & - tvai, tvbi, tvi (i, k)) - endif - if (qrz (k) .gt. qcmin) then - call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (i, k), & - edar, edbr, edr (i, k), oear, oebr, oer (i, k), rrar, rrbr, rrr (i, k), & - tvar, tvbr, tvr (i, k)) - endif - if (qsz (k) .gt. qcmin) then - call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (i, k), & - edas, edbs, eds (i, k), oeas, oebs, oes (i, k), rras, rrbs, rrs (i, k), & - tvas, tvbs, tvs (i, k)) - endif - if (do_hail) then - if (qgz (k) .gt. qcmin) then - call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (i, k), & - edah, edbh, edg (i, k), oeah, oebh, oeg (i, k), rrah, rrbh, rrg (i, k), & - tvah, tvbh, tvg (i, k)) + do k = ks, ke + if (qlz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (k), & + edaw, edbw, edw (k), oeaw, oebw, oew (k), rraw, rrbw, rrw (k), & + tvaw, tvbw, tvw (k)) endif - else - if (qgz (k) .gt. qcmin) then - call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (i, k), & - edag, edbg, edg (i, k), oeag, oebg, oeg (i, k), rrag, rrbg, rrg (i, k), & - tvag, tvbg, tvg (i, k)) + if (qiz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (k), & + edai, edbi, edi (k), oeai, oebi, oei (k), rrai, rrbi, rri (k), & + tvai, tvbi, tvi (k)) endif - endif - enddo + if (qrz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (k), & + edar, edbr, edr (k), oear, oebr, oer (k), rrar, rrbr, rrr (k), & + tvar, tvbr, tvr (k)) + endif + if (qsz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (k), & + edas, edbs, eds (k), oeas, oebs, oes (k), rras, rrbs, rrs (k), & + tvas, tvbs, tvs (k)) + endif + if (do_hail) then + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (k), & + edah, edbh, edg (k), oeah, oebh, oeg (k), rrah, rrbh, rrg (k), & + tvah, tvbh, tvg (k)) + endif + else + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (k), & + edag, edbg, edg (k), oeag, oebg, oeg (k), rrag, rrbg, rrg (k), & + tvag, tvbg, tvg (k)) + endif + endif + enddo + + endif ! ----------------------------------------------------------------------- ! momentum transportation during sedimentation @@ -1577,13 +1619,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & con_r8 = one_r8 - (qvz (k) + q_cond) c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air -#ifdef USE_COND - q_con (i, k) = q_cond -#endif -#ifdef MOIST_CAPPA - tmp = rdgas * (1. + zvir * qvz (k)) - cappa (i, k) = tmp / (tmp + c8) -#endif + if (use_cond) q_con (i, k) = q_cond + if (moist_kappa) then + tmp = rdgas * (1. + zvir * qvz (k)) + cappa (i, k) = tmp / (tmp + c8) + endif enddo @@ -1734,7 +1774,7 @@ end subroutine mpdrv ! fix negative water species ! ======================================================================= -subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) +subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, mppcw, mppfr, convt) implicit none @@ -1744,13 +1784,15 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) integer, intent (in) :: ks, ke + real, intent (in) :: convt + real, intent (in), dimension (ks:ke) :: dp real (kind = r8), intent (inout), dimension (ks:ke) :: tz real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - real, intent (out) :: cond + real, intent (inout) :: mppcw, mppfr ! ----------------------------------------------------------------------- ! local variables @@ -1764,12 +1806,6 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) real (kind = r8), dimension (ks:ke) :: cvm, te8 - ! ----------------------------------------------------------------------- - ! initialization - ! ----------------------------------------------------------------------- - - cond = 0 - ! ----------------------------------------------------------------------- ! calculate moist heat capacity and latent heat coefficients ! ----------------------------------------------------------------------- @@ -1800,6 +1836,7 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) ! if graupel < 0, borrow from rain if (qg (k) .lt. 0.) then sink = min (- qg (k), max (0., qr (k))) + mppfr = mppfr + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) @@ -1819,7 +1856,7 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) ! if cloud water < 0, borrow from water vapor if (ql (k) .lt. 0.) then sink = min (- ql (k), max (0., qv (k))) - cond = cond + sink * dp (k) + mppcw = mppcw + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & - sink, sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) @@ -1854,8 +1891,10 @@ end subroutine neg_adj subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, & den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, & - snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & - condensation, deposition, evaporation, sublimation, convt, last_step) + snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, mppcw, & + mppew, mppe1, mpper, mppdi, mppd1, mppds, mppdg, mppsi, mpps1, mppss, & + mppsg, mppfw, mppfr, mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, & + mppas, mppag, mpprs, mpprg, mppxr, mppxs, mppxg, convt, last_step) implicit none @@ -1877,8 +1916,12 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, real (kind = r8), intent (inout), dimension (ks:ke) :: tz real, intent (inout) :: water, rain, ice, snow, graupel - real, intent (inout) :: condensation, deposition - real, intent (inout) :: evaporation, sublimation + real, intent (inout) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout) :: mppm1, mppm2, mppm3 real (kind = r8), intent (inout) :: dte @@ -1888,7 +1931,7 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, integer :: n - real :: w1, r1, i1, s1, g1, cond, dep, reevap, sub + real :: w1, r1, i1, s1, g1 real, dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg @@ -1898,9 +1941,9 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, ! sedimentation of cloud ice, snow, graupel or hail, and rain ! ----------------------------------------------------------------------- - call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, & - dz, dp, vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & - u, v, w, den, denfac, dte) + call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, vtw, & + vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, u, v, & + w, den, denfac, dte, mppm1, mppm2, mppm3, convt) water = water + w1 * convt rain = rain + r1 * convt @@ -1918,17 +1961,16 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, ! warm rain cloud microphysics ! ----------------------------------------------------------------------- - call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & - den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) - - evaporation = evaporation + reevap * convt + call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, ccn, rh_rain, h_var, mpper, mppar, mppxr, convt) ! ----------------------------------------------------------------------- ! ice cloud microphysics ! ----------------------------------------------------------------------- - call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & - denfac, vtw, vtr, vti, vts, vtg, dts, h_var) + call ice_cloud (ks, ke, dp, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, vti, vts, vtg, dts, h_var, mppfw, mppfr, mppmi, mppms, mppmg, mppas, & + mppag, mpprs, mpprg, mppxs, mppxg, convt) if (do_subgrid_proc) then @@ -1936,13 +1978,9 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, ! temperature sentive high vertical resolution processes ! ----------------------------------------------------------------------- - call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & - qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) - - condensation = condensation + cond * convt - deposition = deposition + dep * convt - evaporation = evaporation + reevap * convt - sublimation = sublimation + sub * convt + call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, mppcw, mppew, mppe1, mppdi, mppd1, mppds, & + mppdg, mppsi, mpps1, mppss, mppsg, mppfw, convt, last_step) endif @@ -1954,9 +1992,9 @@ end subroutine mp_full ! fast microphysics loop ! ======================================================================= -subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & - ccn, cin, condensation, deposition, evaporation, sublimation, & - denfac, convt, last_step) +subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, ccn, & + cin, mppcw, mppew, mppdi, mppds, mppdg, mppsi, mppss, mppsg, mppfw, & + mppfr, mppmi, mppms, mppar, mppas, denfac, convt, last_step) implicit none @@ -1976,8 +2014,8 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & real (kind = r8), intent (inout), dimension (ks:ke) :: tz - real, intent (inout) :: condensation, deposition - real, intent (inout) :: evaporation, sublimation + real, intent (inout) :: mppcw, mppew, mppdi, mppds, mppdg, mppsi, mppss, mppsg + real, intent (inout) :: mppfw, mppfr, mppmi, mppms, mppar, mppas ! ----------------------------------------------------------------------- ! local variables @@ -1987,21 +2025,10 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & integer :: n - real :: cond, dep, reevap, sub - real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 real (kind = r8), dimension (ks:ke) :: cvm, te8 - ! ----------------------------------------------------------------------- - ! initialization - ! ----------------------------------------------------------------------- - - cond = 0 - dep = 0 - reevap = 0 - sub = 0 - ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- @@ -2009,21 +2036,21 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - if (.not. do_warm_rain_mp) then + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then ! ----------------------------------------------------------------------- ! cloud ice melting to form cloud water and rain ! ----------------------------------------------------------------------- - call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & - lcpk, icpk, tcpk, tcp3) + call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, & + icpk, tcpk, tcp3, mppmi, convt) ! ----------------------------------------------------------------------- ! enforce complete freezing below t_wfr ! ----------------------------------------------------------------------- - call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & - lcpk, icpk, tcpk, tcp3) + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) endif @@ -2039,50 +2066,47 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & if (cond_evap) then do n = 1, nconds - call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cond, reevap) + call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, & + te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) enddo endif - condensation = condensation + cond * convt - evaporation = evaporation + reevap * convt - - if (.not. do_warm_rain_mp) then + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then ! ----------------------------------------------------------------------- - ! cloud water freezing to form cloud ice and snow + ! cloud water homogeneous freezing to form cloud ice and snow ! ----------------------------------------------------------------------- - call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3) + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! Wegener Bergeron Findeisen process ! ----------------------------------------------------------------------- - call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3) + call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! Bigg freezing mechanism ! ----------------------------------------------------------------------- - call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, & - lcpk, icpk, tcpk, tcp3) + call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! rain freezing to form graupel ! ----------------------------------------------------------------------- - call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & - lcpk, icpk, tcpk, tcp3) + call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppfr, convt) ! ----------------------------------------------------------------------- ! snow melting to form cloud water and rain ! ----------------------------------------------------------------------- - call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & - lcpk, icpk, tcpk, tcp3) + call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppms, convt) endif @@ -2090,39 +2114,36 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & ! cloud water to rain autoconversion ! ----------------------------------------------------------------------- - call praut_simp (ks, ke, dtm, tz, qv, ql, qr, qi, qs, qg) + call praut_simp (ks, ke, dtm, dp, tz, qv, ql, qr, qi, qs, qg, mppar, convt) - if (.not. do_warm_rain_mp) then + if (.not. do_warm_rain_mp .and. fast_dep_sub) then ! ----------------------------------------------------------------------- ! cloud ice deposition and sublimation ! ----------------------------------------------------------------------- call pidep_pisub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cin, dep, sub) - - deposition = deposition + dep * convt - sublimation = sublimation + sub * convt + lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) ! ----------------------------------------------------------------------- ! cloud ice to snow autoconversion ! ----------------------------------------------------------------------- - call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den) + call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, dp, tz, den, mppas, convt) ! ----------------------------------------------------------------------- ! snow deposition and sublimation ! ----------------------------------------------------------------------- call psdep_pssub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) ! ----------------------------------------------------------------------- ! graupel deposition and sublimation ! ----------------------------------------------------------------------- call pgdep_pgsub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) endif @@ -2134,7 +2155,7 @@ end subroutine mp_fast subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & - u, v, w, den, denfac, dte) + u, v, w, den, denfac, dte, mppm1, mppm2, mppm3, convt) implicit none @@ -2144,7 +2165,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac @@ -2158,6 +2179,8 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppm1, mppm2, mppm3 + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -2205,14 +2228,14 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & if (do_sedi_melt) then call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & - vti, r1, tau_imlt, icpk, "qi") + vti, r1, tau_imlt, icpk, "qi", mppm1, convt) endif call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vti, i1, pfi, u, v, w, dte, "qi") pfi (ks) = max (0.0, pfi (ks)) - do k = ke, ks + 1, -1 + do k = ke, ks + 1, - 1 pfi (k) = max (0.0, pfi (k) - pfi (k - 1)) enddo @@ -2224,14 +2247,14 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & if (do_sedi_melt) then call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & - vts, r1, tau_smlt, icpk, "qs") + vts, r1, tau_smlt, icpk, "qs", mppm2, convt) endif call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vts, s1, pfs, u, v, w, dte, "qs") pfs (ks) = max (0.0, pfs (ks)) - do k = ke, ks + 1, -1 + do k = ke, ks + 1, - 1 pfs (k) = max (0.0, pfs (k) - pfs (k - 1)) enddo @@ -2247,14 +2270,14 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & if (do_sedi_melt) then call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & - vtg, r1, tau_gmlt, icpk, "qg") + vtg, r1, tau_gmlt, icpk, "qg", mppm3, convt) endif call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtg, g1, pfg, u, v, w, dte, "qg") pfg (ks) = max (0.0, pfg (ks)) - do k = ke, ks + 1, -1 + do k = ke, ks + 1, - 1 pfg (k) = max (0.0, pfg (k) - pfg (k - 1)) enddo @@ -2270,7 +2293,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtw, w1, pfw, u, v, w, dte, "ql") pfw (ks) = max (0.0, pfw (ks)) - do k = ke, ks + 1, -1 + do k = ke, ks + 1, - 1 pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) enddo @@ -2286,7 +2309,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtr, r1, pfr, u, v, w, dte, "qr") pfr (ks) = max (0.0, pfr (ks)) - do k = ke, ks + 1, -1 + do k = ke, ks + 1, - 1 pfr (k) = max (0.0, pfr (k) - pfr (k - 1)) enddo @@ -2407,7 +2430,7 @@ end subroutine term_rsg ! ======================================================================= subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & - vt, r1, tau_mlt, icpk, qflag) + vt, r1, tau_mlt, icpk, qflag, mppm, convt) implicit none @@ -2417,13 +2440,13 @@ subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & integer, intent (in) :: ks, ke - real, intent (in) :: dts, tau_mlt + real, intent (in) :: dts, tau_mlt, convt real, intent (in), dimension (ks:ke) :: vt, dp, dz, icpk real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - real, intent (inout) :: r1 + real, intent (inout) :: r1, mppm real (kind = r8), intent (inout), dimension (ks:ke) :: tz @@ -2471,6 +2494,7 @@ subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & dtime = min (dts, (ze (m) - ze (m + 1)) / vt (k)) dtime = min (1.0, dtime / tau_mlt) sink = min (q (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + mppm = mppm + sink * dp (k) * convt q (k) = q (k) - sink * dp (m) / dp (k) if (zt (k) .lt. zs) then r1 = r1 + sink * dp (m) @@ -2500,7 +2524,7 @@ subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & end subroutine sedi_melt ! ======================================================================= -! melting during sedimentation +! terminal fall ! ======================================================================= subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & @@ -2766,7 +2790,7 @@ end subroutine check_column ! ======================================================================= subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & - den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) + den, denfac, vtw, vtr, ccn, rh_rain, h_var, mpper, mppar, mppxr, convt) implicit none @@ -2776,7 +2800,7 @@ subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & integer, intent (in) :: ks, ke - real, intent (in) :: dts, rh_rain, h_var + real, intent (in) :: dts, rh_rain, h_var, convt real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac, vtw, vtr @@ -2784,31 +2808,28 @@ subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & real (kind = r8), intent (inout), dimension (ks:ke) :: tz - real, intent (out) :: reevap - - ! ----------------------------------------------------------------------- - ! initialization - ! ----------------------------------------------------------------------- - - reevap = 0 + real, intent (inout) :: mpper, mppar, mppxr ! ----------------------------------------------------------------------- ! rain evaporation to form water vapor ! ----------------------------------------------------------------------- - call prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) + call prevp (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, & + h_var, mpper, convt) ! ----------------------------------------------------------------------- ! rain accretion with cloud water ! ----------------------------------------------------------------------- - call pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) + call pracw (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, mppxr, convt) ! ----------------------------------------------------------------------- ! cloud water to rain autoconversion ! ----------------------------------------------------------------------- - call praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) + call praut (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var, & + mppar, convt) end subroutine warm_rain @@ -2816,7 +2837,8 @@ end subroutine warm_rain ! rain evaporation to form water vapor, Lin et al. (1983) ! ======================================================================= -subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) +subroutine prevp (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, & + h_var, mpper, convt) implicit none @@ -2826,7 +2848,7 @@ subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, integer, intent (in) :: ks, ke - real, intent (in) :: dts, rh_rain, h_var + real, intent (in) :: dts, rh_rain, h_var, convt real, intent (in), dimension (ks:ke) :: den, denfac, dp @@ -2834,7 +2856,7 @@ subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg - real, intent (out) :: reevap + real, intent (inout) :: mpper ! ----------------------------------------------------------------------- ! local variables @@ -2849,12 +2871,6 @@ subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, real (kind = r8), dimension (ks:ke) :: cvm, te8 - ! ----------------------------------------------------------------------- - ! initialization - ! ----------------------------------------------------------------------- - - reevap = 0 - ! ----------------------------------------------------------------------- ! time-scale factor ! ----------------------------------------------------------------------- @@ -2915,7 +2931,7 @@ subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt)) ! sink = max (sink, tmp) - reevap = reevap + sink * dp (k) + mpper = mpper + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink, 0., - sink, 0., 0., 0., te8 (k), cvm (k), tz (k), & @@ -2931,7 +2947,8 @@ end subroutine prevp ! rain accretion with cloud water, Lin et al. (1983) ! ======================================================================= -subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) +subroutine pracw (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, mppxr, convt) implicit none @@ -2941,14 +2958,16 @@ subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, dp real (kind = r8), intent (inout), dimension (ks:ke) :: tz real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg + real, intent (inout) :: mppxr + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -2969,6 +2988,7 @@ subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur) sink = sink / (1. + sink) * ql (k) endif + mppxr = mppxr + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) @@ -2983,7 +3003,8 @@ end subroutine pracw ! cloud water to rain autoconversion, Hong et al. (2004) ! ======================================================================= -subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) +subroutine praut (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var, & + mppar, convt) implicit none @@ -2993,14 +3014,16 @@ subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) integer, intent (in) :: ks, ke - real, intent (in) :: dts, h_var + real, intent (in) :: dts, h_var, convt - real, intent (in), dimension (ks:ke) :: den + real, intent (in), dimension (ks:ke) :: den, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppar + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3038,6 +3061,7 @@ subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * & exp (so3 * log (ql (k))) sink = min (ql (k), sink) + mppar = mppar + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) @@ -3070,6 +3094,7 @@ subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) sink = min (ql (k), sink) + mppar = mppar + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) @@ -3088,8 +3113,9 @@ end subroutine praut ! ice cloud microphysics ! ======================================================================= -subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & - denfac, vtw, vtr, vti, vts, vtg, dts, h_var) +subroutine ice_cloud (ks, ke, dp, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, vti, vts, vtg, dts, h_var, mppfw, mppfr, mppmi, mppms, mppmg, mppas, & + mppag, mpprs, mpprg, mppxs, mppxg, convt) implicit none @@ -3099,14 +3125,17 @@ subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & integer, intent (in) :: ks, ke - real, intent (in) :: dts, h_var + real, intent (in) :: dts, h_var, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppfw, mppfr, mppmi, mppms, mppmg, mppas, mppag + real, intent (inout) :: mpprs, mpprg, mppxs, mppxg + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3128,13 +3157,15 @@ subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & ! cloud ice melting to form cloud water and rain ! ----------------------------------------------------------------------- - call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppmi, convt) ! ----------------------------------------------------------------------- - ! cloud water freezing to form cloud ice and snow + ! cloud water homogeneous freezing to form cloud ice and snow ! ----------------------------------------------------------------------- - call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! vertical subgrid variability @@ -3146,59 +3177,61 @@ subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain ! ----------------------------------------------------------------------- - call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) + call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3, mppms, convt) ! ----------------------------------------------------------------------- ! graupel melting (includes graupel accretion with cloud water and rain) to form rain ! ----------------------------------------------------------------------- - call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) + call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3, mppmg, convt) ! ----------------------------------------------------------------------- ! snow accretion with cloud ice ! ----------------------------------------------------------------------- - call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) + call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, vts, & + mppxs, convt) ! ----------------------------------------------------------------------- ! cloud ice to snow autoconversion ! ----------------------------------------------------------------------- - call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) + call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, di, mppas, convt) ! ----------------------------------------------------------------------- ! graupel accretion with cloud ice ! ----------------------------------------------------------------------- - call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) + call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, vtg, & + mppxg, convt) ! ----------------------------------------------------------------------- ! snow accretion with rain and rain freezing to form graupel ! ----------------------------------------------------------------------- - call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtr, vts, lcpk, icpk, tcpk, tcp3) + call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vts, lcpk, icpk, tcpk, tcp3, mppfr, mpprs, convt) ! ----------------------------------------------------------------------- ! graupel accretion with snow ! ----------------------------------------------------------------------- - call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) + call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, vts, vtg, mppxg, convt) ! ----------------------------------------------------------------------- ! snow to graupel autoconversion ! ----------------------------------------------------------------------- - call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, mppag, convt) ! ----------------------------------------------------------------------- ! graupel accretion with cloud water and rain ! ----------------------------------------------------------------------- - call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtr, vtg, lcpk, icpk, tcpk, tcp3) + call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vtg, lcpk, icpk, tcpk, tcp3, mpprg, convt) endif ! do_warm_rain_mp @@ -3208,7 +3241,8 @@ end subroutine ice_cloud ! cloud ice melting to form cloud water and rain, Lin et al. (1983) ! ======================================================================= -subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) +subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppmi, convt) implicit none @@ -3218,15 +3252,19 @@ subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real (kind = r8), intent (in), dimension (ks:ke) :: te8 + real, intent (in), dimension (ks:ke) :: dp + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppmi + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3246,6 +3284,7 @@ subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, sink = fac_imlt * tc / icpk (k) sink = min (qi (k), sink) tmp = min (sink, dim (ql_mlt, ql (k))) + mppmi = mppmi + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & @@ -3258,10 +3297,11 @@ subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, end subroutine pimlt ! ======================================================================= -! cloud water freezing to form cloud ice and snow, Lin et al. (1983) +! cloud water homogeneous freezing to form cloud ice and snow, Lin et al. (1983) ! ======================================================================= -subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) +subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) implicit none @@ -3271,7 +3311,9 @@ subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, integer, intent (in) :: ks, ke - real, intent (in), dimension (ks:ke) :: den + real, intent (in) :: convt + + real, intent (in), dimension (ks:ke) :: den, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -3280,6 +3322,8 @@ subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppfw + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3298,6 +3342,7 @@ subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, sink = min (ql (k), sink, tc / icpk (k)) qim = qi0_crt / den (k) tmp = min (sink, dim (qim, qi (k))) + mppfw = mppfw + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & @@ -3314,8 +3359,8 @@ end subroutine pifr ! Lin et al. (1983) ! ======================================================================= -subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) +subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3, mppms, convt) implicit none @@ -3325,9 +3370,9 @@ subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -3336,6 +3381,8 @@ subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppms + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3380,6 +3427,7 @@ subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac sink = min (qs (k), (sink + pracs) * dts, tc / icpk (k)) tmp = min (sink, dim (qs_mlt, ql (k))) + mppms = mppms + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & @@ -3396,8 +3444,8 @@ end subroutine psmlt ! Lin et al. (1983) ! ======================================================================= -subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) +subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3, mppmg, convt) implicit none @@ -3407,9 +3455,9 @@ subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -3418,6 +3466,8 @@ subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppmg + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3467,6 +3517,7 @@ subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac endif sink = min (qg (k), sink * dts, tc / icpk (k)) + mppmg = mppmg + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., sink, 0., 0., - sink, te8 (k), cvm (k), tz (k), & @@ -3482,7 +3533,8 @@ end subroutine pgmlt ! snow accretion with cloud ice, Lin et al. (1983) ! ======================================================================= -subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) +subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, & + vts, mppxs, convt) implicit none @@ -3492,14 +3544,16 @@ subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppxs + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3527,6 +3581,7 @@ subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts endif sink = min (fi2s_fac * qi (k), sink) + mppxs = mppxs + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, sink, 0.) @@ -3541,7 +3596,7 @@ end subroutine psaci ! cloud ice to snow autoconversion, Lin et al. (1983) ! ======================================================================= -subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) +subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, di, mppas, convt) implicit none @@ -3551,14 +3606,16 @@ subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den + real, intent (in), dimension (ks:ke) :: den, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, di real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppas + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3590,6 +3647,7 @@ subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) endif sink = min (fi2s_fac * qi (k), sink) + mppas = mppas + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, sink, 0.) @@ -3604,7 +3662,8 @@ end subroutine psaut ! graupel accretion with cloud ice, Lin et al. (1983) ! ======================================================================= -subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) +subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, & + vtg, mppxg, convt) implicit none @@ -3614,14 +3673,16 @@ subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppxg + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3653,6 +3714,7 @@ subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg endif sink = min (fi2g_fac * qi (k), sink) + mppxg = mppxg + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, 0., sink) @@ -3667,8 +3729,8 @@ end subroutine pgaci ! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983) ! ======================================================================= -subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtr, vts, lcpk, icpk, tcpk, tcp3) +subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vts, lcpk, icpk, tcpk, tcp3, mppfr, mpprs, convt) implicit none @@ -3678,9 +3740,9 @@ subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, d integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -3689,6 +3751,8 @@ subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, d real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppfr, mpprs + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3717,6 +3781,8 @@ subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, d factor = min (sink, qr (k), - tc / icpk (k)) / max (sink, qcmin) psacr = factor * psacr pgfr = factor * pgfr + mpprs = mpprs + psacr * dp (k) * convt + mppfr = mppfr + pgfr * dp (k) * convt sink = min (qr (k), psacr + pgfr) @@ -3734,7 +3800,8 @@ end subroutine psacr_pgfr ! graupel accretion with snow, Lin et al. (1983) ! ======================================================================= -subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) +subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, vts, vtg, & + mppxg, convt) implicit none @@ -3744,14 +3811,16 @@ subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, vts, vtg + real, intent (in), dimension (ks:ke) :: den, vts, vtg, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppxg + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3767,6 +3836,7 @@ subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) sink = dts * acr3d (vtg (k), vts (k), qs (k), qg (k), cgacs, acco (:, 4), & acc (7), acc (8), den (k)) sink = min (fs2g_fac * qs (k), sink) + mppxg = mppxg + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., 0., - sink, sink) @@ -3781,7 +3851,7 @@ end subroutine pgacs ! snow to graupel autoconversion, Lin et al. (1983) ! ======================================================================= -subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) +subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, mppag, convt) implicit none @@ -3791,14 +3861,16 @@ subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den + real, intent (in), dimension (ks:ke) :: den, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppag + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3821,6 +3893,7 @@ subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) endif sink = min (fs2g_fac * qs (k), sink) + mppag = mppag + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., 0., - sink, sink) @@ -3835,8 +3908,8 @@ end subroutine pgaut ! graupel accretion with cloud water and rain, Lin et al. (1983) ! ======================================================================= -subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & - vtr, vtg, lcpk, icpk, tcpk, tcp3) +subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + den, denfac, vtr, vtg, lcpk, icpk, tcpk, tcp3, mpprg, convt) implicit none @@ -3846,9 +3919,9 @@ subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -3857,6 +3930,8 @@ subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mpprg + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -3895,6 +3970,7 @@ subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, pgacw = factor * pgacw sink = pgacr + pgacw + mpprg = mpprg + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - pgacw, - pgacr, 0., 0., sink, te8 (k), cvm (k), tz (k), & @@ -3911,7 +3987,8 @@ end subroutine pgacw_pgacr ! ======================================================================= subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & - qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) + qi, qs, qg, dp, ccn, cin, mppcw, mppew, mppe1, mppdi, mppd1, mppds, & + mppdg, mppsi, mpps1, mppss, mppsg, mppfw, convt, last_step) implicit none @@ -3923,13 +4000,14 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & integer, intent (in) :: ks, ke - real, intent (in) :: dts, rh_adj + real, intent (in) :: dts, rh_adj, convt real, intent (in), dimension (ks:ke) :: den, denfac, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin - real, intent (out) :: cond, dep, reevap, sub + real, intent (inout) :: mppcw, mppew, mppe1, mppdi, mppd1, mppds + real, intent (inout) :: mppdg, mppsi, mpps1, mppss, mppsg, mppfw real (kind = r8), intent (inout), dimension (ks:ke) :: tz @@ -3945,15 +4023,6 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & real (kind = r8), dimension (ks:ke) :: cvm, te8 - ! ----------------------------------------------------------------------- - ! initialization - ! ----------------------------------------------------------------------- - - cond = 0 - dep = 0 - reevap = 0 - sub = 0 - ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- @@ -3968,7 +4037,7 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & if (.not. do_warm_rain_mp) then call pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) + lcpk, icpk, tcpk, tcp3, rh_adj, mppe1, mppd1, mpps1, convt) endif @@ -3984,8 +4053,8 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & if (cond_evap) then do n = 1, nconds - call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cond, reevap) + call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, & + te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) enddo endif @@ -3995,40 +4064,43 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & ! enforce complete freezing below t_wfr ! ----------------------------------------------------------------------- - call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! Wegener Bergeron Findeisen process ! ----------------------------------------------------------------------- - call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! Bigg freezing mechanism ! ----------------------------------------------------------------------- - call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) + call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- ! cloud ice deposition and sublimation ! ----------------------------------------------------------------------- call pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cin, dep, sub) + lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) ! ----------------------------------------------------------------------- ! snow deposition and sublimation ! ----------------------------------------------------------------------- call psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) ! ----------------------------------------------------------------------- ! graupel deposition and sublimation ! ----------------------------------------------------------------------- call pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) endif @@ -4039,7 +4111,7 @@ end subroutine subgrid_z_proc ! ======================================================================= subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) + lcpk, icpk, tcpk, tcp3, rh_adj, mppe1, mppd1, mpps1, convt) implicit none @@ -4049,7 +4121,7 @@ subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & integer, intent (in) :: ks, ke - real, intent (in) :: rh_adj + real, intent (in) :: rh_adj, convt real, intent (in), dimension (ks:ke) :: den, dp @@ -4060,7 +4132,7 @@ subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - real, intent (out) :: dep, reevap, sub + real, intent (inout) :: mppe1, mppd1, mpps1 ! ----------------------------------------------------------------------- ! local variables @@ -4079,7 +4151,7 @@ subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & if (tz (k) .lt. t_min) then sink = dim (qv (k), qcmin) - dep = dep + sink * dp (k) + mppd1 = mppd1 + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & @@ -4104,8 +4176,8 @@ subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & sink = ql (k) tmp = qi (k) - reevap = reevap + sink * dp (k) - sub = sub + tmp * dp (k) + mppe1 = mppe1 + sink * dp (k) * convt + mpps1 = mpps1 + tmp * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink + tmp, - sink, 0., - tmp, 0., 0., te8 (k), cvm (k), tz (k), & @@ -4123,8 +4195,8 @@ end subroutine pinst ! cloud water condensation and evaporation, Hong and Lim (2006) ! ======================================================================= -subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cond, reevap) +subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) implicit none @@ -4134,7 +4206,7 @@ subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real, intent (in), dimension (ks:ke) :: den, dp @@ -4145,7 +4217,7 @@ subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - real, intent (out) :: cond, reevap + real, intent (inout) :: mppcw, mppew ! ----------------------------------------------------------------------- ! local variables @@ -4175,7 +4247,7 @@ subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then sink = 0. endif - reevap = reevap + sink * dp (k) + mppew = mppew + sink * dp (k) * convt else if (do_cond_timescale) then factor = min (1., fac_v2l * (rh_fac_cond * (- dq) / qsw)) @@ -4183,7 +4255,7 @@ subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d factor = 1. endif sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt)) - cond = cond - sink * dp (k) + mppcw = mppcw - sink * dp (k) * convt endif call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -4198,7 +4270,8 @@ end subroutine pcond_pevap ! enforce complete freezing below t_wfr, Lin et al. (1983) ! ======================================================================= -subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) +subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) implicit none @@ -4208,6 +4281,10 @@ subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk integer, intent (in) :: ks, ke + real, intent (in) :: convt + + real, intent (in), dimension (ks:ke) :: dp + real (kind = r8), intent (in), dimension (ks:ke) :: te8 real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg @@ -4215,6 +4292,8 @@ subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppfw + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -4231,6 +4310,7 @@ subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk sink = ql (k) * tc / dt_fr sink = min (ql (k), sink, tc / icpk (k)) + mppfw = mppfw + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & @@ -4246,7 +4326,8 @@ end subroutine pcomp ! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015) ! ======================================================================= -subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) +subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) implicit none @@ -4256,9 +4337,9 @@ subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, i integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den + real, intent (in), dimension (ks:ke) :: den, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -4267,6 +4348,8 @@ subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, i real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppfw + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -4293,6 +4376,7 @@ subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, i sink = min (fac_wbf * ql (k), tc / icpk (k)) qim = qi0_crt / den (k) tmp = min (sink, dim (qim, qi (k))) + mppfw = mppfw + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & @@ -4308,7 +4392,8 @@ end subroutine pwbf ! Bigg freezing mechanism, Bigg (1953) ! ======================================================================= -subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) +subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) implicit none @@ -4318,9 +4403,9 @@ subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, l integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den + real, intent (in), dimension (ks:ke) :: den, dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -4329,6 +4414,8 @@ subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, l real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppfw + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -4351,6 +4438,7 @@ subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, l sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 sink = min (ql (k), sink, tc / icpk (k)) + mppfw = mppfw + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & @@ -4366,8 +4454,8 @@ end subroutine pbigg ! cloud ice deposition and sublimation, Hong et al. (2004) ! ======================================================================= -subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cin, dep, sub) +subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) implicit none @@ -4377,7 +4465,7 @@ subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real, intent (in), dimension (ks:ke) :: den, dp @@ -4388,7 +4476,7 @@ subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - real, intent (out) :: dep, sub + real, intent (out) :: mppdi, mppsi ! ----------------------------------------------------------------------- ! local variables @@ -4409,7 +4497,7 @@ subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d tmp = dq / (1. + tcpk (k) * dqdt) if (qi (k) .gt. qcmin) then - if (.not. prog_ccn) then + if (.not. prog_cin) then if (inflag .eq. 1) & cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k))) if (inflag .eq. 2) & @@ -4443,11 +4531,11 @@ subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d if (igflag .eq. 4) & qi_crt = max (qi_gen, 1.82e-6) * min (qi_lim, 0.1 * tc) / den (k) sink = min (tmp, max (qi_crt - qi (k), pidep), tc / tcpk (k)) - dep = dep + sink * dp (k) + mppdi = mppdi + sink * dp (k) * convt else pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac) sink = max (pidep, tmp, - qi (k)) - sub = sub - sink * dp (k) + mppsi = mppsi - sink * dp (k) * convt endif call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -4464,8 +4552,8 @@ end subroutine pidep_pisub ! snow deposition and sublimation, Lin et al. (1983) ! ======================================================================= -subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - denfac, lcpk, icpk, tcpk, tcp3, dep, sub) +subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) implicit none @@ -4475,7 +4563,7 @@ subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real, intent (in), dimension (ks:ke) :: den, dp, denfac @@ -4486,7 +4574,7 @@ subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - real, intent (out) :: dep, sub + real, intent (out) :: mppds, mppss ! ----------------------------------------------------------------------- ! local variables @@ -4510,13 +4598,13 @@ subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d dq = dq / (1. + tcpk (k) * dqdt) if (pssub .gt. 0.) then sink = min (pssub * min (1., dim (tz (k), t_sub) * ss_fac), qs (k)) - sub = sub + sink * dp (k) + mppss = mppss + sink * dp (k) * convt else sink = 0. if (tz (k) .le. tice) then sink = max (pssub, dq, (tz (k) - tice) / tcpk (k)) endif - dep = dep - sink * dp (k) + mppds = mppds - sink * dp (k) * convt endif call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -4533,8 +4621,8 @@ end subroutine psdep_pssub ! graupel deposition and sublimation, Lin et al. (1983) ! ======================================================================= -subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - denfac, lcpk, icpk, tcpk, tcp3, dep, sub) +subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) implicit none @@ -4544,7 +4632,7 @@ subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real, intent (in), dimension (ks:ke) :: den, dp, denfac @@ -4555,7 +4643,7 @@ subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - real, intent (out) :: dep, sub + real, intent (out) :: mppdg, mppsg ! ----------------------------------------------------------------------- ! local variables @@ -4585,13 +4673,13 @@ subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d dq = dq / (1. + tcpk (k) * dqdt) if (pgsub .gt. 0.) then sink = min (pgsub * min (1., dim (tz (k), t_sub) * gs_fac), qg (k)) - sub = sub + sink * dp (k) + mppsg = mppsg + sink * dp (k) * convt else sink = 0. if (tz (k) .le. tice) then sink = max (pgsub, dq, (tz (k) - tice) / tcpk (k)) endif - dep = dep - sink * dp (k) + mppdg = mppdg - sink * dp (k) * convt endif call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -5479,7 +5567,7 @@ function vent_coeff (qden, c1, c2, denfac, blin, mu) end function vent_coeff ! ======================================================================= -! sublimation or evaporation function, Lin et al. (1983) +! sublimation or deposition function, Lin et al. (1983) ! ======================================================================= function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm) @@ -5637,7 +5725,11 @@ end subroutine sedi_heat subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, & - pt, delp, q_con, cappa, gsize, last_step, do_sat_adj) + pt, delp, q_con, cappa, gsize, mppcw, mppew, mppe1, mpper, mppdi, & + mppd1, mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, & + mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, & + mpprs, mpprg, mppxr, mppxs, mppxg, last_step, do_sat_adj, & + use_cond, moist_kappa) implicit none @@ -5648,6 +5740,7 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & integer, intent (in) :: is, ie, ks, ke logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj + logical, intent (in) :: use_cond, moist_kappa real, intent (in) :: dtm @@ -5660,6 +5753,13 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & real, intent (inout), dimension (is:, ks:) :: q_con, cappa + real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -5699,7 +5799,11 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & - prefluxi, prefluxs, prefluxg, last_step, .true., do_sat_adj, .false.) + prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, .true., do_sat_adj, .false., & + use_cond, moist_kappa) end subroutine fast_sat_adj @@ -5707,8 +5811,8 @@ end subroutine fast_sat_adj ! rain freezing to form graupel, simple version ! ======================================================================= -subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & - lcpk, icpk, tcpk, tcp3) +subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppfr, convt) implicit none @@ -5718,7 +5822,9 @@ subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp real (kind = r8), intent (in), dimension (ks:ke) :: te8 @@ -5727,6 +5833,8 @@ subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppfr + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -5745,6 +5853,7 @@ subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & sink = (- tc * 0.025) ** 2 * qr (k) sink = min (qr (k), sink, - fac_r2g * tc / icpk (k)) + mppfr = mppfr + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & @@ -5760,8 +5869,8 @@ end subroutine pgfr_simp ! snow melting to form cloud water and rain, simple version ! ======================================================================= -subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & - lcpk, icpk, tcpk, tcp3) +subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppms, convt) implicit none @@ -5771,15 +5880,19 @@ subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt real (kind = r8), intent (in), dimension (ks:ke) :: te8 + real, intent (in), dimension (ks:ke) :: dp + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + real, intent (inout) :: mppms + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -5799,6 +5912,7 @@ subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & sink = (tc * 0.1) ** 2 * qs (k) sink = min (qs (k), sink, fac_smlt * tc / icpk (k)) tmp = min (sink, dim (qs_mlt, ql (k))) + mppms = mppms + sink * dp (k) * convt call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & @@ -5814,7 +5928,7 @@ end subroutine psmlt_simp ! cloud water to rain autoconversion, simple version ! ======================================================================= -subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg) +subroutine praut_simp (ks, ke, dts, dp, tz, qv, ql, qr, qi, qs, qg, mppar, convt) implicit none @@ -5824,12 +5938,16 @@ subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg) integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppar + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -5847,6 +5965,7 @@ subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg) if (tc .gt. 0 .and. ql (k) .gt. ql0_max) then sink = fac_l2r * (ql (k) - ql0_max) + mppar = mppar + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) @@ -5861,7 +5980,7 @@ end subroutine praut_simp ! cloud ice to snow autoconversion, simple version ! ======================================================================= -subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) +subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, dp, tz, den, mppas, convt) implicit none @@ -5871,14 +5990,16 @@ subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) integer, intent (in) :: ks, ke - real, intent (in) :: dts + real, intent (in) :: dts, convt - real, intent (in), dimension (ks:ke) :: den + real, intent (in), dimension (ks:ke) :: den, dp real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real (kind = r8), intent (inout), dimension (ks:ke) :: tz + real, intent (inout) :: mppas + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- @@ -5898,6 +6019,7 @@ subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) if (tc .lt. 0. .and. qi (k) .gt. qim) then sink = fac_i2s * (qi (k) - qim) + mppas = mppas + sink * dp (k) * convt call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, sink, 0.) @@ -5913,7 +6035,7 @@ end subroutine psaut_simp ! ======================================================================= subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, & - qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, cld, cloud, snowd, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, cld, cloud, & cnvw, cnvi, cnvc) implicit none @@ -5924,7 +6046,7 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, integer, intent (in) :: is, ie, ks, ke - real, intent (in), dimension (is:ie) :: lsm, snowd + real, intent (in), dimension (is:ie) :: lsm real, intent (in), dimension (is:ie, ks:ke) :: delp, t, p, cloud real, intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa @@ -6097,27 +6219,6 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, endif - if (rewflag .eq. 3) then - - ! ----------------------------------------------------------------------- - ! cloud water (Kiehl et al. 1994) - ! ----------------------------------------------------------------------- - - if (qmw (i, k) .gt. qcmin) then - qcw (i, k) = dpg * qmw (i, k) * 1.0e3 - rew (i, k) = 14.0 * abs (mask - 1.0) + & - (8.0 + (14.0 - 8.0) * min (1.0, max (0.0, - tc / 30.0))) * & - (1.0 - abs (mask - 1.0)) - rew (i, k) = rew (i, k) + (14.0 - rew (i, k)) * & - min (1.0, max (0.0, snowd (i) / 1000.0)) - rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) - else - qcw (i, k) = 0.0 - rew (i, k) = rewmin - endif - - endif - if (rewflag .eq. 4) then ! ----------------------------------------------------------------------- @@ -6747,32 +6848,32 @@ subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & real (kind = r8), dimension (ks:ke) :: cvm - do k = ks, ke - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - q_cond = q_liq (k) + q_sol (k) - con_r8 = one_r8 - (qv (k) + q_cond) - if (moist_q) then - cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k)) - else - cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) - endif - te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air - if (hydrostatic) then - te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2) - else - te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) - endif - te (k) = rgrav * te (k) * delp (k) - tw (k) = rgrav * (qv (k) + q_cond) * delp (k) - enddo - te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) - tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 - - if (present (te_loss)) then - ! total energy change due to sedimentation and its heating - te_loss = dte - endif + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qv (k) + q_cond) + if (moist_q) then + cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k)) + else + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + endif + te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air + if (hydrostatic) then + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2) + else + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) + endif + te (k) = rgrav * te (k) * delp (k) + tw (k) = rgrav * (qv (k) + q_cond) * delp (k) + enddo + te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) + tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 + + if (present (te_loss)) then + ! total energy change due to sedimentation and its heating + te_loss = dte + endif end subroutine mtetw diff --git a/model/intermediate_phys.F90 b/model/intermediate_phys.F90 index b262f7b98..e629d4e20 100644 --- a/model/intermediate_phys.F90 +++ b/model/intermediate_phys.F90 @@ -34,13 +34,14 @@ module intermediate_phys_mod #endif use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, inline_mp_type + use fv_arrays_mod, only: fv_thermo_type use mpp_domains_mod, only: domain2d, mpp_update_domains use tracer_manager_mod, only: get_tracer_index, get_tracer_names use field_manager_mod, only: model_atmos use gfdl_mp_mod, only: gfdl_mp_driver, fast_sat_adj, mtetw - + implicit none - + private real, parameter :: consv_min = 0.001 @@ -50,24 +51,24 @@ module intermediate_phys_mod ! ----------------------------------------------------------------------- ! precision definition ! ----------------------------------------------------------------------- - + integer, parameter :: r8 = 8 ! double precision - + contains subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, & - c2l_ord, mdt, consv, akap, ptop, pfull, hs, te0_2d, u, v, w, pt, & + mdt, consv, akap, ptop, pfull, hs, te0_2d, u, v, w, pt, & delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, inline_mp, & - gridstruct, domain, bd, hydrostatic, do_adiabatic_init, & + gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, & do_inline_mp, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, c2l_ord, nwat + integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat logical, intent (in) :: hydrostatic, do_adiabatic_init, do_inline_mp, consv_checker logical, intent (in) :: do_sat_adj, last_step, do_fast_phys @@ -80,9 +81,9 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, real, intent (in), dimension (isd:ied, jsd:jed) :: hs real, intent (inout), dimension (is:, js:, 1:) :: delz - + real, intent (inout), dimension (isd:, jsd:, 1:) :: q_con, cappa, w - + real, intent (inout), dimension (is:ie, js:je) :: te0_2d real, intent (inout), dimension (isd:ied, jsd:jed, km) :: pt, delp @@ -97,6 +98,8 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, type (fv_grid_type), intent (in), target :: gridstruct + type (fv_thermo_type), intent (in), target :: thermostruct + type (fv_grid_bounds_type), intent (in) :: bd type (domain2d), intent (inout) :: domain @@ -111,6 +114,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, integer :: i, j, k, m, kmp, sphum, liq_wat, ice_wat integer :: rainwat, snowwat, graupel, cld_amt, ccn_cm3, cin_cm3, aerosol + integer :: k_con, k_cappa real :: rrg @@ -127,13 +131,13 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, real, allocatable, dimension (:,:) :: dz, wa real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0 - + real (kind = r8), allocatable, dimension (:) :: tz real (kind = r8), dimension (is:ie) :: te_b_beg, te_b_end, tw_b_beg, tw_b_end, dte, te_loss real (kind = r8), dimension (is:ie, 1:km) :: te_beg, te_end, tw_beg, tw_end - + character (len = 32) :: tracer_units, tracer_name sphum = get_tracer_index (model_atmos, 'sphum') @@ -173,6 +177,16 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, enddo endif + if (thermostruct%use_cond) then + k_con = kmp + else + k_con = 1 + endif + if (thermostruct%moist_kappa) then + k_cappa = kmp + else + k_cappa = 1 + endif !----------------------------------------------------------------------- ! Fast Saturation Adjustment >>> !----------------------------------------------------------------------- @@ -191,7 +205,8 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, !$OMP sphum, pkz, last_step, consv, te0_2d, gridstruct, & !$OMP q, mdt, cld_amt, cappa, rrg, akap, ccn_cm3, & !$OMP cin_cm3, aerosol, do_sat_adj, adj_mass_vmr, & -!$OMP conv_vmr_mmr, nq, consv_checker, te_err, tw_err) & +!$OMP conv_vmr_mmr, nq, consv_checker, te_err, tw_err, & +!$OMP inline_mp,k_con,k_cappa,thermostruct) & !$OMP private (q2, q3, gsize, dz, pe, peln, adj_vmr, qliq, qsol, & !$OMP tz, wz, dte, te_beg, tw_beg, te_b_beg, tw_b_beg, & !$OMP te_end, tw_end, te_b_end, tw_b_end, te_loss) @@ -214,7 +229,29 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, else q3 (is:ie, kmp:km) = 0.0 endif - + + ! initialize tendencies diagnostic + if (allocated (inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt (is:ie, j, kmp:km) = & + inline_mp%liq_wat_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, liq_wat) + if (allocated (inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt (is:ie, j, kmp:km) = & + inline_mp%ice_wat_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, ice_wat) + if (allocated (inline_mp%qv_dt)) inline_mp%qv_dt (is:ie, j, kmp:km) = & + inline_mp%qv_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, sphum) + if (allocated (inline_mp%ql_dt)) inline_mp%ql_dt (is:ie, j, kmp:km) = & + inline_mp%ql_dt (is:ie, j, kmp:km) - (q (is:ie, j, kmp:km, liq_wat) + & + q (is:ie, j, kmp:km, rainwat)) + if (allocated (inline_mp%qi_dt)) inline_mp%qi_dt (is:ie, j, kmp:km) = & + inline_mp%qi_dt (is:ie, j, kmp:km) - (q (is:ie, j, kmp:km, ice_wat) + & + q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel)) + if (allocated (inline_mp%qr_dt)) inline_mp%qr_dt (is:ie, j, kmp:km) = & + inline_mp%qr_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, rainwat) + if (allocated (inline_mp%qs_dt)) inline_mp%qs_dt (is:ie, j, kmp:km) = & + inline_mp%qs_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, snowwat) + if (allocated (inline_mp%qg_dt)) inline_mp%qg_dt (is:ie, j, kmp:km) = & + inline_mp%qg_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, graupel) + if (allocated (inline_mp%t_dt)) inline_mp%t_dt (is:ie, j, kmp:km) = & + inline_mp%t_dt (is:ie, j, kmp:km) - pt (is:ie, j, kmp:km) + ! total energy checker if (consv_checker) then qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat) @@ -262,17 +299,18 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, q (is:ie, j, kmp:km, graupel), q (is:ie, j, kmp:km, cld_amt), & q2 (is:ie, kmp:km), q3 (is:ie, kmp:km), hs (is:ie, j), & dz (is:ie, kmp:km), pt (is:ie, j, kmp:km), delp (is:ie, j, kmp:km), & -#ifdef USE_COND - q_con (is:ie, j, kmp:km), & -#else - q_con (isd:, jsd, 1:), & -#endif -#ifdef MOIST_CAPPA - cappa (is:ie, j, kmp:km), & -#else - cappa (isd:, jsd, 1:), & -#endif - gsize, last_step, do_sat_adj) + q_con (is:ie, j, k_con:), cappa (is:ie, j, k_cappa:), & + gsize, inline_mp%mppcw (is:ie, j), inline_mp%mppew (is:ie, j), inline_mp%mppe1 (is:ie, j), & + inline_mp%mpper (is:ie, j), inline_mp%mppdi (is:ie, j), inline_mp%mppd1 (is:ie, j), & + inline_mp%mppds (is:ie, j), inline_mp%mppdg (is:ie, j), inline_mp%mppsi (is:ie, j), & + inline_mp%mpps1 (is:ie, j), inline_mp%mppss (is:ie, j), inline_mp%mppsg (is:ie, j), & + inline_mp%mppfw (is:ie, j), inline_mp%mppfr (is:ie, j), inline_mp%mppmi (is:ie, j), & + inline_mp%mppms (is:ie, j), inline_mp%mppmg (is:ie, j), inline_mp%mppm1 (is:ie, j), & + inline_mp%mppm2 (is:ie, j), inline_mp%mppm3 (is:ie, j), inline_mp%mppar (is:ie, j), & + inline_mp%mppas (is:ie, j), inline_mp%mppag (is:ie, j), inline_mp%mpprs (is:ie, j), & + inline_mp%mpprg (is:ie, j), inline_mp%mppxr (is:ie, j), inline_mp%mppxs (is:ie, j), & + inline_mp%mppxg (is:ie, j), last_step, do_sat_adj, & + thermostruct%use_cond, thermostruct%moist_kappa) ! update non-microphyiscs tracers due to mass change if (adj_mass_vmr .gt. 0) then @@ -283,18 +321,40 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, enddo endif + ! tendencies diagnostic + if (allocated (inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt (is:ie, j, kmp:km) = & + inline_mp%liq_wat_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, liq_wat) + if (allocated (inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt (is:ie, j, kmp:km) = & + inline_mp%ice_wat_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, ice_wat) + if (allocated (inline_mp%qv_dt)) inline_mp%qv_dt (is:ie, j, kmp:km) = & + inline_mp%qv_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, sphum) + if (allocated (inline_mp%ql_dt)) inline_mp%ql_dt (is:ie, j, kmp:km) = & + inline_mp%ql_dt (is:ie, j, kmp:km) + (q (is:ie, j, kmp:km, liq_wat) + & + q (is:ie, j, kmp:km, rainwat)) + if (allocated (inline_mp%qi_dt)) inline_mp%qi_dt (is:ie, j, kmp:km) = & + inline_mp%qi_dt (is:ie, j, kmp:km) + (q (is:ie, j, kmp:km, ice_wat) + & + q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel)) + if (allocated (inline_mp%qr_dt)) inline_mp%qr_dt (is:ie, j, kmp:km) = & + inline_mp%qr_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, rainwat) + if (allocated (inline_mp%qs_dt)) inline_mp%qs_dt (is:ie, j, kmp:km) = & + inline_mp%qs_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, snowwat) + if (allocated (inline_mp%qg_dt)) inline_mp%qg_dt (is:ie, j, kmp:km) = & + inline_mp%qg_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, graupel) + if (allocated (inline_mp%t_dt)) inline_mp%t_dt (is:ie, j, kmp:km) = & + inline_mp%t_dt (is:ie, j, kmp:km) + pt (is:ie, j, kmp:km) + ! update pkz if (.not. hydrostatic) then -#ifdef MOIST_CAPPA - pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * & - log (rrg * delp (is:ie, j, kmp:km) / & - delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) -#else - pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / & - delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) -#endif + if (thermostruct%moist_kappa) then + pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * & + log (rrg * delp (is:ie, j, kmp:km) / & + delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) + else + pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / & + delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) + endif endif - + ! total energy checker if (consv_checker) then qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat) @@ -394,7 +454,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, ! D grid wind to A grid wind remap call cubed_to_latlon (u, v, ua, va, gridstruct, npx, npy, km, 1, gridstruct%grid_type, & - domain, gridstruct%bounded_domain, c2l_ord, bd) + domain, gridstruct%bounded_domain, 4, bd) ! save delp if (consv .gt. consv_min) then @@ -412,7 +472,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, !$OMP gridstruct, q, mdt, cld_amt, cappa, rrg, akap, & !$OMP ccn_cm3, cin_cm3, inline_mp, do_inline_mp, consv_checker, & !$OMP u_dt, v_dt, aerosol, adj_mass_vmr, conv_vmr_mmr, nq, & -!$OMP te_err, tw_err) & +!$OMP te_err, tw_err, k_con, k_cappa, thermostruct) & !$OMP private (q2, q3, gsize, dz, wa, pe, peln, adj_vmr, qliq, qsol, & !$OMP tz, wz, dte, te_beg, tw_beg, te_b_beg, tw_b_beg, & !$OMP te_end, tw_end, te_b_end, tw_b_end, te_loss) @@ -435,7 +495,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, else q3 (is:ie, kmp:km) = 0.0 endif - + ! note: ua and va are A-grid variables ! note: pt is virtual temperature at this point ! note: w is vertical velocity (m/s) @@ -530,21 +590,22 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, inline_mp%prew (is:ie, j), inline_mp%prer (is:ie, j), & inline_mp%prei (is:ie, j), inline_mp%pres (is:ie, j), & inline_mp%preg (is:ie, j), hydrostatic, is, ie, kmp, km, & -#ifdef USE_COND - q_con (is:ie, j, kmp:km), & -#else - q_con (isd:, jsd, 1:), & -#endif -#ifdef MOIST_CAPPA - cappa (is:ie, j, kmp:km), & -#else - cappa (isd:, jsd, 1:), & -#endif + q_con (is:ie, j, k_con:), cappa (is:ie, j, k_cappa:), & consv .gt. consv_min, adj_vmr (is:ie, kmp:km), te (is:ie, j, kmp:km), dte (is:ie), & inline_mp%prefluxw(is:ie, j, kmp:km), & inline_mp%prefluxr(is:ie, j, kmp:km), inline_mp%prefluxi(is:ie, j, kmp:km), & inline_mp%prefluxs(is:ie, j, kmp:km), inline_mp%prefluxg(is:ie, j, kmp:km), & - last_step, do_inline_mp) + inline_mp%mppcw (is:ie, j), inline_mp%mppew (is:ie, j), inline_mp%mppe1 (is:ie, j), & + inline_mp%mpper (is:ie, j), inline_mp%mppdi (is:ie, j), inline_mp%mppd1 (is:ie, j), & + inline_mp%mppds (is:ie, j), inline_mp%mppdg (is:ie, j), inline_mp%mppsi (is:ie, j), & + inline_mp%mpps1 (is:ie, j), inline_mp%mppss (is:ie, j), inline_mp%mppsg (is:ie, j), & + inline_mp%mppfw (is:ie, j), inline_mp%mppfr (is:ie, j), inline_mp%mppmi (is:ie, j), & + inline_mp%mppms (is:ie, j), inline_mp%mppmg (is:ie, j), inline_mp%mppm1 (is:ie, j), & + inline_mp%mppm2 (is:ie, j), inline_mp%mppm3 (is:ie, j), inline_mp%mppar (is:ie, j), & + inline_mp%mppas (is:ie, j), inline_mp%mppag (is:ie, j), inline_mp%mpprs (is:ie, j), & + inline_mp%mpprg (is:ie, j), inline_mp%mppxr (is:ie, j), inline_mp%mppxs (is:ie, j), & + inline_mp%mppxg (is:ie, j), last_step, do_inline_mp, & + thermostruct%use_cond, thermostruct%moist_kappa) ! update non-microphyiscs tracers due to mass change if (adj_mass_vmr .gt. 0) then @@ -597,16 +658,16 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, ! update pkz if (.not. hydrostatic) then -#ifdef MOIST_CAPPA - pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * & - log (rrg * delp (is:ie, j, kmp:km) / & - delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) -#else - pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / & - delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) -#endif + if (thermostruct%moist_kappa) then + pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * & + log (rrg * delp (is:ie, j, kmp:km) / & + delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) + else + pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / & + delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km))) + endif endif - + ! total energy checker if (consv_checker) then qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat) @@ -677,8 +738,6 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, call mpp_update_domains (u_dt, domain, complete=.false.) call mpp_update_domains (v_dt, domain, complete=.true.) endif - ! update u_dt and v_dt in halo - call mpp_update_domains (u_dt, v_dt, domain) ! update D grid wind call update_dwinds_phys (is, ie, js, je, isd, ied, jsd, jed, abs (mdt), u_dt, v_dt, u, v, & diff --git a/model/nh_core.F90 b/model/nh_core.F90 index ad284c41d..72fbe525c 100644 --- a/model/nh_core.F90 +++ b/model/nh_core.F90 @@ -48,8 +48,9 @@ subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & isd, ied, jsd, jed, akap, cappa, cp, & ptop, zs, q_con, w, delz, pt, & delp, zh, pe, ppe, pk3, pk, peln, & - ws, scale_m, p_fac, a_imp, & - use_logp, last_call, fp_out, d2bg_zq, debug, fast_tau_w_sec) + ws, p_fac, a_imp, & + use_logp, use_cond, moist_kappa, last_call, & + fp_out, d2bg_zq, debug, fast_tau_w_sec) !-------------------------------------------- ! !OUTPUT PARAMETERS ! Ouput: gz: grav*height at edges @@ -59,9 +60,9 @@ subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & integer, intent(in):: ms, is, ie, js, je, km, ng integer, intent(in):: isd, ied, jsd, jed real, intent(in):: dt ! the BIG horizontal Lagrangian time step - real, intent(in):: akap, cp, ptop, p_fac, a_imp, scale_m, d2bg_zq, fast_tau_w_sec + real, intent(in):: akap, cp, ptop, p_fac, a_imp, d2bg_zq, fast_tau_w_sec real, intent(in):: zs(isd:ied,jsd:jed) - logical, intent(in):: last_call, use_logp, fp_out, debug + logical, intent(in):: last_call, use_logp, fp_out, use_cond, moist_kappa, debug real, intent(in):: ws(is:ie,js:je) real, intent(in), dimension(isd:,jsd:,1:):: q_con, cappa real, intent(in), dimension(isd:ied,jsd:jed,km):: delp, pt @@ -78,6 +79,7 @@ subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & real, dimension(is:ie,km+1)::pem, pe2, peln2, peg, pelng real gama, rgrav, ptk, peln1 integer i, j, k + real, parameter :: scale_m = 0.0 ! diff_z = scale_m**2 * 0.25 gama = 1./(1.-akap) rgrav = 1./grav @@ -85,60 +87,84 @@ subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & ptk = exp(akap*peln1) !$OMP parallel do default(none) shared(is,ie,js,je,km,delp,ptop,peln1,pk3,ptk,akap,rgrav,zh,pt, & -!$OMP w,a_imp,dt,gama,ws,p_fac,scale_m,ms,delz,last_call, & -!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con,d2bg_zq,debug,fast_tau_w_sec ) & +!$OMP w,a_imp,dt,gama,ws,p_fac,ms,delz,last_call, & +!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con,& +!$OMP use_cond,moist_kappa,d2bg_zq,debug,fast_tau_w_sec ) & !$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2) do 2000 j=js, je - do k=1,km + if (moist_kappa) then + do k=1,km do i=is, ie dm(i,k) = delp(i,j,k) -#ifdef MOIST_CAPPA cp2(i,k) = cappa(i,j,k) -#endif enddo - enddo + enddo + else + do k=1,km + do i=is, ie + dm(i,k) = delp(i,j,k) + cp2(i,k) = akap + enddo + enddo + endif - do i=is,ie - pem(i,1) = ptop - peln2(i,1) = peln1 - pk3(i,j,1) = ptk -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,km+1 + if (use_cond) then do i=is,ie - pem(i,k) = pem(i,k-1) + dm(i,k-1) - peln2(i,k) = log(pem(i,k)) -#ifdef USE_COND -! Excluding contribution from condensates: -! peln used during remap; pk3 used only for p_grad - peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - pk3(i,j,k) = exp(akap*peln2(i,k)) + pem(i,1) = ptop + peln2(i,1) = peln1 + pk3(i,j,1) = ptk + peg(i,1) = ptop + pelng(i,1) = peln1 enddo - enddo + do k=2,km+1 + do i=is,ie + pem(i,k) = pem(i,k-1) + dm(i,k-1) + peln2(i,k) = log(pem(i,k)) + ! Excluding contribution from condensates: + ! peln used during remap; pk3 used only for p_grad + peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) + pelng(i,k) = log(peg(i,k)) + pk3(i,j,k) = exp(akap*peln2(i,k)) + enddo + enddo + else + do i=is,ie + pem(i,1) = ptop + peln2(i,1) = peln1 + pk3(i,j,1) = ptk + enddo + do k=2,km+1 + do i=is,ie + pem(i,k) = pem(i,k-1) + dm(i,k-1) + peln2(i,k) = log(pem(i,k)) + pk3(i,j,k) = exp(akap*peln2(i,k)) + enddo + enddo + endif - do k=1,km + if (use_cond) then + do k=1,km do i=is, ie -#ifdef USE_COND pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) - -#ifdef MOIST_CAPPA gm2(i,k) = 1. / (1.-cp2(i,k)) -#endif - -#else + dm(i,k) = dm(i,k) * rgrav + dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) + w2(i,k) = w(i,j,k) + enddo + enddo + else + do k=1,km + do i=is, ie pm2(i,k) = dm(i,k)/(peln2(i,k+1)-peln2(i,k)) -#endif + gm2(i,k) = 1. / (1.-cp2(i,k)) dm(i,k) = dm(i,k) * rgrav dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) w2(i,k) = w(i,j,k) enddo - enddo + enddo + endif + if ( a_imp < -0.999 ) then call SIM3p0_solver(dt, is, ie, km, rdgas, gama, akap, pe2, dm, & diff --git a/model/nh_utils.F90 b/model/nh_utils.F90 index 957b925c9..0649380b8 100644 --- a/model/nh_utils.F90 +++ b/model/nh_utils.F90 @@ -322,18 +322,20 @@ end subroutine update_dz_d subroutine Riem_Solver_c(ms, dt, is, ie, js, je, km, ng, & akap, cappa, cp, ptop, hs, w3, pt, q_con, & - delp, gz, pef, ws, p_fac, a_imp, scale_m, & + delp, gz, pef, ws, p_fac, a_imp, & + use_cond, moist_kappa, & pfull, fast_tau_w_sec, rf_cutoff) integer, intent(in):: is, ie, js, je, ng, km integer, intent(in):: ms - real, intent(in):: dt, akap, cp, ptop, p_fac, a_imp, scale_m, fast_tau_w_sec, rf_cutoff + real, intent(in):: dt, akap, cp, ptop, p_fac, a_imp, fast_tau_w_sec, rf_cutoff real, intent(in):: ws(is-ng:ie+ng,js-ng:je+ng) real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delp real, intent(in), dimension(is-ng:,js-ng:,1:):: q_con, cappa real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng) real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: w3 real, intent(in) :: pfull(km) + logical, intent(in) :: use_cond, moist_kappa ! OUTPUT PARAMETERS real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: gz real, intent( out), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: pef @@ -344,6 +346,7 @@ subroutine Riem_Solver_c(ms, dt, is, ie, js, je, km, ng, & real(kind=8) :: rff_temp integer i, j, k integer is1, ie1 + real, parameter :: scale_m = 0.0 ! diff_z = scale_m**2 * 0.25 gama = 1./(1.-akap) rgrav = 1./grav @@ -366,7 +369,8 @@ subroutine Riem_Solver_c(ms, dt, is, ie, js, je, km, ng, & !$OMP parallel do default(none) shared(js,je,is1,ie1,km,delp,pef,ptop,gz,rgrav,w3,pt, & -!$OMP a_imp,dt,gama,akap,ws,p_fac,scale_m,ms,hs,q_con,cappa,fast_tau_w_sec) & +!$OMP a_imp,dt,gama,akap,ws,p_fac,ms,hs,q_con,cappa, & +!$OMP use_cond,moist_kappa,fast_tau_w_sec) & !$OMP private(cp2,gm2, dm, dz2, w2, pm2, pe2, pem, peg) do 2000 j=js-1, je+1 @@ -376,42 +380,71 @@ subroutine Riem_Solver_c(ms, dt, is, ie, js, je, km, ng, & enddo enddo - do i=is1, ie1 - pef(i,j,1) = ptop ! full pressure at top - pem(i,1) = ptop -#ifdef USE_COND - peg(i,1) = ptop -#endif - enddo - - do k=2,km+1 + if (use_cond) then do i=is1, ie1 - pem(i,k) = pem(i,k-1) + dm(i,k-1) -#ifdef USE_COND -! Excluding contribution from condensates: - peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) -#endif + pef(i,j,1) = ptop ! full pressure at top + pem(i,1) = ptop + peg(i,1) = ptop enddo - enddo - do k=1,km + do k=2,km+1 + do i=is1, ie1 + pem(i,k) = pem(i,k-1) + dm(i,k-1) + ! Excluding contribution from condensates: + peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) + enddo + enddo + + else do i=is1, ie1 - dz2(i,k) = gz(i,j,k+1) - gz(i,j,k) -#ifdef USE_COND - pm2(i,k) = (peg(i,k+1)-peg(i,k))/log(peg(i,k+1)/peg(i,k)) + pef(i,j,1) = ptop ! full pressure at top + pem(i,1) = ptop + enddo -#ifdef MOIST_CAPPA - cp2(i,k) = cappa(i,j,k) - gm2(i,k) = 1. / (1.-cp2(i,k)) -#endif + do k=2,km+1 + do i=is1, ie1 + pem(i,k) = pem(i,k-1) + dm(i,k-1) + enddo + enddo -#else + endif + + if (use_cond) then + if (moist_kappa) then + do k=1,km + do i=is1, ie1 + dz2(i,k) = gz(i,j,k+1) - gz(i,j,k) + pm2(i,k) = (peg(i,k+1)-peg(i,k))/log(peg(i,k+1)/peg(i,k)) + cp2(i,k) = cappa(i,j,k) + gm2(i,k) = 1. / (1.-cp2(i,k)) + dm(i,k) = dm(i,k) * rgrav + w2(i,k) = w3(i,j,k) + enddo + enddo + else + do k=1,km + do i=is1, ie1 + dz2(i,k) = gz(i,j,k+1) - gz(i,j,k) + pm2(i,k) = (peg(i,k+1)-peg(i,k))/log(peg(i,k+1)/peg(i,k)) + cp2(i,k) = akap + gm2(i,k) = 1. / (1.-cp2(i,k)) + dm(i,k) = dm(i,k) * rgrav + w2(i,k) = w3(i,j,k) + enddo + enddo + endif !moist_kappa + else + do k=1,km + do i=is1, ie1 + dz2(i,k) = gz(i,j,k+1) - gz(i,j,k) pm2(i,k) = dm(i,k)/log(pem(i,k+1)/pem(i,k)) -#endif + cp2(i,k) = akap + gm2(i,k) = 1. / (1.-cp2(i,k)) dm(i,k) = dm(i,k) * rgrav w2(i,k) = w3(i,j,k) enddo - enddo + enddo + endif !use_cond if ( a_imp < -0.01 ) then @@ -453,7 +486,8 @@ subroutine Riem_Solver3test(ms, dt, is, ie, js, je, km, ng, & isd, ied, jsd, jed, akap, cappa, cp, & ptop, zs, q_con, w, delz, pt, & delp, zh, pe, ppe, pk3, pk, peln, & - ws, scale_m, p_fac, a_imp, & + ws, p_fac, a_imp, & + use_cond, moist_kappa, & use_logp, last_call, fp_out) !-------------------------------------------- ! !OUTPUT PARAMETERS @@ -464,9 +498,10 @@ subroutine Riem_Solver3test(ms, dt, is, ie, js, je, km, ng, & integer, intent(in):: ms, is, ie, js, je, km, ng integer, intent(in):: isd, ied, jsd, jed real, intent(in):: dt ! the BIG horizontal Lagrangian time step - real, intent(in):: akap, cp, ptop, p_fac, a_imp, scale_m + real, intent(in):: akap, cp, ptop, p_fac, a_imp real, intent(in):: zs(isd:ied,jsd:jed) logical, intent(in):: last_call, use_logp, fp_out + logical, intent(in) :: use_cond, moist_kappa real, intent(in):: ws(is:ie,js:je) real, intent(in), dimension(isd:,jsd:,1:):: q_con, cappa real, intent(in), dimension(isd:ied,jsd:jed,km):: delp, pt @@ -483,6 +518,7 @@ subroutine Riem_Solver3test(ms, dt, is, ie, js, je, km, ng, & real, dimension(is:ie,km+1)::pem, pe2, peln2, peg, pelng real gama, rgrav, ptk, peln1 integer i, j, k + real, parameter :: scale_m = 0.0 ! diff_z = scale_m**2 * 0.25 gama = 1./(1.-akap) rgrav = 1./grav @@ -490,60 +526,93 @@ subroutine Riem_Solver3test(ms, dt, is, ie, js, je, km, ng, & ptk = exp(akap*peln1) !$OMP parallel do default(none) shared(is,ie,js,je,km,delp,ptop,peln1,pk3,ptk,akap,rgrav,zh,pt, & -!$OMP w,a_imp,dt,gama,ws,p_fac,scale_m,ms,delz,last_call, & -!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con ) & +!$OMP w,a_imp,dt,gama,ws,p_fac,ms,delz,last_call, & +!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa, & +!$OMP q_con,use_cond,moist_kappa ) & !$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2) do 2000 j=js, je - do k=1,km + if (moist_kappa) then + do k=1,km do i=is, ie dm(i,k) = delp(i,j,k) -#ifdef MOIST_CAPPA cp2(i,k) = cappa(i,j,k) -#endif enddo - enddo + enddo + else + do k=1,km + do i=is, ie + dm(i,k) = delp(i,j,k) + enddo + enddo + endif - do i=is,ie - pem(i,1) = ptop - peln2(i,1) = peln1 - pk3(i,j,1) = ptk -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,km+1 + if (use_cond) then + do i=is,ie + pem(i,1) = ptop + peln2(i,1) = peln1 + pk3(i,j,1) = ptk + peg(i,1) = ptop + pelng(i,1) = peln1 + enddo + do k=2,km+1 do i=is,ie pem(i,k) = pem(i,k-1) + dm(i,k-1) peln2(i,k) = log(pem(i,k)) -#ifdef USE_COND ! Excluding contribution from condensates: ! peln used during remap; pk3 used only for p_grad peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) pelng(i,k) = log(peg(i,k)) -#endif pk3(i,j,k) = exp(akap*peln2(i,k)) enddo - enddo - - do k=1,km + enddo + else + do i=is,ie + pem(i,1) = ptop + peln2(i,1) = peln1 + pk3(i,j,1) = ptk + enddo + do k=2,km+1 + do i=is,ie + pem(i,k) = pem(i,k-1) + dm(i,k-1) + peln2(i,k) = log(pem(i,k)) + pk3(i,j,k) = exp(akap*peln2(i,k)) + enddo + enddo + endif !use_cond + + if (use_cond) then + if (moist_kappa) then + do k=1,km + do i=is, ie + pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) + gm2(i,k) = 1. / (1.-cp2(i,k)) + dm(i,k) = dm(i,k) * rgrav + dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) + w2(i,k) = w(i,j,k) + enddo + enddo + else + do k=1,km + do i=is, ie + pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) + dm(i,k) = dm(i,k) * rgrav + dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) + w2(i,k) = w(i,j,k) + enddo + enddo + endif !moist_kappa + else + do k=1,km do i=is, ie -#ifdef USE_COND - pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) - -#ifdef MOIST_CAPPA - gm2(i,k) = 1. / (1.-cp2(i,k)) -#endif - -#else pm2(i,k) = dm(i,k)/(peln2(i,k+1)-peln2(i,k)) -#endif dm(i,k) = dm(i,k) * rgrav dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) w2(i,k) = w(i,j,k) enddo - enddo + enddo + endif !use_cond + if ( a_imp < -0.999 ) then call SIM3p0_solver(dt, is, ie, km, rdgas, gama, akap, pe2, dm, & @@ -730,14 +799,8 @@ subroutine RIM_2D(ms, bdt, is, ie, km, rgas, gama, gm2, pe2, & ! Continuity of (pbar, wbar) is maintained do k=1, km rden = -rgas*dm(k)/dz(k) -#ifdef MOIST_CAPPA pf1(k) = exp( gm2(i,k)*log(rden*pt1(k)) ) -! dts(k) = -dz(k)/sqrt(gm2(i,k)*rgas*pf1(k)/rden) dts(k) = -dz(k)/sqrt(grg*pf1(k)/rden) -#else - pf1(k) = exp( gama*log(rden*pt1(k)) ) - dts(k) = -dz(k)/sqrt(grg*pf1(k)/rden) -#endif if ( bdt > dts(k) ) then ks0 = k-1 goto 222 @@ -796,14 +859,8 @@ subroutine RIM_2D(ms, bdt, is, ie, km, rgas, gama, gm2, pe2, & do k=ks1, km rden = -rgas*dm(k)/dz(k) -#ifdef MOIST_CAPPA pf = exp( gm2(i,k)*log(rden*pt1(k)) ) -! dts(k) = -dz(k) / sqrt( gm2(i,k)*rgas*pf/rden ) dts(k) = -dz(k) / sqrt( grg*pf/rden ) -#else - pf = exp( gama*log(rden*pt1(k)) ) - dts(k) = -dz(k) / sqrt( grg*pf/rden ) -#endif ptmp1 = dts(k)*(pf - pm2(i,k)) r_lo(k) = wm(k) + ptmp1 r_hi(k) = wm(k) - ptmp1 @@ -1233,21 +1290,13 @@ subroutine SIM1_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe, dm2, real t1g, rdt, capa1 integer i, k -#ifdef MOIST_CAPPA t1g = 2.*dt*dt -#else - t1g = gama * 2.*dt*dt -#endif rdt = 1. / dt capa1 = kappa - 1. do k=1,km do i=is, ie -#ifdef MOIST_CAPPA pe(i,k) = exp(gm2(i,k)*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#else - pe(i,k) = exp(gama*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#endif w1(i,k) = w2(i,k) enddo enddo @@ -1285,11 +1334,7 @@ subroutine SIM1_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe, dm2, ! Start the w-solver do k=2, km do i=is, ie -#ifdef MOIST_CAPPA aa(i,k) = t1g*0.5*(gm2(i,k-1)+gm2(i,k))/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)) -#else - aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)) -#endif enddo enddo do i=is, ie @@ -1304,11 +1349,7 @@ subroutine SIM1_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe, dm2, enddo enddo do i=is, ie -#ifdef MOIST_CAPPA p1(i) = t1g*gm2(i,km)/dz2(i,km)*(pem(i,km+1)) -#else - p1(i) = t1g/dz2(i,km)*(pem(i,km+1)) -#endif gam(i,km) = aa(i,km) / bet(i) bet(i) = dm2(i,km) - (aa(i,km)+p1(i) + aa(i,km)*gam(i,km)) w2(i,km) = (dm2(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-p1(i)*ws(i)-aa(i,km)*w2(i,km-1))/bet(i) @@ -1340,21 +1381,13 @@ subroutine SIM1_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe, dm2, do i=is, ie p1(i) = ( pe(i,km) + 2.*pe(i,km+1) )*r3 -#ifdef MOIST_CAPPA dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp((cp2(i,km)-1.)*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#else - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#endif enddo do k=km-1, 1, -1 do i=is, ie p1(i) = (pe(i,k) + bb(i,k)*pe(i,k+1) + g_rat(i,k)*pe(i,k+2))*r3 - g_rat(i,k)*p1(i) -#ifdef MOIST_CAPPA dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp((cp2(i,k)-1.)*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#else - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#endif enddo enddo @@ -1379,11 +1412,7 @@ subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe2, dm2, beta = 1. - alpha ra = 1. / alpha t2 = beta / alpha -#ifdef MOIST_CAPPA t1g = 2.*(alpha*dt)**2 -#else - t1g = 2.*gama*(alpha*dt)**2 -#endif rdt = 1. / dt capa1 = kappa - 1. @@ -1391,11 +1420,7 @@ subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe2, dm2, do i=is, ie w1(i,k) = w2(i,k) ! P_g perturbation -#ifdef MOIST_CAPPA pe2(i,k) = exp(gm2(i,k)*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#else - pe2(i,k) = exp(gama*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#endif enddo enddo @@ -1437,11 +1462,7 @@ subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe2, dm2, do k=2, km do i=is, ie -#ifdef MOIST_CAPPA aa(i,k) = t1g*0.5*(gm2(i,k-1)+gm2(i,k))/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#else - aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#endif wk(i,k) = t2*aa(i,k)*(w1(i,k-1)-w1(i,k)) aa(i,k) = aa(i,k) - scale_m*dm2(i,1) enddo @@ -1462,11 +1483,7 @@ subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe2, dm2, enddo ! Bottom: k=km do i=is, ie -#ifdef MOIST_CAPPA wk1(i) = t1g*gm2(i,km)/dz2(i,km)*pe2(i,km+1) -#else - wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) -#endif gam(i,km) = aa(i,km) / bet(i) bet(i) = dm2(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) w2(i,km) = (dm2(i,km)*w1(i,km) + dt*(pp(i,km+1)-pp(i,km)) - wk(i,km) + & @@ -1500,22 +1517,14 @@ subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, pe2, dm2, do i=is, ie p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 -#ifdef MOIST_CAPPA dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp((cp2(i,km)-1.)*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#else - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#endif enddo do k=km-1, 1, -1 do i=is, ie p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3 - g_rat(i,k)*p1(i) ! delz = -dm*R*T_m / p_gas -#ifdef MOIST_CAPPA dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp((cp2(i,k)-1.)*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#else - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#endif enddo enddo @@ -1753,31 +1762,23 @@ subroutine edge_profile1(q1, q1e, i1, i2, km, dp0, limiter) end subroutine edge_profile1 subroutine nh_bc(ptop, grav, kappa, cp, delp, delzBC, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & + q_con, cappa, pkc, gz, pk3, & BC_step, BC_split, & - npx, npy, npz, bounded_domain, pkc_pertn, computepk3, fullhalo, bd) + npx, npy, npz, bounded_domain, pkc_pertn, computepk3, fullhalo, & + use_cond, moist_kappa, bd) !INPUT: delp, delz (BC), pt !OUTPUT: gz, pkc, pk3 (optional) integer, intent(IN) :: npx, npy, npz logical, intent(IN) :: pkc_pertn, computepk3, fullhalo, bounded_domain + logical, intent(IN) :: use_cond, moist_kappa real, intent(IN) :: ptop, kappa, cp, grav, BC_step, BC_split type(fv_grid_bounds_type), intent(IN) :: bd real, intent(IN) :: phis(bd%isd:bd%ied,bd%jsd:bd%jed) real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: pt, delp type(fv_nest_BC_type_3d), intent(IN) :: delzBC -#ifdef USE_COND - real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: q_con -#ifdef MOIST_CAPPA - real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: cappa -#endif -#endif + real, intent(IN), dimension(bd%isd:,bd%jsd:,1:):: q_con + real, intent(INOUT), dimension(bd%isd:,bd%jsd:,1:):: cappa real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1):: gz, pkc, pk3 integer :: i,j,k @@ -1801,30 +1802,22 @@ subroutine nh_bc(ptop, grav, kappa, cp, delp, delzBC, pt, phis, & if (is == 1) then call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%west_t0, delzBC%west_t1, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif + q_con, cappa, & pkc, gz, pk3, & BC_step, BC_split, & - pkc_pertn, computepk3, isd, ied, isd, 0, isd, 0, jsd, jed, jsd, jed, npz) + pkc_pertn, computepk3, use_cond, moist_kappa, & + isd, ied, isd, 0, isd, 0, jsd, jed, jsd, jed, npz) endif if (ie == npx-1) then call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%east_t0, delzBC%east_t1, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif + q_con, cappa, & pkc, gz, pk3, & BC_step, BC_split, & - pkc_pertn, computepk3, isd, ied, npx, ied, npx, ied, jsd, jed, jsd, jed, npz) + pkc_pertn, computepk3, use_cond, moist_kappa, & + isd, ied, npx, ied, npx, ied, jsd, jed, jsd, jed, npz) endif @@ -1842,59 +1835,42 @@ subroutine nh_bc(ptop, grav, kappa, cp, delp, delzBC, pt, phis, & if (js == 1) then call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%south_t0, delzBC%south_t1, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif + q_con, cappa, & pkc, gz, pk3, & BC_step, BC_split, & - pkc_pertn, computepk3, isd, ied, isd, ied, istart, iend, jsd, jed, jsd, 0, npz) + pkc_pertn, computepk3, use_cond, moist_kappa, & + isd, ied, isd, ied, istart, iend, jsd, jed, jsd, 0, npz) end if if (je == npy-1) then call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%north_t0, delzBC%north_t1, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif + q_con, cappa, & pkc, gz, pk3, & BC_step, BC_split, & - pkc_pertn, computepk3, isd, ied, isd, ied, istart, iend, jsd, jed, npy, jed, npz) + pkc_pertn, computepk3, use_cond, moist_kappa, & + isd, ied, isd, ied, istart, iend, jsd, jed, npy, jed, npz) endif end subroutine nh_bc subroutine nh_BC_k(ptop, grav, kappa, cp, delp, delzBC_t0, delzBC_t1, pt, phis, & -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & + q_con, cappa, pkc, gz, pk3, & BC_step, BC_split, & - pkc_pertn, computepk3, isd, ied, isd_BC, ied_BC, istart, iend, jsd, jed, jstart, jend, npz) + pkc_pertn, computepk3, use_cond, moist_kappa, & + isd, ied, isd_BC, ied_BC, istart, iend, jsd, jed, jstart, jend, npz) integer, intent(IN) :: isd, ied, isd_BC, ied_BC, istart, iend, jsd, jed, jstart, jend, npz real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: delzBC_t0, delzBC_t1 real, intent(IN) :: BC_step, BC_split - logical, intent(IN) :: pkc_pertn, computepk3 + logical, intent(IN) :: pkc_pertn, computepk3, use_cond, moist_kappa real, intent(IN) :: ptop, kappa, cp, grav real, intent(IN) :: phis(isd:ied,jsd:jed) real, intent(IN), dimension(isd:ied,jsd:jed,npz):: pt, delp -#ifdef USE_COND - real, intent(IN), dimension(isd:ied,jsd:jed,npz):: q_con -#ifdef MOIST_CAPPA - real, intent(INOUT), dimension(isd:ied,jsd:jed,npz):: cappa -#endif -#endif + real, intent(IN), dimension(isd:,jsd:,1:):: q_con + real, intent(INOUT), dimension(isd:,jsd:,1:):: cappa real, intent(INOUT), dimension(isd:ied,jsd:jed,npz+1):: gz, pkc, pk3 integer :: i,j,k @@ -1902,9 +1878,7 @@ subroutine nh_BC_k(ptop, grav, kappa, cp, delp, delzBC_t0, delzBC_t1, pt, phis, real :: ptk, rgrav, rkap, peln1, rdg, denom real, dimension(istart:iend, npz+1, jstart:jend ) :: pe, peln -#ifdef USE_COND real, dimension(istart:iend, npz+1 ) :: peg, pelng -#endif real, dimension(istart:iend, npz) :: gam, bb, dd, pkz real, dimension(istart:iend, npz-1) :: g_rat real, dimension(istart:iend) :: bet @@ -1938,43 +1912,63 @@ subroutine nh_BC_k(ptop, grav, kappa, cp, delp, delzBC_t0, delzBC_t1, pt, phis, do i=istart,iend pe(i,1,j) = ptop peln(i,1,j) = peln1 -#ifdef USE_COND peg(i,1) = ptop pelng(i,1) = peln1 -#endif enddo do k=2,npz+1 - do i=istart,iend - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) - peln(i,k,j) = log(pe(i,k,j)) -#ifdef USE_COND - peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - enddo + if (use_cond) then + do i=istart,iend + pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + peln(i,k,j) = log(pe(i,k,j)) + peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) + pelng(i,k) = log(peg(i,k)) + enddo + else + do i=istart,iend + pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + peln(i,k,j) = log(pe(i,k,j)) + enddo + endif !use_cond enddo !Perturbation nonhydro layer-mean pressure (NOT to the kappa) - do k=1,npz + if (moist_kappa) then + do k=1,npz do i=istart,iend delz_int = (delzBC_t0(i,j,k)*(BC_split-BC_step) + BC_step*delzBC_t1(i,j,k))*denom - !Full p -#ifdef MOIST_CAPPA pkz(i,k) = exp(1./(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz_int*pt(i,j,k))) -#else + enddo + enddo + else + do k=1,npz + do i=istart,iend + delz_int = (delzBC_t0(i,j,k)*(BC_split-BC_step) + BC_step*delzBC_t1(i,j,k))*denom + !Full p pkz(i,k) = exp(gama*log(-delp(i,j,k)*rgrav/delz_int*rdgas*pt(i,j,k))) -#endif + enddo + enddo + endif !moist_kappa + + if (use_cond) then + do k=1,npz + do i=istart,iend !hydro -#ifdef USE_COND pm = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) -#else + !Remove hydro cell-mean pressure + pkz(i,k) = pkz(i,k) - pm + enddo + enddo + else + do k=1,npz + do i=istart,iend + !hydro pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -#endif !Remove hydro cell-mean pressure pkz(i,k) = pkz(i,k) - pm enddo - enddo + enddo + endif !pressure solver do k=1,npz-1 diff --git a/model/sw_core.F90 b/model/sw_core.F90 index 058463dff..dfcab1bf9 100644 --- a/model/sw_core.F90 +++ b/model/sw_core.F90 @@ -497,7 +497,7 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & diss_est, zvir, sphum, nq, q, k, km, inline_q, & dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, & nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, & - damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd) + damp_t, d_con, hydrostatic, gridstruct, flagstruct, use_cond, bd) integer, intent(IN):: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp integer, intent(IN):: nord ! nord=1 divergence damping; (del-4) or 3 (del-8) @@ -507,9 +507,10 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & integer, intent(IN):: sphum, nq, k, km real , intent(IN):: dt, dddmp, d2_bg, d4_bg, d_con real , intent(IN):: zvir - real, intent(in):: damp_v, damp_w, damp_t, kgb + real , intent(IN):: damp_v, damp_w, damp_t, kgb + logical, intent(IN):: use_cond type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(inout):: divg_d(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) ! divergence + real, intent(INOUT):: divg_d(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) ! divergence real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed):: z_rat real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed):: delp, pt, ua, va real, intent(INOUT), dimension(bd%isd: , bd%jsd: ):: w, q_con @@ -557,8 +558,9 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & real :: dt2, dt4, dt5, dt6 real :: damp, damp2, damp4, dd8, u2, v2, du2, dv2 - real :: u_lon + real :: u_lon, tmp integer :: i,j, is2, ie1, js2, je1, n, nt, n2, iq + logical :: prevent_diss_cooling real, pointer, dimension(:,:) :: area, area_c, rarea @@ -619,6 +621,8 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & nw_corner = gridstruct%nw_corner ne_corner = gridstruct%ne_corner + prevent_diss_cooling = flagstruct%prevent_diss_cooling + #ifdef SW_DYNAMICS if ( test_case == 1 ) then do j=jsd,jed @@ -945,20 +949,36 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & if ( .not. hydrostatic ) then if ( damp_w>1.E-5 ) then - dd8 = kgb*abs(dt) - damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1) - call del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, gridstruct, bd) - do j=js,je - do i=is,ie - dw(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) -! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw -! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j)) - heat_source(i,j) = dd8 - dw(i,j)*(w(i,j)+0.5*dw(i,j)) + dd8 = kgb*abs(dt) + damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1) + call del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, gridstruct, bd) + if (prevent_diss_cooling) then + do j=js,je + do i=is,ie + dw(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) + ! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw + !limiter to prevent "dissipative cooling" + !physically `tmp` is negative. + tmp = dw(i,j)*(w(i,j)+0.5*dw(i,j)) + heat_source(i,j) = dd8 - min(0.,tmp) if ( flagstruct%do_diss_est ) then - diss_est(i,j) = heat_source(i,j) + diss_est(i,j) = dd8 - tmp endif - enddo + enddo + enddo + else + do j=js,je + do i=is,ie + dw(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) + ! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw + heat_source(i,j) = dd8 - dw(i,j)*(w(i,j)+0.5*dw(i,j)) + tmp = dw(i,j)*(w(i,j)+0.5*dw(i,j)) + if ( flagstruct%do_diss_est ) then + diss_est(i,j) = heat_source(i,j) + endif enddo + enddo + endif endif call fv_tp_2d(w, crx_adv,cry_adv, npx, npy, hord_vt, gx, gy, xfx_adv, yfx_adv, & gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, mfx=fx, mfy=fy) @@ -969,15 +989,15 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & enddo endif -#ifdef USE_COND + if (use_cond) then call fv_tp_2d(q_con, crx_adv,cry_adv, npx, npy, hord_dp, gx, gy, & xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) - do j=js,je - do i=is,ie - q_con(i,j) = delp(i,j)*q_con(i,j) + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) - enddo - enddo -#endif + do j=js,je + do i=is,ie + q_con(i,j) = delp(i,j)*q_con(i,j) + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) + enddo + enddo + endif ! if ( inline_q .and. zvir>0.01 ) then ! do j=jsd,jed @@ -1254,13 +1274,13 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & endif endif -#ifdef USE_COND - do j=js,je + if (use_cond) then + do j=js,je do i=is,ie q_con(i,j) = q_con(i,j)/delp(i,j) enddo - enddo -#endif + enddo + endif !----------------------------- ! Compute divergence damping @@ -1498,6 +1518,8 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & vt=0. endif + !estimate dissipation for dissipative heating + ! or dissipation estimate diagnostic if ( d_con > 1.e-5 .or. flagstruct%do_diss_est ) then do j=js,je+1 do i=is,ie @@ -1517,7 +1539,30 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & ! Heating due to damping: !---------------------------------- damp = 0.25*d_con - do j=js,je + if (prevent_diss_cooling) then + do j=js,je + do i=is,ie + u2 = fy(i,j) + fy(i,j+1) + du2 = ub(i,j) + ub(i,j+1) + v2 = fx(i,j) + fx(i+1,j) + dv2 = vb(i,j) + vb(i+1,j) +! Total energy conserving: +! Convert lost KE due to divergence damping to "heat" + tmp = rsin2(i,j)*((ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2) & + + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & + - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) + if (d_con > 1.e-5) then + !limiter to prevent dissipative cooling + ! again this quantity should physically be negative + heat_source(i,j) = delp(i,j)*(heat_source(i,j) - damp*min(0.,tmp) ) + endif + if (flagstruct%do_diss_est) then + diss_est(i,j) = diss_est(i,j)-tmp + endif + enddo + enddo + else + do j=js,je do i=is,ie u2 = fy(i,j) + fy(i,j+1) du2 = ub(i,j) + ub(i,j+1) @@ -1532,12 +1577,13 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & if (flagstruct%do_diss_est) then diss_est(i,j) = diss_est(i,j)-rsin2(i,j)*( & (ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2) & - + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & - - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) - endif + + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & + - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) + endif enddo - enddo - endif + enddo + endif !prevent_diss_cooling + endif ! d_con > 1.e-5 .or. flagstruct%do_diss_est ! Add diffusive fluxes to the momentum equation: if ( damp_v>1.E-5 ) then @@ -2299,7 +2345,18 @@ subroutine xtp_u(is,ie,js,je,isd,ied,jsd,jed,c, u, v, flux, iord, dx, rdx, npx, smt5(i) = 3.*abs(b0(i)) < abs(bl(i)-br(i)) enddo endif - +!WMP +! fix edge issues + if ( (.not. bounded_domain) .and. grid_type < 3) then + if( is==1 ) then + smt5(0) = bl(0)*br(0) < 0. + smt5(1) = bl(1)*br(1) < 0. + endif + if( (ie+1)==npx ) then + smt5(npx-1) = bl(npx-1)*br(npx-1) < 0. + smt5(npx ) = bl(npx )*br(npx ) < 0. + endif + endif !DEC$ VECTOR ALWAYS do i=is,ie+1 if( c(i,j)>0. ) then @@ -2707,6 +2764,25 @@ subroutine ytp_v(is,ie,js,je,isd,ied,jsd,jed, c, u, v, flux, jord, dy, rdy, npx, smt6(i,j) = 3.*abs(b0(i,j)) < abs(bl(i,j)-br(i,j)) enddo enddo + +!WMP +! fix edge issues + if ( (.not.bounded_domain) .and. grid_type < 3) then + if( js==1 ) then + do i=is,ie+1 + smt6(i,0) = bl(i,0)*br(i,0) < 0. + smt6(i,1) = bl(i,1)*br(i,1) < 0. + enddo + endif + if( (je+1)==npy ) then + do i=is,ie+1 + smt6(i,npy-1) = bl(i,npy-1)*br(i,npy-1) < 0. + smt6(i,npy ) = bl(i,npy )*br(i,npy ) < 0. + enddo + endif + endif + + do j=js,je+1 !DEC$ VECTOR ALWAYS do i=is,ie+1 diff --git a/model/tp_core.F90 b/model/tp_core.F90 index 4ab2164a6..2541e084c 100644 --- a/model/tp_core.F90 +++ b/model/tp_core.F90 @@ -71,6 +71,11 @@ module tp_core_mod ! q(i+0.5) = p1*(q(i-1)+q(i)) + p2*(q(i-2)+q(i+1)) ! integer:: is, ie, js, je, isd, ied, jsd, jed + !List of schemes for tracer setup + integer, public, parameter :: tp_mono_schemes(1) = (/8/) + integer, public, parameter :: tp_PD_schemes(5) = (/-5, 7, 9, 12, 13/) + integer, public, parameter :: tp_unlim_schemes(8) = (/1, 2, 3, 4, 5, 6, 10, 11/) + integer, public, parameter :: tp_valid_schemes(14) = (/-5, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13/) ! !EOP !----------------------------------------------------------------------- @@ -525,6 +530,19 @@ subroutine xppm(flux, q, c, iord, is,ie,isd,ied, jfirst,jlast,jsd,jed, npx, npy, enddo endif +!WMP +! fix edge issues + if ( (.not. bounded_domain) .and. grid_type < 3) then + if( is==1 ) then + smt5(0) = bl(0)*br(0) < 0. + smt5(1) = bl(1)*br(1) < 0. + endif + if( (ie+1)==npx ) then + smt5(npx-1) = bl(npx-1)*br(npx-1) < 0. + smt5(npx ) = bl(npx )*br(npx ) < 0. + endif + endif + !DEC$ VECTOR ALWAYS do i=is,ie+1 if ( c(i,j) > 0. ) then @@ -918,6 +936,23 @@ subroutine yppm(flux, q, c, jord, ifirst,ilast, isd,ied, js,je,jsd,jed, npx, npy enddo endif +!WMP +! fix edge issues + if ( (.not. bounded_domain) .and. grid_type < 3) then + if( js==1 ) then + do i=ifirst,ilast + smt5(i,0) = bl(i,0)*br(i,0) < 0. + smt5(i,1) = bl(i,1)*br(i,1) < 0. + enddo + endif + if( (je+1)==npy ) then + do i=ifirst,ilast + smt5(i,npy-1) = bl(i,npy-1)*br(i,npy-1) < 0. + smt5(i,npy ) = bl(i,npy )*br(i,npy ) < 0. + enddo + endif + endif + do j=js,je+1 !DEC$ VECTOR ALWAYS do i=ifirst,ilast diff --git a/tools/coarse_grained_diagnostics.F90 b/tools/coarse_grained_diagnostics.F90 index 9e39d482a..5fd38f8ba 100644 --- a/tools/coarse_grained_diagnostics.F90 +++ b/tools/coarse_grained_diagnostics.F90 @@ -30,18 +30,23 @@ module coarse_grained_diagnostics_mod use field_manager_mod, only: MODEL_ATMOS use fv_arrays_mod, only: fv_atmos_type, fv_coarse_graining_type use fv_diagnostics_mod, only: cs3_interpolator, get_height_given_pressure, get_vorticity, interpolate_vertical - use fv_mapz_mod, only: moist_cp, moist_cv + use fv_diagnostics_mod, only: nplev, levs, id_plev + use fv_thermodynamics_mod, only: moist_cp, moist_cv use mpp_domains_mod, only: domain2d, EAST, NORTH use mpp_mod, only: FATAL, mpp_error - use coarse_graining_mod, only: block_sum, get_fine_array_bounds, get_coarse_array_bounds, MODEL_LEVEL, & - weighted_block_average, PRESSURE_LEVEL, vertically_remap_field, & + use coarse_graining_mod, only: MODEL_LEVEL_MASS_WEIGHTED, MODEL_LEVEL_AREA_WEIGHTED + use coarse_graining_mod, only: PRESSURE_LEVEL, PRESSURE_LEVEL_EXTRAPOLATE, BLENDED_AREA_WEIGHTED + use coarse_graining_mod, only: block_sum, get_fine_array_bounds, get_coarse_array_bounds, & + weighted_block_average, vertically_remap_field, & vertical_remapping_requirements, mask_area_weights, & block_edge_sum_x, block_edge_sum_y,& eddy_covariance_2d_weights, eddy_covariance_3d_weights - + use coarse_graining_mod, only: compute_blending_weights_agrid, blended_area_weighted_coarse_grain_field + use time_manager_mod, only: time_type use tracer_manager_mod, only: get_tracer_index, get_tracer_names - + use gfdl_mp_mod, only: mqs3d + implicit none private @@ -62,11 +67,12 @@ module coarse_grained_diagnostics_mod character(len=64) :: reduction_method logical :: vertically_integrated = .false. logical :: scaled_by_specific_heat_and_vertically_integrated = .false. - logical :: always_model_level_coarse_grain = .false. + logical :: always_model_level_area_weighted_coarse_grain = .false. integer :: pressure_level = -1 ! If greater than 0, interpolate to this pressure level (in hPa) integer :: iv = 0 ! Controls type of pressure-level interpolation performed (-1, 0, or 1) character(len=64) :: special_case = '' ! E.g. height is computed differently on pressure surfaces type(data_subtype) :: data + logical :: plev_diag = .false. end type coarse_diag_type public :: fv_coarse_diag_init, fv_coarse_diag @@ -150,7 +156,7 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics) coarse_diagnostics(index)%description = 'coarse-grained pressure thickness' coarse_diagnostics(index)%units = 'Pa' coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED - coarse_diagnostics(index)%always_model_level_coarse_grain = .true. + coarse_diagnostics(index)%always_model_level_area_weighted_coarse_grain = .true. coarse_diagnostics(index)%data%var3 => Atm(tile_count)%delp(is:ie,js:je,1:npz) index = index + 1 @@ -170,7 +176,7 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics) coarse_diagnostics(index)%description = 'coarse-grained height thickness' coarse_diagnostics(index)%units = 'm' coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED - coarse_diagnostics(index)%always_model_level_coarse_grain = .true. + coarse_diagnostics(index)%always_model_level_area_weighted_coarse_grain = .true. coarse_diagnostics(index)%data%var3 => Atm(tile_count)%delz(is:ie,js:je,1:npz) index = index + 1 @@ -374,7 +380,7 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics) coarse_diagnostics(index)%name = 'delp_dt_nudge_coarse' coarse_diagnostics(index)%description = 'coarse-grained pressure thickness tendency from nudging' coarse_diagnostics(index)%units = 'Pa/s' - coarse_diagnostics(index)%always_model_level_coarse_grain = .true. + coarse_diagnostics(index)%always_model_level_area_weighted_coarse_grain = .true. coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED index = index + 1 @@ -393,6 +399,14 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics) coarse_diagnostics(index)%units = 'm/s/s' coarse_diagnostics(index)%reduction_method = MASS_WEIGHTED + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'qv_dt_nudge_coarse' + coarse_diagnostics(index)%description = 'coarse-grained specific humidity tendency from nudging' + coarse_diagnostics(index)%units = 'kg/kg/s' + coarse_diagnostics(index)%reduction_method = MASS_WEIGHTED + index = index + 1 coarse_diagnostics(index)%axes = 3 coarse_diagnostics(index)%module_name = DYNAMICS @@ -640,6 +654,15 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics) coarse_diagnostics(index)%vertically_integrated = .true. coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + index = index + 1 + coarse_diagnostics(index)%axes = 2 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'int_qv_dt_nudge_coarse' + coarse_diagnostics(index)%description = 'coarse-grained vertically integrated specific humidity tendency from nudging' + coarse_diagnostics(index)%units = 'kg/m**2/s' + coarse_diagnostics(index)%vertically_integrated = .true. + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + index = index + 1 coarse_diagnostics(index)%axes = 2 coarse_diagnostics(index)%module_name = DYNAMICS @@ -918,6 +941,116 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics) coarse_diagnostics(index)%iv = -1 endif enddo + + if (Atm(tile_count)%flagstruct%write_3d_diags) then + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'u_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained zonal wind' + coarse_diagnostics(index)%units = 'm/s' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%ua(is:ie,js:je,1:npz) + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = -1 + + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'v_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained meridional wind' + coarse_diagnostics(index)%units = 'm/s' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%va(is:ie,js:je,1:npz) + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = -1 + + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 't_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained temperature' + coarse_diagnostics(index)%units = 'K' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%pt(is:ie,js:je,1:npz) + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = 1 + + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'omega_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained pressure velocity' + coarse_diagnostics(index)%units = 'Pa/s' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%omga(is:ie,js:je,1:npz) + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = -1 + + if (.not. Atm(tile_count)%flagstruct%hydrostatic) then + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'w_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained vertical wind' + coarse_diagnostics(index)%units = 'm/s' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%w(is:ie,js:je,1:npz) + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = -1 + endif + + do t = 1, n_tracers + call get_tracer_names(MODEL_ATMOS, t, tracer_name, tracer_long_name, tracer_units) + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = trim(tracer_name) // '_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained ' // trim(tracer_long_name) + coarse_diagnostics(index)%units = tracer_units + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + if (t .gt. n_prognostic) then + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%qdiag(is:ie,js:je,1:npz,t) + else + coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,t) + endif + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = 0 + enddo + + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'h_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained height' + coarse_diagnostics(index)%units = 'm' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%special_case = 'height' + coarse_diagnostics(index)%plev_diag = .true. + + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'vort_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained vorticity' + coarse_diagnostics(index)%units = '1/s' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%special_case = 'vorticity' + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = -1 + + index = index + 1 + coarse_diagnostics(index)%axes = 3 + coarse_diagnostics(index)%module_name = DYNAMICS + coarse_diagnostics(index)%name = 'rh_plev_coarse' + coarse_diagnostics(index)%description = 'coarse-grained relative humidity' + coarse_diagnostics(index)%units = '%' + coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED + coarse_diagnostics(index)%special_case = 'rh' + coarse_diagnostics(index)%plev_diag = .true. + coarse_diagnostics(index)%iv = 0 + endif + end subroutine populate_coarse_diag_type subroutine register_coarse_diagnostics(Atm, coarse_diagnostics, Time, & @@ -929,27 +1062,40 @@ subroutine register_coarse_diagnostics(Atm, coarse_diagnostics, Time, & integer, intent(in) :: id_x_coarse, id_y_coarse integer :: index, n_valid_diagnostics - integer :: axes_t(3), axes(3) + integer :: axes_t(3), axes(3), axes_p(3) real :: missing_value = -1.0e10 ! Following fv_diagnostics.F90 axes_t = (/ id_xt_coarse, id_yt_coarse, id_pfull_coarse /) axes = (/ id_x_coarse, id_y_coarse, id_pfull_coarse /) + axes_p = (/ id_xt_coarse, id_yt_coarse, id_plev /) do index = 1, DIAG_SIZE if (trim(coarse_diagnostics(index)%name) == '') exit n_valid_diagnostics = index enddo do index = 1, n_valid_diagnostics - coarse_diagnostics(index)%id = register_diag_field( & - trim(coarse_diagnostics(index)%module_name), & - trim(coarse_diagnostics(index)%name), & - axes_t(1:coarse_diagnostics(index)%axes), & - Time, & - trim(coarse_diagnostics(index)%description), & - trim(coarse_diagnostics(index)%units), & - missing_value=missing_value & - ) - call maybe_allocate_reference_array(Atm, coarse_diagnostics(index)) + if (coarse_diagnostics(index)%plev_diag) then + coarse_diagnostics(index)%id = register_diag_field( & + trim(coarse_diagnostics(index)%module_name), & + trim(coarse_diagnostics(index)%name), & + axes_p, & + Time, & + trim(coarse_diagnostics(index)%description), & + trim(coarse_diagnostics(index)%units), & + missing_value=missing_value & + ) + else + coarse_diagnostics(index)%id = register_diag_field( & + trim(coarse_diagnostics(index)%module_name), & + trim(coarse_diagnostics(index)%name), & + axes_t(1:coarse_diagnostics(index)%axes), & + Time, & + trim(coarse_diagnostics(index)%description), & + trim(coarse_diagnostics(index)%units), & + missing_value=missing_value & + ) + call maybe_allocate_reference_array(Atm, coarse_diagnostics(index)) + endif enddo call register_coarse_static_diagnostics(Atm, Time, axes_t, axes) @@ -1058,6 +1204,12 @@ subroutine maybe_allocate_reference_array(Atm, coarse_diagnostic) Atm(tile_count)%nudge_diag%nudge_v_dt(is:ie,js:je,1:npz) = 0.0 endif coarse_diagnostic%data%var3 => Atm(tile_count)%nudge_diag%nudge_v_dt(is:ie,js:je,1:npz) + elseif (ends_with(coarse_diagnostic%name, 'qv_dt_nudge_coarse')) then + if (.not. allocated(Atm(tile_count)%nudge_diag%nudge_qv_dt)) then + allocate(Atm(tile_count)%nudge_diag%nudge_qv_dt(is:ie,js:je,1:npz)) + Atm(tile_count)%nudge_diag%nudge_qv_dt(is:ie,js:je,1:npz) = 0.0 + endif + coarse_diagnostic%data%var3 => Atm(tile_count)%nudge_diag%nudge_v_dt(is:ie,js:je,1:npz) elseif (ends_with(coarse_diagnostic%name, 'qv_dt_gfdlmp_coarse')) then if (.not. allocated(Atm(tile_count)%inline_mp%qv_dt)) then allocate(Atm(tile_count)%inline_mp%qv_dt(is:ie,js:je,1:npz)) @@ -1236,14 +1388,17 @@ subroutine fv_coarse_diag(Atm, Time, zvir) real, allocatable :: work_2d(:,:), work_2d_coarse(:,:), work_3d_coarse(:,:,:) real, allocatable :: mass(:,:,:), height_on_interfaces(:,:,:), masked_area(:,:,:) real, allocatable :: phalf(:,:,:), upsampled_coarse_phalf(:,:,:) - real, allocatable, target :: vorticity(:,:,:) + real, allocatable :: blending_weights(:,:,:) + real, allocatable, target :: vorticity(:,:,:), rh(:,:,:) real, allocatable :: zsurf(:,:) integer :: is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz integer :: isd, ied, jsd, jed logical :: used logical :: need_2d_work_array, need_3d_work_array, need_mass_array, need_height_array, need_masked_area_array - logical :: need_vorticity_array + logical :: extrapolate + logical :: need_vorticity_array, need_rh_array integer :: index, i, j + integer :: nwat character(len=256) :: error_message call get_need_nd_work_array(2, need_2d_work_array) @@ -1251,6 +1406,7 @@ subroutine fv_coarse_diag(Atm, Time, zvir) call get_need_mass_array(Atm(tile_count)%coarse_graining%strategy, need_mass_array) call get_need_height_array(need_height_array) call get_need_vorticity_array(need_vorticity_array) + call get_need_rh_array(need_rh_array) call get_need_masked_area_array(Atm(tile_count)%coarse_graining%strategy, need_masked_area_array) call get_fine_array_bounds(is, ie, js, je) @@ -1267,7 +1423,8 @@ subroutine fv_coarse_diag(Atm, Time, zvir) if (need_3d_work_array) then allocate(work_3d_coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) - if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL) then + if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL .or. & + trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL_EXTRAPOLATE) then allocate(phalf(is:ie,js:je,1:npz+1)) allocate(upsampled_coarse_phalf(is:ie,js:je,1:npz+1)) @@ -1277,6 +1434,18 @@ subroutine fv_coarse_diag(Atm, Time, zvir) Atm(tile_count)%ptop, & phalf, & upsampled_coarse_phalf) + elseif (trim(Atm(tile_count)%coarse_graining%strategy) .eq. BLENDED_AREA_WEIGHTED) then + allocate(phalf(is:ie,js:je,1:npz+1)) + allocate(upsampled_coarse_phalf(is:ie,js:je,1:npz+1)) + allocate(blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + + call vertical_remapping_requirements( & + Atm(tile_count)%delp(is:ie,js:je,1:npz), & + Atm(tile_count)%gridstruct%area(is:ie,js:je), & + Atm(tile_count)%ptop, & + phalf, & + upsampled_coarse_phalf, & + blending_weights) endif endif @@ -1287,10 +1456,12 @@ subroutine fv_coarse_diag(Atm, Time, zvir) if (need_masked_area_array) then allocate(masked_area(is:ie,js:je,1:npz)) + extrapolate = trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL_EXTRAPOLATE call mask_area_weights( & Atm(tile_count)%gridstruct%area(is:ie,js:je), & phalf, & upsampled_coarse_phalf, & + extrapolate, & masked_area) endif @@ -1316,28 +1487,55 @@ subroutine fv_coarse_diag(Atm, Time, zvir) allocate(vorticity(is:ie,js:je,1:npz)) call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, Atm(tile_count)%u, Atm(tile_count)%v, vorticity, & Atm(tile_count)%gridstruct%dx, Atm(tile_count)%gridstruct%dy, Atm(tile_count)%gridstruct%rarea) - call associate_vorticity_pointers(is, ie, js, je, npz, vorticity) + call associate_variable_pointers(is, ie, js, je, npz, vorticity, 'vorticity') endif + if (need_rh_array) then + nwat = Atm(tile_count)%flagstruct%nwat + allocate(rh(is:ie,js:je,1:npz)) + call get_rh(is, ie, js, je, npz, nwat, Atm(tile_count)%q(is:ie,js:je,1:npz,1:nwat), & + Atm(tile_count)%delp(is:ie,js:je,1:npz), Atm(tile_count)%peln(is:ie,1:npz+1,js:je), & + Atm(tile_count)%pt(is:ie,js:je,1:npz), rh) + call associate_variable_pointers(is, ie, js, je, npz, rh, 'rh') + endif + do index = 1, DIAG_SIZE if (coarse_diagnostics(index)%id .gt. 0) then if (coarse_diagnostics(index)%axes .eq. 2) then call coarse_grain_2D_field(is, ie, js, je, npz, is_coarse, ie_coarse, js_coarse, je_coarse, & Atm(tile_count), coarse_diagnostics(index), height_on_interfaces, work_2d_coarse) used = send_data(coarse_diagnostics(index)%id, work_2d_coarse, Time) - elseif (coarse_diagnostics(index)%axes .eq. 3) then - if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. MODEL_LEVEL .or. coarse_diagnostics(index)%always_model_level_coarse_grain) then - call coarse_grain_3D_field_on_model_levels(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz, & + elseif (coarse_diagnostics(index)%plev_diag) then + call coarse_grain_3D_plev_field(is, ie, js, je, npz, is_coarse, ie_coarse, js_coarse, je_coarse, & + Atm(tile_count), coarse_diagnostics(index), height_on_interfaces, work_3d_coarse(:,:,1:nplev)) + used = send_data(coarse_diagnostics(index)%id, work_3d_coarse(:,:,1:nplev), Time) + elseif (coarse_diagnostics(index)%axes .eq. 3) then + if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. MODEL_LEVEL_MASS_WEIGHTED) then + call coarse_grain_3D_field_model_level_mass_weighted(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz, & coarse_diagnostics(index), Atm(tile_count)%gridstruct%area(is:ie,js:je),& mass, & Atm(tile_count)%omga(is:ie,js:je,1:npz), & work_3d_coarse) - else if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL) then + elseif (trim(Atm(tile_count)%coarse_graining%strategy) .eq. MODEL_LEVEL_AREA_WEIGHTED .or. coarse_diagnostics(index)%always_model_level_area_weighted_coarse_grain) then + call coarse_grain_3D_field_model_level_area_weighted(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz, & + coarse_diagnostics(index), Atm(tile_count)%gridstruct%area(is:ie,js:je),& + Atm(tile_count)%omga(is:ie,js:je,1:npz), & + work_3d_coarse) + elseif (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL .or. & + trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL_EXTRAPOLATE) then call coarse_grain_3D_field_on_pressure_levels(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz, & coarse_diagnostics(index), masked_area, phalf, & upsampled_coarse_phalf, Atm(tile_count)%ptop, & Atm(tile_count)%omga(is:ie,js:je,1:npz),& work_3d_coarse) + elseif (trim(Atm(tile_count)%coarse_graining%strategy) .eq. BLENDED_AREA_WEIGHTED) then + call coarse_grain_3D_field_blended_area_weighted(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz, & + coarse_diagnostics(index), masked_area, phalf, & + upsampled_coarse_phalf, Atm(tile_count)%ptop, & + Atm(tile_count)%omga(is:ie,js:je,1:npz), & + Atm(tile_count)%gridstruct%area(is:ie,js:je), & + blending_weights, & + work_3d_coarse) else write(error_message, *) 'fv_coarse_diag: invalid coarse-graining strategy provided for 3D variables, ' // & trim(Atm(tile_count)%coarse_graining%strategy) @@ -1349,7 +1547,7 @@ subroutine fv_coarse_diag(Atm, Time, zvir) enddo end subroutine fv_coarse_diag - subroutine coarse_grain_3D_field_on_model_levels(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, & + subroutine coarse_grain_3D_field_model_level_mass_weighted(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, & npz, coarse_diag, area, mass, omega, result) integer, intent(in) :: is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz type(coarse_diag_type) :: coarse_diag @@ -1389,12 +1587,44 @@ subroutine coarse_grain_3D_field_on_model_levels(is, ie, js, je, is_coarse, ie_c result & ) else - write(error_message, *) 'coarse_grain_3D_field_on_model_levels: invalid reduction_method, ' // & + write(error_message, *) 'coarse_grain_3D_field_model_level_mass_weighted: invalid reduction_method, ' // & + trim(coarse_diag%reduction_method) // ', provided for 3D variable, ' // & + trim(coarse_diag%name) + call mpp_error(FATAL, error_message) + endif + end subroutine coarse_grain_3D_field_model_level_mass_weighted + + subroutine coarse_grain_3D_field_model_level_area_weighted(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, & + npz, coarse_diag, area, omega, result) + integer, intent(in) :: is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz + type(coarse_diag_type) :: coarse_diag + real, intent(in) :: area(is:ie,js:je) + real, intent(in) :: omega(is:ie,js:je,1:npz) + real, intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + character(len=256) :: error_message + + if (trim(coarse_diag%reduction_method) .eq. AREA_WEIGHTED .or. & + trim(coarse_diag%reduction_method) .eq. MASS_WEIGHTED) then + call weighted_block_average( & + area(is:ie,js:je), & + coarse_diag%data%var3, & + result & + ) + elseif (trim(coarse_diag%reduction_method) .eq. EDDY_COVARIANCE) then + call eddy_covariance_2d_weights( & + area(is:ie,js:je), & + omega(is:ie,js:je,1:npz), & + coarse_diag%data%var3, & + result & + ) + else + write(error_message, *) 'coarse_grain_3D_field_model_level_area_weighted: invalid reduction_method, ' // & trim(coarse_diag%reduction_method) // ', provided for 3D variable, ' // & trim(coarse_diag%name) call mpp_error(FATAL, error_message) endif - end subroutine coarse_grain_3D_field_on_model_levels + end subroutine coarse_grain_3D_field_model_level_area_weighted subroutine coarse_grain_3D_field_on_pressure_levels(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, & npz, coarse_diag, masked_area, phalf, upsampled_coarse_phalf, & @@ -1421,12 +1651,14 @@ subroutine coarse_grain_3D_field_on_pressure_levels(is, ie, js, je, is_coarse, i endif allocate(remapped_field(is:ie,js:je,1:npz)) + call vertically_remap_field( & - phalf, & - var3, & - upsampled_coarse_phalf, & - ptop, & - remapped_field) + phalf, & + var3, & + upsampled_coarse_phalf, & + ptop, & + remapped_field) + if (trim(coarse_diag%reduction_method) .eq. EDDY_COVARIANCE) then allocate(remapped_omega(is:ie,js:je,1:npz)) call vertically_remap_field( & @@ -1459,6 +1691,118 @@ subroutine coarse_grain_3D_field_on_pressure_levels(is, ie, js, je, is_coarse, i endif end subroutine coarse_grain_3D_field_on_pressure_levels + subroutine coarse_grain_3D_field_blended_area_weighted(is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, & + npz, coarse_diag, masked_area, phalf, upsampled_coarse_phalf, & + ptop, omega, area, blending_weights, result) + integer, intent(in) :: is, ie, js, je, is_coarse, ie_coarse, js_coarse, je_coarse, npz + type(coarse_diag_type) :: coarse_diag + real, intent(in) :: masked_area(is:ie,js:je,1:npz) + real, intent(in) :: phalf(is:ie,js:je,1:npz+1), upsampled_coarse_phalf(is:ie,js:je,1:npz+1) + real, intent(in) :: ptop + real, intent(in) :: omega(is:ie,js:je,1:npz) + real, intent(in) :: area(is:ie,js:je) + real, intent(in) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + real, intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real, allocatable :: remapped_field(:,:,:), remapped_omega(:,:,:) + real, allocatable :: pressure_coarse_grained(:,:,:) + character(len=256) :: error_message + + if (trim(coarse_diag%reduction_method) .ne. EDDY_COVARIANCE) then + call blended_area_weighted_coarse_grain_field(& + coarse_diag%data%var3, & + phalf, & + upsampled_coarse_phalf, & + ptop, & + masked_area, & + area, & + blending_weights, & + result) + else + allocate(remapped_field(is:ie,js:je,1:npz)) + allocate(remapped_omega(is:ie,js:je,1:npz)) + allocate(pressure_coarse_grained(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + + call eddy_covariance_2d_weights( & + area(is:ie,js:je), & + omega(is:ie,js:je,1:npz), & + coarse_diag%data%var3, & + result & + ) + + call vertically_remap_field( & + phalf, & + coarse_diag%data%var3, & + upsampled_coarse_phalf, & + ptop, & + remapped_field) + call vertically_remap_field( & + phalf, & + omega, & + upsampled_coarse_phalf, & + ptop, & + remapped_omega) + call eddy_covariance_3d_weights( & + masked_area(is:ie,js:je,1:npz), & + remapped_omega(is:ie,js:je,1:npz), & + remapped_field(is:ie,js:je,1:npz), & + pressure_coarse_grained & + ) + + result = blending_weights * pressure_coarse_grained + (1 - blending_weights) * result + endif + end subroutine coarse_grain_3D_field_blended_area_weighted + + subroutine coarse_grain_3D_plev_field(is, ie, js, je, npz, is_coarse, ie_coarse, js_coarse, je_coarse, & + Atm, coarse_diag, height_on_interfaces, result) + integer, intent(in) :: is, ie, js, je, npz, is_coarse, ie_coarse, js_coarse, je_coarse + type(fv_atmos_type), intent(in) :: Atm + type(coarse_diag_type), intent(in) :: coarse_diag + real, intent(in) :: height_on_interfaces(is:ie,js:je,1:npz+1) + real, intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,nplev) + + character(len=256) :: error_message + real, allocatable :: work_3d(:,:,:) + integer :: k + + allocate(work_3d(is:ie,js:je,nplev)) + + do k = 1,nplev + if (trim(coarse_diag%special_case) .eq. 'height') then + call height_given_pressure_level( & + is, & + ie, & + js, & + je, & + npz, & + height_on_interfaces(is:ie,js:je,1:npz+1), & + Atm%peln(is:ie,1:npz+1,js:je), & + levs(k), & + work_3d(is:ie,js:je,k) & + ) + else + call interpolate_to_pressure_level( & + is, & + ie, & + js, & + je, & + npz, & + coarse_diag%data%var3, & + height_on_interfaces(is:ie,js:je,1:npz+1), & + Atm%peln(is:ie,1:npz+1,js:je), & + levs(k), & + coarse_diag%iv, & + work_3d(is:ie,js:je,k) & + ) + endif + call weighted_block_average( & + Atm%gridstruct%area(is:ie,js:je), & + work_3d(is:ie,js:je,k), & + result(is_coarse:ie_coarse,js_coarse:je_coarse,k) & + ) + enddo + end subroutine coarse_grain_3D_plev_field + subroutine coarse_grain_2D_field(is, ie, js, je, npz, is_coarse, ie_coarse, js_coarse, je_coarse, & Atm, coarse_diag, height_on_interfaces, result) integer, intent(in) :: is, ie, js, je, npz, is_coarse, ie_coarse, js_coarse, je_coarse @@ -1655,7 +1999,7 @@ subroutine get_need_mass_array(coarsening_strategy, need_mass_array) integer :: index need_mass_array = .false. - valid_strategy = trim(coarsening_strategy) .eq. MODEL_LEVEL + valid_strategy = trim(coarsening_strategy) .eq. MODEL_LEVEL_MASS_WEIGHTED if (.not. valid_strategy) return do index = 1, DIAG_SIZE valid_axes = coarse_diagnostics(index)%axes .eq. 3 @@ -1675,9 +2019,10 @@ subroutine get_need_height_array(need_height_array) need_height_array = .false. do index = 1, DIAG_SIZE - if ((coarse_diagnostics(index)%axes == 2) .and. & + if (((coarse_diagnostics(index)%axes == 2) .and. & (coarse_diagnostics(index)%pressure_level > 0) .and. & - (coarse_diagnostics(index)%id > 0)) then + (coarse_diagnostics(index)%id > 0)) .or. & + coarse_diagnostics(index)%plev_diag) then need_height_array = .true. exit endif @@ -1699,6 +2044,21 @@ subroutine get_need_vorticity_array(need_vorticity_array) enddo end subroutine get_need_vorticity_array + subroutine get_need_rh_array(need_rh_array) + logical, intent(out) :: need_rh_array + + integer :: index + + need_rh_array = .false. + do index = 1, DIAG_SIZE + if (trim(coarse_diagnostics(index)%special_case) .eq. 'rh' .and. & + coarse_diagnostics(index)%id .gt. 0) then + need_rh_array = .true. + exit + endif + enddo +end subroutine get_need_rh_array + subroutine get_need_masked_area_array(coarsening_strategy, need_masked_area_array) character(len=64), intent(in) :: coarsening_strategy logical, intent(out) :: need_masked_area_array @@ -1707,7 +2067,9 @@ subroutine get_need_masked_area_array(coarsening_strategy, need_masked_area_arra integer :: index need_masked_area_array = .false. - valid_strategy = trim(coarsening_strategy) .eq. PRESSURE_LEVEL + valid_strategy = (trim(coarsening_strategy) .eq. PRESSURE_LEVEL .or. & + trim(coarsening_strategy) .eq. PRESSURE_LEVEL_EXTRAPOLATE .or. & + trim(coarsening_strategy) .eq. BLENDED_AREA_WEIGHTED) if (.not. valid_strategy) return do index = 1, DIAG_SIZE valid_axes = coarse_diagnostics(index)%axes .eq. 3 @@ -1717,19 +2079,20 @@ subroutine get_need_masked_area_array(coarsening_strategy, need_masked_area_arra enddo end subroutine get_need_masked_area_array - subroutine associate_vorticity_pointers(is, ie, js, je, npz, vorticity) + subroutine associate_variable_pointers(is, ie, js, je, npz, work_3d, special_case) integer, intent(in) :: is, ie, js, je, npz - real, target, intent(in) :: vorticity(is:ie,js:je,1:npz) + real, target, intent(in) :: work_3d(is:ie,js:je,1:npz) + character(len=*), intent(in) :: special_case - integer :: index + integer :: index - do index = 1, DIAG_SIZE - if (trim(coarse_diagnostics(index)%special_case) .eq. 'vorticity' .and. & - coarse_diagnostics(index)%id .gt. 0) then - coarse_diagnostics(index)%data%var3 => vorticity(is:ie,js:je,1:npz) - endif - enddo - end subroutine associate_vorticity_pointers + do index = 1, DIAG_SIZE + if (trim(coarse_diagnostics(index)%special_case) .eq. trim(special_case) .and. & + coarse_diagnostics(index)%id .gt. 0) then + coarse_diagnostics(index)%data%var3 => work_3d(is:ie,js:je,1:npz) + endif + enddo + end subroutine associate_variable_pointers subroutine compute_mass(Atm, is, ie, js, je, npz, mass) type(fv_atmos_type), intent(in) :: Atm @@ -1757,7 +2120,7 @@ subroutine interpolate_to_pressure_level(is, ie, js, je, npz, field, height, pha output_pressures = log(100.0 * real(pressure_level)) ! convert to Pa then take log to match expectation of cs3_interpolator allocate(work(is:ie,js:je,n_pressure_levels)) - call cs3_interpolator(is, ie, js, je, npz, field, n_pressure_levels, output_pressures, height, phalf, ids, work, iv) + call cs3_interpolator(is, ie, js, je, npz, field, n_pressure_levels, output_pressures, phalf, ids, work, iv) result = work(is:ie,js:je,1) end subroutine interpolate_to_pressure_level @@ -2079,4 +2442,30 @@ subroutine ice_water_path(is, ie, js, je, npz, nwat, q, delp, iw) iw = iw + ginv * sum(q(is:ie,js:je,1:npz,graupel) * delp(is:ie,js:je,1:npz), 3) endif end subroutine ice_water_path + + subroutine get_rh(is, ie, js, je, npz, nwat, q, delp, peln, pt, rh) + integer, intent(in) :: is, ie, js, je, npz, nwat + real, intent(in) :: q(is:ie,js:je,1:npz,1:nwat), delp(is:ie,js:je,1:npz), peln(is:ie,1:npz+1,js:je) + real, intent(in) :: pt(is:ie,js:je,1:npz) + real, intent(out) :: rh(is:ie,js:je,npz) + + integer :: sphum, i, j, k + real:: work_2d(is:ie,js:je) + + sphum = get_tracer_index (MODEL_ATMOS, 'sphum') + do k=1,npz + do j=js,je + do i=is,ie + work_2d(i,j) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) + enddo + enddo + call mqs3d(ie-is+1, je-js+1, 1, pt(is:ie,js:je,k), work_2d, & + q(is:ie,js:je,k,sphum), rh(is:ie,js:je,k)) + do j=js,je + do i=is,ie + rh(i,j,k) = 100.*q(i,j,k,sphum)/rh(i,j,k) + enddo + enddo + enddo + end subroutine get_rh end module coarse_grained_diagnostics_mod diff --git a/tools/coarse_grained_restart_files.F90 b/tools/coarse_grained_restart_files.F90 index 804925133..9673411b3 100644 --- a/tools/coarse_grained_restart_files.F90 +++ b/tools/coarse_grained_restart_files.F90 @@ -22,10 +22,13 @@ module coarse_grained_restart_files_mod use coarse_graining_mod, only: compute_mass_weights, get_coarse_array_bounds,& - get_fine_array_bounds, MODEL_LEVEL, PRESSURE_LEVEL, weighted_block_average, & - weighted_block_edge_average_x, weighted_block_edge_average_y, & - mask_area_weights, block_upsample, remap_edges_along_x, & + get_fine_array_bounds, weighted_block_average, weighted_block_edge_average_x, & + weighted_block_edge_average_y, mask_area_weights, block_upsample, remap_edges_along_x, & remap_edges_along_y, vertically_remap_field + use coarse_graining_mod, only: MODEL_LEVEL_MASS_WEIGHTED, MODEL_LEVEL_AREA_WEIGHTED + use coarse_graining_mod, only: PRESSURE_LEVEL, PRESSURE_LEVEL_EXTRAPOLATE, BLENDED_AREA_WEIGHTED + use coarse_graining_mod, only: compute_blending_weights_agrid, compute_blending_weights_dgrid_u, compute_blending_weights_dgrid_v + use coarse_graining_mod, only: blended_area_weighted_coarse_grain_field, blended_length_weighted_coarse_grain_u, blended_length_weighted_coarse_grain_v #ifdef OVERLOAD_R4 use constantsR4_mod, only: GRAV, RDGAS, RVGAS #else @@ -474,26 +477,39 @@ subroutine coarse_grain_restart_data(Atm) character(len=256) :: error_message - if (trim(Atm%coarse_graining%strategy) .eq. MODEL_LEVEL) then - call coarse_grain_restart_data_on_model_levels(Atm) + if (trim(Atm%coarse_graining%strategy) .eq. MODEL_LEVEL_MASS_WEIGHTED) then + call coarse_grain_restart_data_on_model_levels(Atm, mass_weighted=.true.) + elseif (trim(Atm%coarse_graining%strategy) .eq. MODEL_LEVEL_AREA_WEIGHTED) then + call coarse_grain_restart_data_on_model_levels(Atm, mass_weighted=.false.) elseif (trim(Atm%coarse_graining%strategy) .eq. PRESSURE_LEVEL) then - call coarse_grain_restart_data_on_pressure_levels(Atm) + call coarse_grain_restart_data_on_pressure_levels(Atm, extrapolate=.false.) + elseif (trim(Atm%coarse_graining%strategy) .eq. PRESSURE_LEVEL_EXTRAPOLATE) then + call coarse_grain_restart_data_on_pressure_levels(Atm, extrapolate=.true.) + elseif (trim(Atm%coarse_graining%strategy) .eq. BLENDED_AREA_WEIGHTED) then + call coarse_grain_restart_data_via_blended_area_weighted_method(Atm) else - write(error_message, *) 'Currently only model_level and pressure_level coarse-graining are supported for restart files.' + write(error_message, *) 'Currently only model_level_mass_weighted, model_level_area_weighted, pressure_level, & + pressure_level_extrapolate, and blended_area_weighted & + coarse-graining are supported for restart files. Got ', trim(Atm%coarse_graining%strategy) call mpp_error(FATAL, error_message) endif end subroutine coarse_grain_restart_data - subroutine coarse_grain_restart_data_on_model_levels(Atm) + subroutine coarse_grain_restart_data_on_model_levels(Atm, mass_weighted) type(fv_atmos_type), intent(inout) :: Atm + logical, intent(in) :: mass_weighted real, allocatable :: mass(:,:,:) - allocate(mass(is:ie,js:je,1:npz)) - call compute_mass_weights(Atm%gridstruct%area(is:ie,js:je), Atm%delp(is:ie,js:je,1:npz), mass) - - call coarse_grain_fv_core_restart_data_on_model_levels(Atm, mass) - call coarse_grain_fv_tracer_restart_data_on_model_levels(Atm, mass) + if (mass_weighted) then + allocate(mass(is:ie,js:je,1:npz)) + call compute_mass_weights(Atm%gridstruct%area(is:ie,js:je), Atm%delp(is:ie,js:je,1:npz), mass) + call coarse_grain_fv_core_restart_data_model_level_mass_weighted(Atm, mass) + call coarse_grain_fv_tracer_restart_data_model_level_mass_weighted(Atm, mass) + else + call coarse_grain_fv_core_restart_data_model_level_area_weighted(Atm) + call coarse_grain_fv_tracer_restart_data_model_level_area_weighted(Atm) + endif call coarse_grain_fv_srf_wnd_restart_data(Atm) if (Atm%flagstruct%fv_land) then call coarse_grain_mg_drag_restart_data(Atm) @@ -501,8 +517,9 @@ subroutine coarse_grain_restart_data_on_model_levels(Atm) endif end subroutine coarse_grain_restart_data_on_model_levels - subroutine coarse_grain_restart_data_on_pressure_levels(Atm) + subroutine coarse_grain_restart_data_on_pressure_levels(Atm, extrapolate) type(fv_atmos_type), intent(inout) :: Atm + logical, intent(in) :: extrapolate real, allocatable, dimension(:,:,:):: phalf, coarse_phalf, coarse_phalf_on_fine real, allocatable, dimension(:,:,:) :: masked_area_weights @@ -516,9 +533,9 @@ subroutine coarse_grain_restart_data_on_pressure_levels(Atm) ! are all remapped to surfaces of constant pressure within coarse grid cells before ! coarse graining. At the end, delz and phis are corrected to impose hydrostatic balance. call compute_pressure_level_coarse_graining_requirements( & - Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) + Atm, extrapolate, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) call coarse_grain_fv_core_restart_data_on_pressure_levels( & - Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) + Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights, extrapolate) call coarse_grain_fv_tracer_restart_data_on_pressure_levels( & Atm, phalf, coarse_phalf_on_fine, masked_area_weights) call coarse_grain_fv_srf_wnd_restart_data(Atm) @@ -529,7 +546,47 @@ subroutine coarse_grain_restart_data_on_pressure_levels(Atm) call impose_hydrostatic_balance(Atm, coarse_phalf) end subroutine coarse_grain_restart_data_on_pressure_levels - subroutine coarse_grain_fv_core_restart_data_on_model_levels(Atm, mass) + subroutine coarse_grain_restart_data_via_blended_area_weighted_method(Atm) + type(fv_atmos_type), intent(inout) :: Atm + + logical :: extrapolate = .false. + real, allocatable, dimension(:,:,:):: phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights + real, allocatable, dimension(:,:,:) :: mass, blending_weights_agrid, blending_weights_dgrid_u, blending_weights_dgrid_v + + allocate(phalf(is-1:ie+1,js-1:je+1,1:npz+1)) ! Require the halo here for the winds + allocate(coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1)) + allocate(coarse_phalf_on_fine(is:ie,js:je,1:npz+1)) + allocate(masked_area_weights(is:ie,js:je,1:npz)) + allocate(blending_weights_agrid(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + allocate(blending_weights_dgrid_u(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz)) + allocate(blending_weights_dgrid_v(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz)) + + ! delp and delz are coarse-grained on model levels via an area-weighted + ! average; u, v, W, T, and all the tracers are coarsened via blended + ! pressure level and area-weighted model level coarse-graining. At the end, + ! delz and phis are corrected to impose hydrostatic balance. + call compute_pressure_level_coarse_graining_requirements( & + Atm, extrapolate, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) + + ! These subroutines compute the blending weights based on Chris's approach + call compute_blending_weights_agrid(phalf, coarse_phalf, blending_weights_agrid, x_pad=1, y_pad=1) + call compute_blending_weights_dgrid_u(phalf, Atm%gridstruct%dx(is:ie,js:je+1), blending_weights_dgrid_u) + call compute_blending_weights_dgrid_v(phalf, Atm%gridstruct%dy(is:ie+1,js:je), blending_weights_dgrid_v) + + call coarse_grain_fv_core_via_blended_area_weighted_method(Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights,& + Atm%gridstruct%area(is:ie,js:je), blending_weights_agrid, blending_weights_dgrid_u, blending_weights_dgrid_v) + call coarse_grain_fv_tracer_via_blended_area_weighted_method(Atm, phalf, coarse_phalf_on_fine, masked_area_weights,& + Atm%gridstruct%area(is:ie,js:je), blending_weights_agrid) + + call coarse_grain_fv_srf_wnd_restart_data(Atm) + if (Atm%flagstruct%fv_land) then + call coarse_grain_mg_drag_restart_data(Atm) + call coarse_grain_fv_land_restart_data(Atm) + endif + call impose_hydrostatic_balance(Atm, coarse_phalf) + end subroutine coarse_grain_restart_data_via_blended_area_weighted_method + + subroutine coarse_grain_fv_core_restart_data_model_level_mass_weighted(Atm, mass) type(fv_atmos_type), intent(inout) :: Atm real, intent(in) :: mass(is:ie,js:je,1:npz) @@ -564,9 +621,45 @@ subroutine coarse_grain_fv_core_restart_data_on_model_levels(Atm, mass) call weighted_block_average(mass(is:ie,js:je,1:npz), & Atm%va(is:ie,js:je,1:npz), Atm%coarse_graining%restart%va) endif - end subroutine coarse_grain_fv_core_restart_data_on_model_levels + end subroutine coarse_grain_fv_core_restart_data_model_level_mass_weighted - subroutine coarse_grain_fv_tracer_restart_data_on_model_levels(Atm, mass) + subroutine coarse_grain_fv_core_restart_data_model_level_area_weighted(Atm) + type(fv_atmos_type), intent(inout) :: Atm + + if (Atm%coarse_graining%write_coarse_dgrid_vel_rst) then + call weighted_block_edge_average_x(Atm%gridstruct%dx(is:ie,js:je+1), & + Atm%u(is:ie,js:je+1,1:npz), Atm%coarse_graining%restart%u) + call weighted_block_edge_average_y(Atm%gridstruct%dy(is:ie+1,js:je), & + Atm%v(is:ie+1,js:je,1:npz), Atm%coarse_graining%restart%v) + endif + + if (.not. Atm%flagstruct%hydrostatic) then + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%w(is:ie,js:je,1:npz), Atm%coarse_graining%restart%w) + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%delz(is:ie,js:je,1:npz), Atm%coarse_graining%restart%delz) + if (Atm%flagstruct%hybrid_z) then + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%ze0(is:ie,js:je,1:npz), Atm%coarse_graining%restart%ze0) + endif + endif + + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%pt(is:ie,js:je,1:npz), Atm%coarse_graining%restart%pt) + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%delp(is:ie,js:je,1:npz), Atm%coarse_graining%restart%delp) + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%phis(is:ie,js:je), Atm%coarse_graining%restart%phis) + + if (Atm%coarse_graining%write_coarse_agrid_vel_rst) then + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%ua(is:ie,js:je,1:npz), Atm%coarse_graining%restart%ua) + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%va(is:ie,js:je,1:npz), Atm%coarse_graining%restart%va) + endif + end subroutine coarse_grain_fv_core_restart_data_model_level_area_weighted + + subroutine coarse_grain_fv_tracer_restart_data_model_level_mass_weighted(Atm, mass) type(fv_atmos_type), intent(inout) :: Atm real, intent(in) :: mass(is:ie,js:je,1:npz) @@ -591,7 +684,27 @@ subroutine coarse_grain_fv_tracer_restart_data_on_model_levels(Atm, mass) Atm%qdiag(is:ie,js:je,1:npz,n_tracer), & Atm%coarse_graining%restart%qdiag(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer)) enddo - end subroutine coarse_grain_fv_tracer_restart_data_on_model_levels + end subroutine coarse_grain_fv_tracer_restart_data_model_level_mass_weighted + + subroutine coarse_grain_fv_tracer_restart_data_model_level_area_weighted(Atm) + type(fv_atmos_type), intent(inout) :: Atm + + character(len=64) :: tracer_name + integer :: n_tracer + + do n_tracer = 1, n_prognostic_tracers + call get_tracer_names(MODEL_ATMOS, n_tracer, tracer_name) + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%q(is:ie,js:je,1:npz,n_tracer), & + Atm%coarse_graining%restart%q(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer)) + enddo + + do n_tracer = n_prognostic_tracers + 1, n_tracers + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), & + Atm%qdiag(is:ie,js:je,1:npz,n_tracer), & + Atm%coarse_graining%restart%qdiag(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer)) + enddo + end subroutine coarse_grain_fv_tracer_restart_data_model_level_area_weighted subroutine coarse_grain_fv_srf_wnd_restart_data(Atm) type(fv_atmos_type), intent(inout) :: Atm @@ -617,12 +730,13 @@ subroutine coarse_grain_fv_land_restart_data(Atm) end subroutine coarse_grain_fv_land_restart_data subroutine coarse_grain_fv_core_restart_data_on_pressure_levels(& - Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) + Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights, extrapolate) type(fv_atmos_type), intent(inout) :: Atm real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) real, intent(in) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1) real, intent(in) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1) real, intent(in), dimension(is:ie,js:je,1:npz) :: masked_area_weights + logical, intent(in) :: extrapolate real, allocatable :: remapped(:,:,:) ! Will re-use this to save memory @@ -633,11 +747,13 @@ subroutine coarse_grain_fv_core_restart_data_on_pressure_levels(& phalf(is-1:ie+1,js-1:je+1,1:npz+1), & Atm%gridstruct%dx(is:ie,js:je+1), & Atm%ptop, & + extrapolate, & Atm%coarse_graining%restart%u) call remap_edges_along_y(Atm%v(is:ie+1,js:je,1:npz), & phalf(is-1:ie+1,js-1:je+1,1:npz+1), & Atm%gridstruct%dy(is:ie+1,js:je), & Atm%ptop, & + extrapolate, & Atm%coarse_graining%restart%v) endif @@ -692,6 +808,69 @@ subroutine coarse_grain_fv_tracer_restart_data_on_pressure_levels( & enddo end subroutine coarse_grain_fv_tracer_restart_data_on_pressure_levels + subroutine coarse_grain_fv_core_via_blended_area_weighted_method(Atm, phalf, coarse_phalf, coarse_phalf_on_fine,& + masked_area_weights, model_level_weights, blending_weights_agrid, blending_weights_dgrid_u, blending_weights_dgrid_v) + type(fv_atmos_type), intent(inout) :: Atm + real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) + real, intent(in) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1) + real, intent(in) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1) + real, intent(in) :: masked_area_weights(is:ie,js:je,1:npz) + real, intent(in) :: model_level_weights(is:ie,js:je) + real, intent(in) :: blending_weights_agrid(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + real, intent(in) :: blending_weights_dgrid_u(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz) + real, intent(in) :: blending_weights_dgrid_v(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz) + + call blended_length_weighted_coarse_grain_u(Atm%u(is:ie,js:je+1,1:npz), phalf, Atm%gridstruct%dx(is:ie,js:je+1),& + Atm%ptop, blending_weights_dgrid_u, Atm%coarse_graining%restart%u) + call blended_length_weighted_coarse_grain_v(Atm%v(is:ie+1,js:je,1:npz), phalf, Atm%gridstruct%dy(is:ie+1,js:je),& + Atm%ptop, blending_weights_dgrid_v, Atm%coarse_graining%restart%v) + call blended_area_weighted_coarse_grain_field(Atm%pt(is:ie,js:je,1:npz), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine,& + Atm%ptop, masked_area_weights, model_level_weights, blending_weights_agrid, Atm%coarse_graining%restart%pt) + + if (.not. Atm%flagstruct%hydrostatic) then + call blended_area_weighted_coarse_grain_field(Atm%w(is:ie,js:je,1:npz), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine,& + Atm%ptop, masked_area_weights, model_level_weights, blending_weights_agrid, Atm%coarse_graining%restart%w) + + ! Always coarse-grain delz an ze0 via an area weighted average + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%delz(is:ie,js:je,1:npz), Atm%coarse_graining%restart%delz) + if (Atm%flagstruct%hybrid_z) then + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%ze0(is:ie,js:je,1:npz), Atm%coarse_graining%restart%ze0) + endif + endif + + call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%phis(is:ie,js:je), Atm%coarse_graining%restart%phis) + + if (Atm%coarse_graining%write_coarse_agrid_vel_rst) then + call blended_area_weighted_coarse_grain_field(Atm%ua(is:ie,js:je,1:npz), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine,& + Atm%ptop, masked_area_weights, model_level_weights, blending_weights_agrid, Atm%coarse_graining%restart%ua) + call blended_area_weighted_coarse_grain_field(Atm%va(is:ie,js:je,1:npz), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine,& + Atm%ptop, masked_area_weights, model_level_weights, blending_weights_agrid, Atm%coarse_graining%restart%va) + endif + end subroutine coarse_grain_fv_core_via_blended_area_weighted_method + + subroutine coarse_grain_fv_tracer_via_blended_area_weighted_method(Atm, phalf, coarse_phalf_on_fine, masked_area_weights,& + model_level_weights, blending_weights_agrid) + type(fv_atmos_type), intent(inout) :: Atm + real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) + real, intent(in) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1) + real, intent(in) :: masked_area_weights(is:ie,js:je,1:npz) + real, intent(in) :: model_level_weights(is:ie,js:je) + real, intent(in) :: blending_weights_agrid(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + integer :: n_tracer + + do n_tracer = 1, n_tracers + call blended_area_weighted_coarse_grain_field(Atm%q(is:ie,js:je,1:npz,n_tracer), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine,& + Atm%ptop, masked_area_weights, model_level_weights, blending_weights_agrid,& + Atm%coarse_graining%restart%q(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer)) + enddo + do n_tracer = n_prognostic_tracers + 1, n_tracers + call blended_area_weighted_coarse_grain_field(Atm%qdiag(is:ie,js:je,1:npz,n_tracer), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine,& + Atm%ptop, masked_area_weights, model_level_weights, blending_weights_agrid,& + Atm%coarse_graining%restart%q(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer)) + enddo + end subroutine coarse_grain_fv_tracer_via_blended_area_weighted_method + subroutine compute_top_height(delz, phis, top_height) real, intent(in) :: delz(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) real, intent(in) :: phis(is_coarse:ie_coarse,js_coarse:je_coarse) @@ -743,8 +922,9 @@ subroutine impose_hydrostatic_balance(Atm, coarse_phalf) end subroutine impose_hydrostatic_balance subroutine compute_pressure_level_coarse_graining_requirements( & - Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) + Atm, extrapolate, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights) type(fv_atmos_type), intent(inout) :: Atm + logical, intent(in) :: extrapolate real, intent(out) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) real, intent(out) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1) real, intent(out) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1) @@ -757,7 +937,7 @@ subroutine compute_pressure_level_coarse_graining_requirements( & call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%delp(is:ie,js:je,1:npz), Atm%coarse_graining%restart%delp) call compute_phalf(is_coarse, ie_coarse, js_coarse, je_coarse, Atm%coarse_graining%restart%delp, Atm%ptop, coarse_phalf) call block_upsample(coarse_phalf, coarse_phalf_on_fine, npz+1) - call mask_area_weights(Atm%gridstruct%area(is:ie,js:je), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine, masked_area_weights) + call mask_area_weights(Atm%gridstruct%area(is:ie,js:je), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine, extrapolate, masked_area_weights) end subroutine compute_pressure_level_coarse_graining_requirements subroutine compute_phalf(i_start, i_end, j_start, j_end, delp, ptop, phalf) diff --git a/tools/coarse_graining.F90 b/tools/coarse_graining.F90 index d14bf9948..ddf048af7 100644 --- a/tools/coarse_graining.F90 +++ b/tools/coarse_graining.F90 @@ -29,14 +29,19 @@ module coarse_graining_mod implicit none private + public :: MODEL_LEVEL_MASS_WEIGHTED, MODEL_LEVEL_AREA_WEIGHTED + public :: PRESSURE_LEVEL, PRESSURE_LEVEL_EXTRAPOLATE, BLENDED_AREA_WEIGHTED public :: block_sum, compute_mass_weights, get_fine_array_bounds, & get_coarse_array_bounds, coarse_graining_init, weighted_block_average, & - weighted_block_edge_average_x, weighted_block_edge_average_y, MODEL_LEVEL, & - block_upsample, mask_area_weights, PRESSURE_LEVEL, vertical_remapping_requirements, & - vertically_remap_field, remap_edges_along_x, remap_edges_along_y, & - block_edge_sum_x, block_edge_sum_y, block_mode, block_min, block_max, & - eddy_covariance, eddy_covariance_2d_weights, eddy_covariance_3d_weights - + weighted_block_edge_average_x, weighted_block_edge_average_y, & + block_upsample, mask_area_weights, vertical_remapping_requirements, vertically_remap_field, & + remap_edges_along_x, remap_edges_along_y, block_edge_sum_x, block_edge_sum_y, & + block_mode, block_min, eddy_covariance, eddy_covariance_2d_weights, & + eddy_covariance_3d_weights + public :: compute_blending_weights_agrid, compute_blending_weights_dgrid_u, compute_blending_weights_dgrid_v + public :: blended_area_weighted_coarse_grain_field, blended_length_weighted_coarse_grain_u, blended_length_weighted_coarse_grain_v + + interface block_sum module procedure block_sum_2d_real4 module procedure block_sum_2d_real8 @@ -96,7 +101,7 @@ module coarse_graining_mod module procedure eddy_covariance_2d_weights module procedure eddy_covariance_3d_weights end interface eddy_covariance - + interface block_mode module procedure block_mode_2d_real4 module procedure masked_block_mode_2d_real4 @@ -105,18 +110,15 @@ module coarse_graining_mod end interface block_mode interface block_min - module procedure masked_block_min_2d_real4 - module procedure masked_block_min_2d_real8 + module procedure block_min_2d_real4 + module procedure block_min_2d_real8 end interface block_min - interface block_max - module procedure masked_block_max_2d_real4 - module procedure masked_block_max_2d_real8 - end interface block_max - interface vertical_remapping_requirements - module procedure vertical_remapping_requirements_real4 - module procedure vertical_remapping_requirements_real8 + module procedure vertical_remapping_requirements_pressure_level_real4 + module procedure vertical_remapping_requirements_pressure_level_real8 + module procedure vertical_remapping_requirements_blended_area_weighted_real4 + module procedure vertical_remapping_requirements_blended_area_weighted_real8 end interface vertical_remapping_requirements interface compute_phalf_from_delp @@ -133,7 +135,12 @@ module coarse_graining_mod module procedure vertically_remap_field_real4 module procedure vertically_remap_field_real8 end interface vertically_remap_field - + + interface compute_pfull_from_phalf + module procedure compute_pfull_from_phalf_real4 + module procedure compute_pfull_from_phalf_real8 + end interface compute_pfull_from_phalf + interface mappm module procedure mappm_real4 module procedure mappm_real8 @@ -159,22 +166,46 @@ module coarse_graining_mod module procedure ppm_limiters_real8 end interface ppm_limiters + interface compute_blending_weights_agrid + module procedure compute_blending_weights_agrid_real4 + module procedure compute_blending_weights_agrid_real8 + end interface compute_blending_weights_agrid + + interface pressure_coarse_grain_field + module procedure pressure_coarse_grain_field_real4 + module procedure pressure_coarse_grain_field_real8 + end interface pressure_coarse_grain_field + + interface blended_area_weighted_coarse_grain_field + module procedure blended_area_weighted_coarse_grain_field_real4 + module procedure blended_area_weighted_coarse_grain_field_real8 + end interface blended_area_weighted_coarse_grain_field + + interface compute_coarse_pfull + module procedure compute_coarse_pfull_real4 + module procedure compute_coarse_pfull_real8 + end interface compute_coarse_pfull + ! Global variables for the module, initialized in coarse_graining_init integer :: is, ie, js, je, npz integer :: is_coarse, ie_coarse, js_coarse, je_coarse - character(len=11) :: MODEL_LEVEL = 'model_level' - character(len=14) :: PRESSURE_LEVEL = 'pressure_level' - - ! GLobal variables for mappm + character(len=25), parameter :: MODEL_LEVEL_MASS_WEIGHTED = 'model_level_mass_weighted' + character(len=25), parameter :: MODEL_LEVEL_AREA_WEIGHTED = 'model_level_area_weighted' + character(len=14), parameter :: PRESSURE_LEVEL = 'pressure_level' + character(len=26), parameter :: PRESSURE_LEVEL_EXTRAPOLATE = 'pressure_level_extrapolate' + character(len=21), parameter :: BLENDED_AREA_WEIGHTED = 'blended_area_weighted' + + ! Global variables for mappm real(kind=4), parameter:: r3_real4 = 1./3., r23_real4 = 2./3., r12_real4 = 1./12. real(kind=8), parameter:: r3_real8 = 1./3., r23_real8 = 2./3., r12_real8 = 1./12. ! Namelist parameters initialized with default values integer :: coarsening_factor = 8 !< factor the coarse grid is downsampled by (e.g. 8 if coarsening from C384 to C48 resolution) integer :: coarse_io_layout(2) = (/1, 1/) !< I/O layout for coarse-grid fields - character(len=64) :: strategy = 'model_level' !< Valid values are 'model_level' and 'pressure_level' - - namelist /coarse_graining_nml/ coarsening_factor, coarse_io_layout, strategy + character(len=64) :: strategy = MODEL_LEVEL_MASS_WEIGHTED !< Valid values are 'model_level_mass_weighted', 'model_level_area_weighted', 'pressure_level', 'pressure_level_extrapolate', 'blended_area_weighted' + real :: sigma_blend = 0.9 ! Constant defining sigma level at which we switch to pressure-level coarsening in the blended method. + + namelist /coarse_graining_nml/ coarsening_factor, coarse_io_layout, strategy, sigma_blend contains @@ -244,8 +275,12 @@ subroutine assert_valid_strategy(strategy) character(len=256) :: error_message - if (trim(strategy) .ne. MODEL_LEVEL .and. trim(strategy) .ne. PRESSURE_LEVEL) then - write(error_message, *) 'Invalid coarse graining strategy provided.' + if (trim(strategy) .ne. MODEL_LEVEL_MASS_WEIGHTED .and. & + trim(strategy) .ne. MODEL_LEVEL_AREA_WEIGHTED .and. & + trim(strategy) .ne. PRESSURE_LEVEL .and. & + trim(strategy) .ne. PRESSURE_LEVEL_EXTRAPOLATE .and. & + trim(strategy) .ne. BLENDED_AREA_WEIGHTED) then + write(error_message, *) 'Invalid coarse graining strategy provided, ', trim(strategy) call mpp_error(FATAL, error_message) endif end subroutine assert_valid_strategy @@ -284,6 +319,7 @@ subroutine compute_mass_weights(area, delp, mass) integer :: k +!$OMP parallel do default(none) shared(npz,mass,area,delp) do k = 1, npz mass(:,:,k) = area * delp(:,:,k) enddo @@ -296,6 +332,8 @@ subroutine block_sum_2d_real4(fine, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -312,6 +350,8 @@ subroutine block_sum_2d_real8(fine, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -329,6 +369,8 @@ subroutine masked_block_sum_2d_real4(fine, mask, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset,mask) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -346,6 +388,8 @@ subroutine masked_block_sum_2d_real8(fine, mask, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset,mask) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -429,6 +473,8 @@ subroutine masked_weighted_block_average_3d_field_2d_weights_real4(weights, fine integer :: k +!$OMP parallel do default(none) shared(nz,is,ie,js,je,weights,fine,mask,coarse, & +!$OMP is_coarse,ie_coarse,js_coarse,je_coarse) do k = 1, nz call masked_weighted_block_average_2d_real4(weights, fine(is:ie,js:je,k), mask, coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k)) enddo @@ -442,6 +488,8 @@ subroutine masked_weighted_block_average_3d_field_2d_weights_real8(weights, fine integer :: k +!$OMP parallel do default(none) shared(nz,is,ie,js,je,weights,fine,mask,coarse, & +!$OMP is_coarse,ie_coarse,js_coarse,je_coarse) do k = 1, nz call masked_weighted_block_average_2d_real8(weights, fine(is:ie,js:je,k), mask, coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k)) enddo @@ -453,6 +501,8 @@ subroutine weighted_block_average_3d_field_2d_weights_real4(weights, fine, coars integer :: k +!$OMP parallel do default(none) shared(npz,is,ie,js,je,weights,fine,coarse, & +!$OMP is_coarse,ie_coarse,js_coarse,je_coarse) do k = 1, npz call weighted_block_average_2d_real4(weights, fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k)) enddo @@ -464,6 +514,8 @@ subroutine weighted_block_average_3d_field_2d_weights_real8(weights, fine, coars integer :: k +!$OMP parallel do default(none) shared(npz,is,ie,js,je,weights,fine,coarse, & +!$OMP is_coarse,ie_coarse,js_coarse,je_coarse) do k = 1, npz call weighted_block_average_2d_real8(weights, fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k)) enddo @@ -475,6 +527,8 @@ subroutine weighted_block_average_3d_field_3d_weights_real4(weights, fine, coars integer :: k +!$OMP parallel do default(none) shared(npz,is,ie,js,je,weights,fine,coarse, & +!$OMP is_coarse,ie_coarse,js_coarse,je_coarse) do k = 1, npz call weighted_block_average_2d_real4(weights(is:ie,js:je,k), fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k)) enddo @@ -486,6 +540,8 @@ subroutine weighted_block_average_3d_field_3d_weights_real8(weights, fine, coars integer :: k +!$OMP parallel do default(none) shared(npz,is,ie,js,je,weights,fine,coarse, & +!$OMP is_coarse,ie_coarse,js_coarse,je_coarse) do k = 1, npz call weighted_block_average_2d_real8(weights(is:ie,js:je,k), fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k)) enddo @@ -589,6 +645,8 @@ subroutine block_mode_2d_real8(fine, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -606,6 +664,8 @@ subroutine masked_block_mode_2d_real8(fine, mask, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset,mask) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -622,6 +682,8 @@ subroutine block_mode_2d_real4(fine, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -639,6 +701,8 @@ subroutine masked_block_mode_2d_real4(fine, mask, coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset,mask) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor i_coarse = (i - 1) / coarsening_factor + 1 do j = js, je, coarsening_factor @@ -648,74 +712,78 @@ subroutine masked_block_mode_2d_real4(fine, mask, coarse) enddo end subroutine masked_block_mode_2d_real4 - subroutine masked_block_min_2d_real8(fine, mask, coarse) - real(kind=8), intent(in) :: fine(is:ie,js:je) - logical, intent(in) :: mask(is:ie,js:je) - real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse) + subroutine block_min_2d_real4(fine, coarse) + real(kind=4), intent(in) :: fine(is:ie,js:je) + real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor - i_coarse = (i - 1) / coarsening_factor + 1 - do j = js, je, coarsening_factor - j_coarse = (j - 1) / coarsening_factor + 1 - coarse(i_coarse, j_coarse) = minval(fine(i:i+offset,j:j+offset), mask=mask(i:i + offset,j:j + offset)) - enddo + i_coarse = (i - 1) / coarsening_factor + 1 + do j = js, je, coarsening_factor + j_coarse = (j - 1) / coarsening_factor + 1 + coarse(i_coarse, j_coarse) = minval(fine(i:i+offset,j:j+offset)) + enddo enddo - end subroutine masked_block_min_2d_real8 + end subroutine block_min_2d_real4 - subroutine masked_block_max_2d_real8(fine, mask, coarse) + subroutine block_min_2d_real8(fine, coarse) real(kind=8), intent(in) :: fine(is:ie,js:je) - logical, intent(in) :: mask(is:ie,js:je) real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse) integer :: i, j, i_coarse, j_coarse, offset offset = coarsening_factor - 1 +!$OMP parallel do default(none) shared(is,ie,js,je,coarsening_factor,coarse,fine,offset) & +!$OMP private(i_coarse,j_coarse) do i = is, ie, coarsening_factor - i_coarse = (i - 1) / coarsening_factor + 1 - do j = js, je, coarsening_factor - j_coarse = (j - 1) / coarsening_factor + 1 - coarse(i_coarse, j_coarse) = maxval(fine(i:i+offset,j:j+offset), mask=mask(i:i + offset,j:j + offset)) - enddo + i_coarse = (i - 1) / coarsening_factor + 1 + do j = js, je, coarsening_factor + j_coarse = (j - 1) / coarsening_factor + 1 + coarse(i_coarse, j_coarse) = minval(fine(i:i+offset,j:j+offset)) + enddo enddo - end subroutine masked_block_max_2d_real8 + end subroutine block_min_2d_real8 - subroutine masked_block_min_2d_real4(fine, mask, coarse) - real(kind=4), intent(in) :: fine(is:ie,js:je) - logical, intent(in) :: mask(is:ie,js:je) - real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse) + ! Compute the minimum of the input array along the x-dimension within coarse + ! grid cell edges assuming that the input array is pre-downsampled to the + ! coarse grid along the y-dimension. + subroutine block_edge_min_x(fine, coarse) + real, intent(in) :: fine(is:ie,js_coarse:je_coarse+1) + real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse+1) - integer :: i, j, i_coarse, j_coarse, offset + integer :: i, j_coarse, i_coarse, offset offset = coarsening_factor - 1 do i = is, ie, coarsening_factor - i_coarse = (i - 1) / coarsening_factor + 1 - do j = js, je, coarsening_factor - j_coarse = (j - 1) / coarsening_factor + 1 - coarse(i_coarse, j_coarse) = minval(fine(i:i+offset,j:j+offset), mask=mask(i:i + offset,j:j + offset)) - enddo + i_coarse = (i - 1) / coarsening_factor + 1 + do j_coarse = js_coarse, je_coarse+1 + coarse(i_coarse, j_coarse) = minval(fine(i:i+offset,j_coarse)) + enddo enddo - end subroutine masked_block_min_2d_real4 - - subroutine masked_block_max_2d_real4(fine, mask, coarse) - real(kind=4), intent(in) :: fine(is:ie,js:je) - logical, intent(in) :: mask(is:ie,js:je) - real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse) + end subroutine block_edge_min_x + + ! Compute the minimum of the input array along the y-dimension within coarse + ! grid cell edges assuming that the input array is pre-downsampled to the + ! coarse grid along the x-dimension. + subroutine block_edge_min_y(fine, coarse) + real, intent(in) :: fine(is_coarse:ie_coarse+1,js:je) + real, intent(out) :: coarse(is_coarse:ie_coarse+1,js_coarse:je_coarse) - integer :: i, j, i_coarse, j_coarse, offset + integer :: i_coarse, j, j_coarse, offset offset = coarsening_factor - 1 - do i = is, ie, coarsening_factor - i_coarse = (i - 1) / coarsening_factor + 1 - do j = js, je, coarsening_factor - j_coarse = (j - 1) / coarsening_factor + 1 - coarse(i_coarse, j_coarse) = maxval(fine(i:i+offset,j:j+offset), mask=mask(i:i + offset,j:j + offset)) - enddo + do i_coarse = is_coarse, ie_coarse+1 + do j = js, je, coarsening_factor + j_coarse = (j - 1) / coarsening_factor + 1 + coarse(i_coarse, j_coarse) = minval(fine(i_coarse,j:j+offset)) + enddo enddo - end subroutine masked_block_max_2d_real4 - + end subroutine block_edge_min_y + subroutine vertically_remap_field_real4(phalf_in, field, phalf_out, ptop, field_out) real(kind=4), intent(in) :: phalf_in(is:ie,js:je,1:npz+1), phalf_out(is:ie,js:je,1:npz+1) real(kind=4), intent(in) :: field(is:ie,js:je,1:npz) @@ -783,6 +851,8 @@ subroutine block_upsample_3d_real4(coarse, fine, nz) integer :: k +!$OMP parallel do default(none) shared(nz, coarse, fine, & +!$OMP is,ie,js,je, is_coarse, ie_coarse, js_coarse, je_coarse) do k = 1, nz call block_upsample_2d_real4(coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k), fine(is:ie,js:je,k)) enddo @@ -811,6 +881,8 @@ subroutine block_upsample_3d_real8(coarse, fine, nz) integer :: k +!$OMP parallel do default(none) shared(nz, coarse, fine, & +!$OMP is,ie,js,je, is_coarse, ie_coarse, js_coarse, je_coarse) do k = 1, nz call block_upsample_2d_real8(coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k), fine(is:ie,js:je,k)) enddo @@ -952,7 +1024,7 @@ subroutine compute_phalf_from_delp_real8(delp, ptop, i_start, i_end, j_start, j_ end subroutine compute_phalf_from_delp_real8 ! Routine for computing the common requirements for pressure-level coarse-graining. - subroutine vertical_remapping_requirements_real4(delp, area, ptop, phalf, upsampled_coarse_phalf) + subroutine vertical_remapping_requirements_pressure_level_real4(delp, area, ptop, phalf, upsampled_coarse_phalf) real(kind=4), intent(in) :: delp(is:ie,js:je,1:npz) real(kind=4), intent(in) :: area(is:ie,js:je) real(kind=4), intent(in) :: ptop @@ -971,9 +1043,9 @@ subroutine vertical_remapping_requirements_real4(delp, area, ptop, phalf, upsamp deallocate(coarse_delp) deallocate(coarse_phalf) - end subroutine vertical_remapping_requirements_real4 + end subroutine vertical_remapping_requirements_pressure_level_real4 - subroutine vertical_remapping_requirements_real8(delp, area, ptop, phalf, upsampled_coarse_phalf) + subroutine vertical_remapping_requirements_pressure_level_real8(delp, area, ptop, phalf, upsampled_coarse_phalf) real(kind=8), intent(in) :: delp(is:ie,js:je,1:npz) real(kind=8), intent(in) :: area(is:ie,js:je) real(kind=8), intent(in) :: ptop @@ -992,40 +1064,143 @@ subroutine vertical_remapping_requirements_real8(delp, area, ptop, phalf, upsamp deallocate(coarse_delp) deallocate(coarse_phalf) - end subroutine vertical_remapping_requirements_real8 + end subroutine vertical_remapping_requirements_pressure_level_real8 - subroutine mask_area_weights_real4(area, phalf, upsampled_coarse_phalf, masked_area_weights) + ! Routine for computing the common requirements for blended-area-weighted coarse-graining. + subroutine vertical_remapping_requirements_blended_area_weighted_real4(delp, area, ptop, phalf, upsampled_coarse_phalf, blending_weights) + real(kind=4), intent(in) :: delp(is:ie,js:je,1:npz) + real(kind=4), intent(in) :: area(is:ie,js:je) + real(kind=4), intent(in) :: ptop + real(kind=4), intent(out) :: phalf(is:ie,js:je,1:npz+1) + real(kind=4), intent(out) :: upsampled_coarse_phalf(is:ie,js:je,1:npz+1) + real(kind=4), intent(out) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=4), allocatable :: coarse_delp(:,:,:), coarse_phalf(:,:,:) + integer :: x_pad, y_pad + + allocate(coarse_delp(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + allocate(coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1)) + + call compute_phalf_from_delp(delp(is:ie,js:je,1:npz), ptop, is, ie, js, je, phalf) + call weighted_block_average(area(is:ie,js:je), delp(is:ie,js:je,1:npz), coarse_delp) + call compute_phalf_from_delp(coarse_delp, ptop, is_coarse, ie_coarse, js_coarse, je_coarse, coarse_phalf) + call block_upsample(coarse_phalf, upsampled_coarse_phalf, npz+1) + + x_pad = 0 + y_pad = 0 + call compute_blending_weights_agrid(phalf, coarse_phalf, blending_weights, x_pad, y_pad) + + deallocate(coarse_delp) + deallocate(coarse_phalf) + end subroutine vertical_remapping_requirements_blended_area_weighted_real4 + + subroutine vertical_remapping_requirements_blended_area_weighted_real8(delp, area, ptop, phalf, upsampled_coarse_phalf, blending_weights) + real(kind=8), intent(in) :: delp(is:ie,js:je,1:npz) + real(kind=8), intent(in) :: area(is:ie,js:je) + real(kind=8), intent(in) :: ptop + real(kind=8), intent(out) :: phalf(is:ie,js:je,1:npz+1) + real(kind=8), intent(out) :: upsampled_coarse_phalf(is:ie,js:je,1:npz+1) + real(kind=8), intent(out) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=8), allocatable :: coarse_delp(:,:,:), coarse_phalf(:,:,:) + integer :: x_pad, y_pad + + allocate(coarse_delp(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + allocate(coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1)) + + call compute_phalf_from_delp(delp(is:ie,js:je,1:npz), ptop, is, ie, js, je, phalf) + call weighted_block_average(area(is:ie,js:je), delp(is:ie,js:je,1:npz), coarse_delp) + call compute_phalf_from_delp(coarse_delp, ptop, is_coarse, ie_coarse, js_coarse, je_coarse, coarse_phalf) + call block_upsample(coarse_phalf, upsampled_coarse_phalf, npz+1) + + x_pad = 0 + y_pad = 0 + call compute_blending_weights_agrid(phalf, coarse_phalf, blending_weights, x_pad, y_pad) + + deallocate(coarse_delp) + deallocate(coarse_phalf) + end subroutine vertical_remapping_requirements_blended_area_weighted_real8 + + subroutine mask_area_weights_real4(area, phalf, upsampled_coarse_phalf, extrapolate, masked_area_weights) real(kind=4), intent(in) :: area(is:ie,js:je) real(kind=4), intent(in) :: phalf(is:ie,js:je,1:npz+1) real(kind=4), intent(in) :: upsampled_coarse_phalf(is:ie,js:je,1:npz+1) + logical, intent(in) :: extrapolate real(kind=4), intent(out) :: masked_area_weights(is:ie,js:je,1:npz) + real(kind=4), allocatable :: upsampled_coarse_pfull(:,:,:) integer :: k - do k = 1, npz - where (upsampled_coarse_phalf(is:ie,js:je,k+1) .lt. phalf(is:ie,js:je,npz+1)) - masked_area_weights(is:ie,js:je,k) = area(is:ie,js:je) - elsewhere - masked_area_weights(is:ie,js:je,k) = 0.0 - endwhere - enddo + ! Even in "extrapolation" mode we extrapolate in a limited sense. We use + ! nearest neighbor extrapolation in the event that the pressure at the + ! vertical midpoint of the cell is less than that of the surface pressure + ! in the fine-grid column; otherwise do not attempt to extrapolate and + ! mask the points when computing horizontal averages. This approach + ! allows us to generally use all grid cells in the lowest model level + ! over ocean, while maintaining masking in land regions with variable + ! topography; our stricter no-extrapolation approach often masks 50% or so + ! of the grid cells there. + if (extrapolate) then + allocate(upsampled_coarse_pfull(is:ie,js:je,1:npz)) + call compute_pfull_from_phalf(upsampled_coarse_phalf, upsampled_coarse_pfull) + + do k = 1, npz + where (upsampled_coarse_pfull(is:ie,js:je,k) .lt. phalf(is:ie,js:je,npz+1)) + masked_area_weights(is:ie,js:je,k) = area(is:ie,js:je) + elsewhere + masked_area_weights(is:ie,js:je,k) = 0.0 + endwhere + enddo + else + do k = 1, npz + where (upsampled_coarse_phalf(is:ie,js:je,k+1) .lt. phalf(is:ie,js:je,npz+1)) + masked_area_weights(is:ie,js:je,k) = area(is:ie,js:je) + elsewhere + masked_area_weights(is:ie,js:je,k) = 0.0 + endwhere + enddo + endif end subroutine mask_area_weights_real4 - subroutine mask_area_weights_real8(area, phalf, upsampled_coarse_phalf, masked_area_weights) + subroutine mask_area_weights_real8(area, phalf, upsampled_coarse_phalf, extrapolate, masked_area_weights) real(kind=8), intent(in) :: area(is:ie,js:je) real(kind=8), intent(in) :: phalf(is:ie,js:je,1:npz+1) real(kind=8), intent(in) :: upsampled_coarse_phalf(is:ie,js:je,1:npz+1) + logical, intent(in) :: extrapolate real(kind=8), intent(out) :: masked_area_weights(is:ie,js:je,1:npz) + real(kind=8), allocatable :: upsampled_coarse_pfull(:,:,:) integer :: k - do k = 1, npz - where (upsampled_coarse_phalf(is:ie,js:je,k+1) .lt. phalf(is:ie,js:je,npz+1)) - masked_area_weights(is:ie,js:je,k) = area(is:ie,js:je) - elsewhere - masked_area_weights(is:ie,js:je,k) = 0.0 - endwhere - enddo + ! Even in "extrapolation" mode we extrapolate in a limited sense. We use + ! nearest neighbor extrapolation in the event that the pressure at the + ! vertical midpoint of the cell is less than that of the surface pressure + ! in the fine-grid column; otherwise do not attempt to extrapolate and + ! mask the points when computing horizontal averages. This approach + ! allows us to generally use all grid cells in the lowest model level + ! over ocean, while maintaining masking in land regions with variable + ! topography; our stricter no-extrapolation approach often masks 50% or so + ! of the grid cells there. + if (extrapolate) then + allocate(upsampled_coarse_pfull(is:ie,js:je,1:npz)) + call compute_pfull_from_phalf(upsampled_coarse_phalf, upsampled_coarse_pfull) + + do k = 1, npz + where (upsampled_coarse_pfull(is:ie,js:je,k) .lt. phalf(is:ie,js:je,npz+1)) + masked_area_weights(is:ie,js:je,k) = area(is:ie,js:je) + elsewhere + masked_area_weights(is:ie,js:je,k) = 0.0 + endwhere + enddo + else + do k = 1, npz + where (upsampled_coarse_phalf(is:ie,js:je,k+1) .lt. phalf(is:ie,js:je,npz+1)) + masked_area_weights(is:ie,js:je,k) = area(is:ie,js:je) + elsewhere + masked_area_weights(is:ie,js:je,k) = 0.0 + endwhere + enddo + endif end subroutine mask_area_weights_real8 ! A naive routine for interpolating a field from the A-grid to the y-boundary @@ -1119,14 +1294,16 @@ subroutine upsample_d_grid_x(field_in, field_out, nz) enddo end subroutine upsample_d_grid_x - subroutine remap_edges_along_x(field, phalf, dx, ptop, result) + subroutine remap_edges_along_x(field, phalf, dx, ptop, extrapolate, result) real, intent(in) :: field(is:ie,js:je+1,1:npz) real, intent(in) :: phalf(is-1,ie+1,js-1,je+1,1:npz+1) real, intent(in) :: dx(is:ie,js:je+1) real, intent(in) :: ptop + logical, intent(in) :: extrapolate real, intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz) real, allocatable, dimension(:,:,:) :: phalf_d_grid, coarse_phalf_d_grid, coarse_phalf_d_grid_on_fine, remapped + real, allocatable, dimension(:,:,:) :: coarse_pfull_d_grid_on_fine logical, allocatable :: mask(:,:,:) integer :: i, i_coarse, j, j_coarse, k, kn, km, kord, iv @@ -1160,13 +1337,35 @@ subroutine remap_edges_along_x(field, phalf, dx, ptop, result) enddo ! 5. Create mask - do k = 1, npz - where (coarse_phalf_d_grid_on_fine(:,:,k+1) .lt. phalf_d_grid(:,:,npz+1)) - mask(:,:,k) = .true. - elsewhere - mask(:,:,k) = .false. - endwhere - enddo + if (extrapolate) then + allocate(coarse_pfull_d_grid_on_fine(is:ie,js_coarse:je_coarse+1,1:npz)) + call compute_pfull_from_phalf_d_grid_x(coarse_phalf_d_grid_on_fine, coarse_pfull_d_grid_on_fine) + + ! Even in "extrapolation" mode we extrapolate in a limited sense. We use + ! nearest neighbor extrapolation in the event that the pressure at the + ! vertical midpoint of the cell is less than that of the surface pressure + ! in the fine-grid column; otherwise do not attempt to extrapolate and + ! mask the points when computing horizontal averages. This approach + ! allows us to generally use all grid cells in the lowest model level + ! over ocean, while maintaining masking in land regions with variable + ! topography; our stricter no-extrapolation approach often masks 50% or so + ! of the grid cells there. + do k = 1, npz + where (coarse_pfull_d_grid_on_fine(:,:,k) .lt. phalf_d_grid(:,:,npz+1)) + mask(:,:,k) = .true. + elsewhere + mask(:,:,k) = .false. + endwhere + enddo + else + do k = 1, npz + where (coarse_phalf_d_grid_on_fine(:,:,k+1) .lt. phalf_d_grid(:,:,npz+1)) + mask(:,:,k) = .true. + elsewhere + mask(:,:,k) = .false. + endwhere + enddo + endif ! 6. Coarsen the remapped field call weighted_block_edge_average_x_pre_downsampled(remapped, dx, result, mask, npz) @@ -1264,16 +1463,18 @@ subroutine upsample_d_grid_y(field_in, field_out, nz) enddo end subroutine upsample_d_grid_y - subroutine remap_edges_along_y(field, phalf, dy, ptop, result) + subroutine remap_edges_along_y(field, phalf, dy, ptop, extrapolate, result) real, intent(in) :: field(is:ie+1,js:je,1:npz) real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) real, intent(in) :: dy(is:ie+1,js:je) real, intent(in) :: ptop + logical, intent(in) :: extrapolate real, intent(out) :: result(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz) real, allocatable, dimension(:,:,:) :: phalf_d_grid, coarse_phalf_d_grid, coarse_phalf_d_grid_on_fine, remapped + real, allocatable, dimension(:,:,:) :: coarse_pfull_d_grid_on_fine logical, allocatable :: mask(:,:,:) - + integer :: i, i_coarse, j, j_coarse, k, kn, km, kord, iv allocate(phalf_d_grid(is_coarse:ie_coarse+1,js:je,1:npz+1)) @@ -1305,13 +1506,35 @@ subroutine remap_edges_along_y(field, phalf, dy, ptop, result) enddo ! 5. Create mask - do k = 1, npz - where (coarse_phalf_d_grid_on_fine(:,:,k+1) .lt. phalf_d_grid(:,:,npz+1)) - mask(:,:,k) = .true. - elsewhere - mask(:,:,k) = .false. - endwhere - enddo + if (extrapolate) then + allocate(coarse_pfull_d_grid_on_fine(is_coarse:ie_coarse+1,js:je,1:npz)) + call compute_pfull_from_phalf_d_grid_y(coarse_phalf_d_grid_on_fine, coarse_pfull_d_grid_on_fine) + + ! Even in "extrapolation" mode we extrapolate in a limited sense. We use + ! nearest neighbor extrapolation in the event that the pressure at the + ! vertical midpoint of the cell is less than that of the surface pressure + ! in the fine-grid column; otherwise do not attempt to extrapolate and + ! mask the points when computing horizontal averages. This approach + ! allows us to generally use all grid cells in the lowest model level + ! over ocean, while maintaining masking in land regions with variable + ! topography; our stricter no-extrapolation approach often masks 50% or so + ! of the grid cells there. + do k = 1, npz + where (coarse_pfull_d_grid_on_fine(:,:,k) .lt. phalf_d_grid(:,:,npz+1)) + mask(:,:,k) = .true. + elsewhere + mask(:,:,k) = .false. + endwhere + enddo + else + do k = 1, npz + where (coarse_phalf_d_grid_on_fine(:,:,k+1) .lt. phalf_d_grid(:,:,npz+1)) + mask(:,:,k) = .true. + elsewhere + mask(:,:,k) = .false. + endwhere + enddo + endif ! 6. Coarsen the remapped field call weighted_block_edge_average_y_pre_downsampled(remapped, dy, result, mask, npz) @@ -1428,6 +1651,316 @@ subroutine eddy_covariance_3d_weights(weights, field_a, field_b, coarse) call weighted_block_average(weights, anom_a * anom_b, coarse) end subroutine eddy_covariance_3d_weights + subroutine compute_blending_weights_agrid_real4(phalf, coarse_phalf, blending_weights, x_pad, y_pad) + integer :: x_pad, y_pad + real(kind=4), intent(in) :: phalf(is-x_pad:ie+x_pad,js-y_pad:je+y_pad,1:npz+1) + real(kind=4), intent(in) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1) + real(kind=4), intent(out) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=4), allocatable, dimension(:,:) :: blending_pressure, coarse_surface_pressure + real(kind=4), allocatable :: coarse_pfull(:,:,:) + + integer :: k, x_pad_coarse, y_pad_coarse + + allocate(blending_pressure(is_coarse:ie_coarse,js_coarse:je_coarse)) + allocate(coarse_pfull(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + allocate(coarse_surface_pressure(is_coarse:ie_coarse,js_coarse:je_coarse)) + + coarse_surface_pressure = coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,npz+1) + + x_pad_coarse = 0 + y_pad_coarse = 0 + call compute_coarse_pfull(coarse_phalf, coarse_pfull, x_pad_coarse, y_pad_coarse) + call block_min(phalf(is:ie,js:je,npz+1), blending_pressure) + blending_pressure = sigma_blend * blending_pressure + do k = 1, npz + where (coarse_pfull(:,:,k) .gt. blending_pressure) + blending_weights(:,:,k) = (coarse_surface_pressure - coarse_pfull(:,:,k)) / & + (coarse_surface_pressure - blending_pressure) + elsewhere + blending_weights(:,:,k) = 1.0 + endwhere + enddo + end subroutine compute_blending_weights_agrid_real4 + + subroutine compute_blending_weights_dgrid_u(phalf, dx, blending_weights) + real, intent(in) :: phalf(is-1:is+1,js-1:js+1,1:npz+1) + real, intent(in) :: dx(is:ie,js:je+1) + real, intent(out) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz) + + real, allocatable, dimension(:,:,:) :: phalf_d_grid, coarse_phalf_d_grid, coarse_pfull_d_grid + real, allocatable, dimension(:,:) :: blending_pressure, coarse_surface_pressure + + integer :: k, x_pad, y_pad + + allocate(phalf_d_grid(is:ie,js_coarse:je_coarse+1,1:npz+1)) + allocate(coarse_phalf_d_grid(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz+1)) + allocate(coarse_pfull_d_grid(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz)) + allocate(blending_pressure(is_coarse:ie_coarse,js_coarse:je_coarse+1)) + allocate(coarse_surface_pressure(is_coarse:ie_coarse,js_coarse:je_coarse+1)) + + call interpolate_to_d_grid_and_downsample_along_y(phalf, phalf_d_grid, npz+1) + call weighted_block_edge_average_x_pre_downsampled(phalf_d_grid, dx, coarse_phalf_d_grid, npz+1) + + x_pad = 0 + y_pad = 1 + call compute_coarse_pfull(coarse_phalf_d_grid, coarse_pfull_d_grid, x_pad, y_pad) + call block_edge_min_x(phalf_d_grid(is:ie,js_coarse:je_coarse+1,npz+1), blending_pressure) + coarse_surface_pressure = coarse_phalf_d_grid(is_coarse:ie_coarse,js_coarse:je_coarse+1,npz+1) + blending_pressure = sigma_blend * blending_pressure + + do k = 1, npz + where (coarse_pfull_d_grid(:,:,k) .gt. blending_pressure) + blending_weights(:,:,k) = (coarse_surface_pressure - coarse_pfull_d_grid(:,:,k)) / & + (coarse_surface_pressure - blending_pressure) + elsewhere + blending_weights(:,:,k) = 1.0 + endwhere + enddo + end subroutine compute_blending_weights_dgrid_u + + subroutine compute_blending_weights_dgrid_v(phalf, dy, blending_weights) + real, intent(in) :: phalf(is-1:is+1,js-1:js+1,1:npz+1) + real, intent(in) :: dy(is:ie+1,js:je) + real, intent(out) :: blending_weights(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz) + + real, allocatable, dimension(:,:,:) :: phalf_d_grid, coarse_phalf_d_grid, coarse_pfull_d_grid + real, allocatable, dimension(:,:) :: blending_pressure, coarse_surface_pressure + + integer :: k, x_pad, y_pad + + allocate(phalf_d_grid(is_coarse:ie_coarse+1,js:je,1:npz+1)) + allocate(coarse_phalf_d_grid(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz+1)) + allocate(coarse_pfull_d_grid(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz)) + allocate(blending_pressure(is_coarse:ie_coarse+1,js_coarse:je_coarse)) + allocate(coarse_surface_pressure(is_coarse:ie_coarse+1,js_coarse:je_coarse)) + + call interpolate_to_d_grid_and_downsample_along_x(phalf, phalf_d_grid, npz+1) + call weighted_block_edge_average_y_pre_downsampled(phalf_d_grid, dy, coarse_phalf_d_grid, npz+1) + + x_pad = 1 + y_pad = 0 + call compute_coarse_pfull(coarse_phalf_d_grid, coarse_pfull_d_grid, x_pad, y_pad) + call block_edge_min_y(phalf_d_grid(is_coarse:ie_coarse+1,js:je,npz+1), blending_pressure) + coarse_surface_pressure = coarse_phalf_d_grid(is_coarse:ie_coarse+1,js_coarse:je_coarse,npz+1) + blending_pressure = sigma_blend * blending_pressure + + do k = 1, npz + where (coarse_pfull_d_grid(:,:,k) .gt. blending_pressure) + blending_weights(:,:,k) = (coarse_surface_pressure - coarse_pfull_d_grid(:,:,k)) / & + (coarse_surface_pressure - blending_pressure) + elsewhere + blending_weights(:,:,k) = 1.0 + endwhere + enddo + end subroutine compute_blending_weights_dgrid_v + + subroutine compute_coarse_pfull_real4(coarse_phalf, coarse_pfull, x_pad, y_pad) + integer, intent(in) :: x_pad, y_pad + real(kind=4), intent(in) :: coarse_phalf(is_coarse:ie_coarse+x_pad,js_coarse:je_coarse+y_pad,1:npz+1) + real(kind=4), intent(out) :: coarse_pfull(is_coarse:ie_coarse+x_pad,js_coarse:je_coarse+y_pad,1:npz) + + coarse_pfull = (coarse_phalf(:,:,1:npz) - coarse_phalf(:,:,2:npz+1)) / & + (log(coarse_phalf(:,:,1:npz)) - log(coarse_phalf(:,:,2:npz+1))) + end subroutine compute_coarse_pfull_real4 + + subroutine pressure_coarse_grain_field_real4(field, phalf, coarse_phalf_on_fine, ptop, masked_area_weights, result) + real(kind=4), intent(in), dimension(is:ie,js:je,1:npz) :: field, masked_area_weights + real(kind=4), intent(in), dimension(is:ie,js:je,1:npz+1) :: phalf, coarse_phalf_on_fine + real(kind=4), intent(in) :: ptop + real(kind=4), intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=4), allocatable :: remapped(:,:,:) + + allocate(remapped(is:ie,js:je,1:npz)) + + call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), field(is:ie,js:je,1:npz), coarse_phalf_on_fine, ptop, remapped) + call weighted_block_average(masked_area_weights, remapped, result) + end subroutine pressure_coarse_grain_field_real4 + + subroutine blended_area_weighted_coarse_grain_field_real4(field, phalf, coarse_phalf_on_fine, ptop, masked_area_weights,& + model_level_weights, blending_weights, result) + real(kind=4), intent(in), dimension(is:ie,js:je,1:npz) :: field, masked_area_weights + real(kind=4), intent(in), dimension(is:ie,js:je,1:npz+1) :: phalf, coarse_phalf_on_fine + real(kind=4), intent(in) :: ptop + real(kind=4), intent(in) :: model_level_weights(is:ie,js:je) + real(kind=4), intent(in) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + real(kind=4), intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=4), allocatable, dimension(:,:,:) :: pressure_coarse_grained, remapped + + allocate(remapped(is:ie,js:je,1:npz)) + allocate(pressure_coarse_grained(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + + call pressure_coarse_grain_field(field, phalf, coarse_phalf_on_fine, ptop, masked_area_weights, pressure_coarse_grained) + call weighted_block_average(model_level_weights, field, result) + result = blending_weights * pressure_coarse_grained + (1 - blending_weights) * result + end subroutine blended_area_weighted_coarse_grain_field_real4 + + subroutine blended_length_weighted_coarse_grain_u(u, phalf, dx, ptop, blending_weights, u_coarse) + real, intent(in) :: u(is:ie,js:je+1,1:npz) + real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) + real, intent(in) :: dx(is:ie,js:je+1) + real, intent(in) :: ptop + real, intent(in) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz) + real, intent(out) :: u_coarse(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz) + + logical :: extrapolate = .false. + real, allocatable :: pressure_coarse_grained(:,:,:) + + allocate(pressure_coarse_grained(is_coarse:ie_coarse,js_coarse:je_coarse+1,1:npz)) + + call remap_edges_along_x(u, phalf, dx, ptop, extrapolate, pressure_coarse_grained) + call weighted_block_edge_average_x(dx, u, u_coarse) + u_coarse = blending_weights * pressure_coarse_grained + (1 - blending_weights) * u_coarse + end subroutine blended_length_weighted_coarse_grain_u + + subroutine blended_length_weighted_coarse_grain_v(v, phalf, dy, ptop, blending_weights, v_coarse) + real, intent(in) :: v(is:ie+1,js:je,1:npz) + real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1) + real, intent(in) :: dy(is:ie+1,js:je) + real, intent(in) :: ptop + real, intent(in) :: blending_weights(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz) + real, intent(out) :: v_coarse(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz) + + logical :: extrapolate = .false. + real, allocatable :: pressure_coarse_grained(:,:,:) + + allocate(pressure_coarse_grained(is_coarse:ie_coarse+1,js_coarse:je_coarse,1:npz)) + + call remap_edges_along_y(v, phalf, dy, ptop, extrapolate, pressure_coarse_grained) + call weighted_block_edge_average_y(dy, v, v_coarse) + v_coarse = blending_weights * pressure_coarse_grained + (1 - blending_weights) * v_coarse + end subroutine blended_length_weighted_coarse_grain_v + + subroutine compute_blending_weights_agrid_real8(phalf, coarse_phalf, blending_weights, x_pad, y_pad) + integer :: x_pad, y_pad + real(kind=8), intent(in) :: phalf(is-x_pad:ie+x_pad,js-y_pad:je+y_pad,1:npz+1) + real(kind=8), intent(in) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1) + real(kind=8), intent(out) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=8), allocatable, dimension(:,:) :: blending_pressure, coarse_surface_pressure + real(kind=8), allocatable :: coarse_pfull(:,:,:) + + integer :: k, x_pad_coarse, y_pad_coarse + + allocate(blending_pressure(is_coarse:ie_coarse,js_coarse:je_coarse)) + allocate(coarse_pfull(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + allocate(coarse_surface_pressure(is_coarse:ie_coarse,js_coarse:je_coarse)) + + coarse_surface_pressure = coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,npz+1) + + x_pad_coarse = 0 + y_pad_coarse = 0 + call compute_coarse_pfull(coarse_phalf, coarse_pfull, x_pad_coarse, y_pad_coarse) + call block_min(phalf(is:ie,js:je,npz+1), blending_pressure) + blending_pressure = sigma_blend * blending_pressure + do k = 1, npz + where (coarse_pfull(:,:,k) .gt. blending_pressure) + blending_weights(:,:,k) = (coarse_surface_pressure - coarse_pfull(:,:,k)) / & + (coarse_surface_pressure - blending_pressure) + elsewhere + blending_weights(:,:,k) = 1.0 + endwhere + enddo + end subroutine compute_blending_weights_agrid_real8 + + subroutine compute_coarse_pfull_real8(coarse_phalf, coarse_pfull, x_pad, y_pad) + integer, intent(in) :: x_pad, y_pad + real(kind=8), intent(in) :: coarse_phalf(is_coarse:ie_coarse+x_pad,js_coarse:je_coarse+y_pad,1:npz+1) + real(kind=8), intent(out) :: coarse_pfull(is_coarse:ie_coarse+x_pad,js_coarse:je_coarse+y_pad,1:npz) + + coarse_pfull = (coarse_phalf(:,:,1:npz) - coarse_phalf(:,:,2:npz+1)) / & + (log(coarse_phalf(:,:,1:npz)) - log(coarse_phalf(:,:,2:npz+1))) + end subroutine compute_coarse_pfull_real8 + + subroutine pressure_coarse_grain_field_real8(field, phalf, coarse_phalf_on_fine, ptop, masked_area_weights, result) + real(kind=8), intent(in), dimension(is:ie,js:je,1:npz) :: field, masked_area_weights + real(kind=8), intent(in), dimension(is:ie,js:je,1:npz+1) :: phalf, coarse_phalf_on_fine + real(kind=8), intent(in) :: ptop + real(kind=8), intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=8), allocatable :: remapped(:,:,:) + + allocate(remapped(is:ie,js:je,1:npz)) + + call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), field(is:ie,js:je,1:npz), coarse_phalf_on_fine, ptop, remapped) + call weighted_block_average(masked_area_weights, remapped, result) + end subroutine pressure_coarse_grain_field_real8 + + subroutine blended_area_weighted_coarse_grain_field_real8(field, phalf, coarse_phalf_on_fine, ptop, masked_area_weights,& + model_level_weights, blending_weights, result) + real(kind=8), intent(in), dimension(is:ie,js:je,1:npz) :: field, masked_area_weights + real(kind=8), intent(in), dimension(is:ie,js:je,1:npz+1) :: phalf, coarse_phalf_on_fine + real(kind=8), intent(in) :: ptop + real(kind=8), intent(in) :: model_level_weights(is:ie,js:je) + real(kind=8), intent(in) :: blending_weights(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + real(kind=8), intent(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz) + + real(kind=8), allocatable, dimension(:,:,:) :: pressure_coarse_grained, remapped + + allocate(remapped(is:ie,js:je,1:npz)) + allocate(pressure_coarse_grained(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)) + + call pressure_coarse_grain_field(field, phalf, coarse_phalf_on_fine, ptop, masked_area_weights, pressure_coarse_grained) + call weighted_block_average(model_level_weights, field, result) + result = blending_weights * pressure_coarse_grained + (1 - blending_weights) * result + end subroutine blended_area_weighted_coarse_grain_field_real8 + + ! Compute pressure at layer midpoints following Eq. 3.17 of Simmons + ! and Burridge (1981), MWR. + subroutine compute_pfull_from_phalf_real4(phalf, pfull) + real(kind=4), intent(in) :: phalf(is:ie,js:je,1:npz+1) + real(kind=4), intent(out) :: pfull(is:ie,js:je,1:npz) + + integer :: k + + do k = 1, npz + pfull(:,:,k) = & + (phalf(:,:,k+1) - phalf(:,:,k)) / & + (log(phalf(:,:,k+1)) - log(phalf(:,:,k))) + enddo + end subroutine compute_pfull_from_phalf_real4 + + subroutine compute_pfull_from_phalf_real8(phalf, pfull) + real(kind=8), intent(in) :: phalf(is:ie,js:je,1:npz+1) + real(kind=8), intent(out) :: pfull(is:ie,js:je,1:npz) + + integer :: k + + do k = 1, npz + pfull(:,:,k) = & + (phalf(:,:,k+1) - phalf(:,:,k)) / & + (log(phalf(:,:,k+1)) - log(phalf(:,:,k))) + enddo + end subroutine compute_pfull_from_phalf_real8 + + subroutine compute_pfull_from_phalf_d_grid_y(coarse_phalf_d_grid_on_fine, coarse_pfull_d_grid_on_fine) + real, intent(in) :: coarse_phalf_d_grid_on_fine(is_coarse:ie_coarse+1,js:je,1:npz+1) + real, intent(out) :: coarse_pfull_d_grid_on_fine(is_coarse:ie_coarse+1,js:je,1:npz) + + integer :: k + + do k = 1, npz + coarse_pfull_d_grid_on_fine(:,:,k) = & + (coarse_phalf_d_grid_on_fine(:,:,k+1) - coarse_phalf_d_grid_on_fine(:,:,k)) / & + (log(coarse_phalf_d_grid_on_fine(:,:,k+1)) - log(coarse_phalf_d_grid_on_fine(:,:,k))) + enddo + end subroutine + + subroutine compute_pfull_from_phalf_d_grid_x(coarse_phalf_d_grid_on_fine, coarse_pfull_d_grid_on_fine) + real, intent(in) :: coarse_phalf_d_grid_on_fine(is:ie,js_coarse:je_coarse+1,1:npz+1) + real, intent(out) :: coarse_pfull_d_grid_on_fine(is:ie,js_coarse:je_coarse+1,1:npz) + + integer :: k + + do k = 1, npz + coarse_pfull_d_grid_on_fine(:,:,k) = & + (coarse_phalf_d_grid_on_fine(:,:,k+1) - coarse_phalf_d_grid_on_fine(:,:,k)) / & + (log(coarse_phalf_d_grid_on_fine(:,:,k+1)) - log(coarse_phalf_d_grid_on_fine(:,:,k))) + enddo + end subroutine + ! Port mappm for single and double precision subroutine mappm_real4(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop) diff --git a/tools/external_aero.F90 b/tools/external_aero.F90 index e0a0b6d1d..04c69aef0 100644 --- a/tools/external_aero.F90 +++ b/tools/external_aero.F90 @@ -31,7 +31,7 @@ module external_aero_mod use fms2_io_mod, only: file_exists use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_npes, mpp_get_current_pelist use time_manager_mod, only: time_type - use fv_mapz_mod, only: map1_q2 + use fv_operators_mod, only: map1_q2 use fv_fill_mod, only: fillz public :: load_aero, read_aero, clean_aero diff --git a/tools/external_ic.F90 b/tools/external_ic.F90 index bc7711396..eb95a201f 100644 --- a/tools/external_ic.F90 +++ b/tools/external_ic.F90 @@ -52,7 +52,7 @@ module external_ic_mod use fv_diagnostics_mod,only: prt_maxmin, prt_mxm, prt_gb_nh_sh, prt_height use fv_grid_utils_mod, only: ptop_min, g_sum,mid_pt_sphere,get_unit_vect2,get_latlon_vector,inner_prod use fv_io_mod, only: fv_io_read_tracers - use fv_mapz_mod, only: mappm + use fv_operators_mod, only: mappm use fv_regional_mod, only: dump_field, H_STAGGER, U_STAGGER, V_STAGGER, get_data_source use fv_mp_mod, only: is_master, fill_corners, YDir, mp_reduce_min, mp_reduce_max use fv_regional_mod, only: start_regional_cold_start @@ -338,11 +338,11 @@ subroutine get_nggps_ic (Atm) character(len=64) :: fn_sfc_ics = 'INPUT/sfc_data.nc' character(len=64) :: fn_oro_ics = 'INPUT/oro_data.nc' logical :: remap - logical :: filtered_terrain = .true. - logical :: gfs_dwinds = .true. - integer :: levp = 64 - logical :: checker_tr = .false. - integer :: nt_checker = 0 + logical :: filtered_terrain = .true. !< use orography-maker filtered terrain for remapping and model orography + logical :: gfs_dwinds = .true. !< not used + integer :: levp = 64 !< not used + logical :: checker_tr = .false. !< whether to create idealized checkerboard pattern + integer :: nt_checker = 0 !< number of tracers to initialize with checkerboard pattern character(len=20) :: suffix character(len=1) :: tile_num real(kind=R_GRID), dimension(2):: p1, p2, p3 diff --git a/tools/fv_diag_column.F90 b/tools/fv_diag_column.F90 index 127df3022..3c6bc52ce 100644 --- a/tools/fv_diag_column.F90 +++ b/tools/fv_diag_column.F90 @@ -28,7 +28,7 @@ module fv_diag_column_mod use constants_mod, only: grav, rdgas, kappa, cp_air, TFREEZE, pi=>pi_8 use fms_mod, only: write_version_number, lowercase use mpp_mod, only: mpp_error, FATAL, stdlog, mpp_pe, mpp_root_pe, mpp_sum, & - mpp_max, NOTE, input_nml_file, get_unit + mpp_max, NOTE, input_nml_file use gfdl_mp_mod, only: mqs3d implicit none @@ -152,8 +152,7 @@ subroutine read_column_table character(len=256) :: record character(len=10) :: dum1, dum2 - iunit = get_unit() - open(iunit, file='column_table', action='READ', iostat=io) + open(newunit=iunit, file='column_table', action='READ', iostat=io) if(io/=0) call mpp_error(FATAL, ' find_diagnostic_column: Error in opening column_table') num_diag_debug=0 @@ -435,13 +434,14 @@ subroutine debug_column(pt, delp, delz, u, v, w, q, npz, ncnst, sphum, nwat, zvi end subroutine debug_column subroutine debug_column_dyn(pt, delp, delz, u, v, w, q, heat_source, cappa, akap, & - use_heat_source, npz, ncnst, sphum, nwat, zvir, ptop, hydrostatic, bd, Time, k_step, n_step) + npz, ncnst, sphum, nwat, zvir, ptop, hydrostatic, moist_kappa, bd, Time, k_step, n_step) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npz, ncnst, sphum, nwat, k_step, n_step real, intent(IN) :: akap, zvir, ptop - logical, intent(IN) :: hydrostatic, use_heat_source - real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: pt, delp, w, heat_source + logical, intent(IN) :: hydrostatic, moist_kappa + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: pt, delp, w + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: heat_source real, dimension(bd%is:, bd%js:,1:), intent(IN) :: delz real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz), intent(IN) :: u real, dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz), intent(IN) :: v @@ -503,11 +503,7 @@ subroutine debug_column_dyn(pt, delp, delz, u, v, w, q, heat_source, cappa, akap !NOTE: Moist cappa not implemented for hydrostatic dynamics. pk = exp(akap*log(preshyd(k))) temp = pt(i,j,k)*pk/virt - if (use_heat_source) then - heats = heat_source(i,j,k) / (cp_air*delp(i,j,k)) - else - heats = 0.0 - endif + heats = heat_source(i,j,k) / (cp_air*delp(i,j,k)) write(unit,'(I4, F7.2, F8.3, F8.3, F8.3, F8.3, F9.5, F9.3, 1x, G9.3)') & k, temp, delp(i,j,k)*0.01, u(i,j,k), v(i,j,k), & q(i,j,k,sphum)*1000., cond*1000., preshyd(k)*1.e-2, heats!, presdry*1.e-2, (presdry-preshyddry(k))*1.e-2 @@ -528,19 +524,15 @@ subroutine debug_column_dyn(pt, delp, delz, u, v, w, q, heat_source, cappa, akap cond = cond + q(i,j,k,l) enddo virt = (1.+zvir*q(i,j,k,sphum)) -#ifdef MOIST_CAPPA - pres = exp(1./(1.-cappa(i,j,k))*log(rdg*(delp(i,j,k)-cond)/delz(i,j,k)*pt(i,j,k)) ) - pk = exp(cappa(i,j,k)*log(pres)) -#else - pres = exp(1./(1.-akap)*log(rdg*(delp(i,j,k))/delz(i,j,k)*pt(i,j,k)) ) - pk = exp(akap*log(pres)) -#endif - temp = pt(i,j,k)*pk/virt - if (use_heat_source) then - heats = heat_source(i,j,k) / (cv_air*delp(i,j,k)) + if (moist_kappa) then + pres = exp(1./(1.-cappa(i,j,k))*log(rdg*(delp(i,j,k)-cond)/delz(i,j,k)*pt(i,j,k)) ) + pk = exp(cappa(i,j,k)*log(pres)) else - heats = 0.0 + pres = exp(1./(1.-akap)*log(rdg*(delp(i,j,k))/delz(i,j,k)*pt(i,j,k)) ) + pk = exp(akap*log(pres)) endif + temp = pt(i,j,k)*pk/virt + heats = heat_source(i,j,k) / (cv_air*delp(i,j,k)) write(unit,'(I4, F7.2, F8.3, I6, F8.3, F8.3, F8.3, F8.3, F9.5, F9.3, F9.3, 1x, G9.3 )') & k, temp, delp(i,j,k)*0.01, -int(delz(i,j,k)), u(i,j,k), v(i,j,k), w(i,j,k), & q(i,j,k,sphum)*1000., cond*1000., pres*1.e-2, (pres-preshyd(k))*1.e-2, heats diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90 index 758ecdd51..8a2446d5a 100644 --- a/tools/fv_diagnostics.F90 +++ b/tools/fv_diagnostics.F90 @@ -40,7 +40,8 @@ module fv_diagnostics_mod diag_field_add_attribute use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_diag_type, fv_grid_bounds_type, & R_GRID - use fv_mapz_mod, only: E_Flux, moist_cv, moist_cp, mappm + use fv_mapz_mod, only: E_Flux + use fv_operators_mod, only: mappm use fv_mp_mod, only: mp_reduce_sum, mp_reduce_min, mp_reduce_max, is_master use fv_eta_mod, only: get_eta_level, gw_1d use fv_grid_utils_mod, only: g_sum @@ -52,8 +53,8 @@ module fv_diagnostics_mod use mpp_mod, only: mpp_error, FATAL, stdlog, mpp_pe, mpp_root_pe, mpp_sum, mpp_max, NOTE, input_nml_file use sat_vapor_pres_mod, only: compute_qs, lookup_es - use fv_arrays_mod, only: max_step - use gfdl_mp_mod, only: wqs, mqs3d, qs_init, c_liq, rad_ref + use fv_arrays_mod, only: max_step + use gfdl_mp_mod, only: wqs, mqs3d, c_liq, rad_ref, cld_eff_rad use fv_diag_column_mod, only: fv_diag_column_init, sounding_column, debug_column @@ -82,13 +83,18 @@ module fv_diagnostics_mod logical :: prt_minmax =.false. logical :: m_calendar integer sphum, liq_wat, ice_wat, cld_amt ! GFDL physics - integer rainwat, snowwat, graupel, o3mr + integer rainwat, snowwat, graupel, o3mr, aerosol integer :: istep, mp_top real :: ptop real, parameter :: rad2deg = 180./pi logical :: do_diag_sonde, do_diag_debug integer :: sound_freq logical :: prt_sounding = .false. + integer :: user_prt_level = 1 + integer, parameter :: PRT_LEVEL_0 = 0 + integer, parameter :: PRT_LEVEL_1 = 1 + integer, parameter :: PRT_LEVEL_2 = 2 + integer, parameter :: PRT_LEVEL_3 = 3 ! tracers character(len=128) :: tname @@ -103,6 +109,7 @@ module fv_diagnostics_mod public :: cs3_interpolator, get_vorticity ! needed by fv_nggps_diag public :: max_vv, max_uh, bunkers_vector, helicity_relative_CAPS + public :: nplev, levs, id_plev public :: max_vorticity public :: Mw_air!_0d, Mw_air_3d @@ -112,11 +119,7 @@ module fv_diagnostics_mod end interface Mw_air integer, parameter :: MAX_PLEVS = 31 -#ifdef FEWER_PLEVS - integer :: nplev = 11 !< # of levels in plev interpolated standard level output, with levels given by levs. 11 by default -#else integer :: nplev = 31 !< # of levels in plev interpolated standard level output, with levels given by levs. 31 by default -#endif integer :: levs(MAX_PLEVS) !< levels for plev interpolated standard level output, in hPa (mb) in increasing order. Extended GFS std levels by default. integer :: k100, k200, k300, k500 integer :: nplev_ave @@ -124,9 +127,16 @@ module fv_diagnostics_mod integer :: yr_init, mo_init, dy_init, hr_init, mn_init, sec_init integer :: id_dx, id_dy + integer :: id_plev = 0 real :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2), psrange(2), skrange(2) + !Fields needed for diagnostics + real, allocatable :: w_mr(:) + real, allocatable :: phalf(:) + real, allocatable :: zsurf(:,:) + real, allocatable :: pt1(:) + ! integer :: id_d_grid_ucomp, id_d_grid_vcomp ! D grid winds ! integer :: id_c_grid_ucomp, id_c_grid_vcomp ! C grid winds @@ -148,6 +158,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) integer, intent(in) :: npx, npy, npz real, intent(in):: p_ref + real, allocatable :: grid_xt(:), grid_yt(:), grid_xe(:), grid_ye(:), grid_xn(:), grid_yn(:) real, allocatable :: grid_x(:), grid_y(:) real, allocatable :: a3(:,:,:) @@ -157,7 +168,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) !These id_* are not needed later since they are for static data which is not used elsewhere integer :: id_bk, id_pk, id_area, id_lon, id_lat, id_lont, id_latt, id_phalf, id_pfull integer :: id_hyam, id_hybm - integer :: id_plev, id_plev_ave_edges, id_plev_ave + integer :: id_plev_ave_edges, id_plev_ave integer :: i, j, k, m, n, ntileMe, id_xt, id_yt, id_x, id_y, id_xe, id_ye, id_xn, id_yn integer :: isd, ied, jsd, jed, isc, iec, jsc, jec @@ -204,6 +215,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) graupel = get_tracer_index (MODEL_ATMOS, 'graupel') o3mr = get_tracer_index (MODEL_ATMOS, 'o3mr') cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt') + aerosol = get_tracer_index (MODEL_ATMOS, 'aerosol') ! valid range for some fields @@ -240,8 +252,8 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) exit endif enddo - if ( Atm(1)%flagstruct%fv_debug .and. is_master() ) then - write(*,*) 'radar reflectivity: mp_top=', mp_top, 'pfull=', pfull(mp_top) + if ( (user_prt_level >= PRT_LEVEL_2 .or. Atm(1)%flagstruct%fv_debug) .and. is_master() ) then + write(*,'(2x, A, G20.8, A, G20.8)') 'radar reflectivity: mp_top=', mp_top, 'pfull=', pfull(mp_top) endif ! allocate(grid_xt(npx-1), grid_yt(npy-1), grid_xe(npx), grid_ye(npy-1), grid_xn(npx-1), grid_yn(npy)) @@ -344,23 +356,13 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) axes(3) = id_pfull axes(4) = id_phalf -! Selected pressure levels -! SJL note: 31 is enough here; if you need more levels you should do it OFF line - ! do not add more to prevent the model from slowing down too much. +! DEFAULT Selected pressure levels; change with fv_diag_plevs_nml levs = 0 -#ifdef FEWER_PLEVS - levs(1:nplev) = (/50,70,100,200,250,300,500,750,850,925,1000/) ! lmh mini-levs for MJO simulations - k100 = 3 - k200 = 4 - k300 = 6 - k500 = 7 -#else levs(1:nplev) = (/1,2,3,5,7,10,20,30,50,70,100,150,200,250,300,350,400,450,500,550,600,650,700,750,800,850,900,925,950,975,1000/) k100 = 11 k200 = 13 k300 = 15 k500 = 19 -#endif levs_ave = 0 levs_ave(1:4) = (/50,400,850,1000/) read(input_nml_file, nml=fv_diag_plevs_nml,iostat=ios) @@ -441,10 +443,8 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'dx', 'm') id_dy = register_static_field( trim(field), 'dy', (/id_x,id_yt/), & 'dy', 'm') -#ifndef DYNAMICS_ZS id_zsurf = register_static_field ( trim(field), 'zsurf', axes(1:2), & 'surface height', 'm', interp_method='conserve_order1' ) -#endif id_zs = register_static_field ( trim(field), 'zs', axes(1:2), & 'Original Mean Terrain', 'm' ) ! 3D hybrid_z fields: @@ -463,13 +463,13 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) ic_ps = register_static_field ( trim(field), 'ps_ic', axes(1:2), & 'initial surface pressure', 'Pa' ) ic_ua = register_static_field ( trim(field), 'ua_ic', axes(1:3), & - 'zonal wind', 'm/sec' ) + 'initial zonal wind', 'm/s' ) ic_va = register_static_field ( trim(field), 'va_ic', axes(1:3), & - 'meridional wind', 'm/sec' ) + 'initial meridional wind', 'm/s' ) ic_ppt= register_static_field ( trim(field), 'ppt_ic', axes(1:3), & - 'potential temperature perturbation', 'K' ) + 'initial potential temperature', 'K' ) ic_sphum = register_static_field ( trim(field), 'sphum_ic', axes(1:2), & - 'initial surface pressure', 'Pa' ) + 'initial surface pressure', 'Pa' ) !not used ! end do @@ -506,10 +506,12 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) if (id_dy > 0) used = send_data(id_dy, dy, Time) deallocate(dx, dy) -#ifndef DYNAMICS_ZS - if (id_zsurf > 0) used = send_data(id_zsurf, zsurf, Time) - call prt_mxm('ZS', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain) -#endif + if (id_zsurf > 0) then + used = send_data(id_zsurf, zsurf, Time) + call prt_mxm('ZS', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, & + Atm(n)%gridstruct%area_64, Atm(n)%domain,PRT_LEVEL_0) + endif + if ( Atm(n)%flagstruct%fv_land ) then if (id_zs > 0) used = send_data(id_zs , zs_g, Time) if (id_oro > 0) used = send_data(id_oro, Atm(n)%oro(isc:iec,jsc:jec), Time) @@ -569,37 +571,49 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) allocate(conv_vmr_mmr(ncnst)) conv_vmr_mmr(:) = .false. - allocate(id_u(nplev)) - allocate(id_v(nplev)) - allocate(id_t(nplev)) - allocate(id_h(nplev)) - allocate(id_q(nplev)) - allocate(id_ql(nplev)) - allocate(id_qi(nplev)) - allocate(id_qr(nplev)) - allocate(id_qs(nplev)) - allocate(id_qg(nplev)) - allocate(id_cf(nplev)) - allocate(id_omg(nplev)) - id_u(:) = 0 - id_v(:) = 0 - id_t(:) = 0 - id_h(:) = 0 - id_q(:) = 0 - id_ql(:) = 0 - id_qi(:) = 0 - id_qr(:) = 0 - id_qs(:) = 0 - id_qg(:) = 0 - id_cf(:) = 0 - id_omg(:) = 0 + allocate(id_u_levs(nplev)) + allocate(id_v_levs(nplev)) + allocate(id_t_levs(nplev)) + allocate(id_h_levs(nplev)) + allocate(id_q_levs(nplev)) + allocate(id_ql_levs(nplev)) + allocate(id_qi_levs(nplev)) + allocate(id_qr_levs(nplev)) + allocate(id_qs_levs(nplev)) + allocate(id_qg_levs(nplev)) + allocate(id_cf_levs(nplev)) + allocate(id_omg_levs(nplev)) + allocate(id_w_levs(nplev)) + allocate(id_vort_levs(nplev)) + allocate(id_rh_levs(nplev)) + allocate(id_dp_levs(nplev)) + allocate(id_theta_levs(nplev)) + allocate(id_theta_e_levs(nplev)) + id_u_levs(:) = 0 + id_v_levs(:) = 0 + id_t_levs(:) = 0 + id_h_levs(:) = 0 + id_q_levs(:) = 0 + id_ql_levs(:) = 0 + id_qi_levs(:) = 0 + id_qr_levs(:) = 0 + id_qs_levs(:) = 0 + id_qg_levs(:) = 0 + id_cf_levs(:) = 0 + id_omg_levs(:) = 0 + id_w_levs(:) = 0 + id_vort_levs(:) = 0 + id_rh_levs(:) = 0 + id_dp_levs(:) = 0 + id_theta_levs(:) = 0 + id_theta_e_levs(:) = 0 ! do n = 1, ntileMe n = 1 field= 'dynamics' #ifdef DYNAMICS_ZS - id_zsurf = register_diag_field ( trim(field), 'zsurf', axes(1:2), Time, & + id_zsurf_t = register_diag_field ( trim(field), 'zsurf_t', axes(1:2), Time, & 'surface height', 'm', interp_method='conserve_order1') #endif !------------------- @@ -637,6 +651,101 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) id_preg = register_diag_field ( trim(field), 'preg', axes(1:2), Time, & 'graupel precipitation', 'mm/day', missing_value=missing_value ) !------------------- +! Cloud effective radius +!------------------- + id_qcw = register_diag_field ( trim(field), 'qcw', axes(1:3), Time, & + 'cloud water water content', 'g/m^2', missing_value=missing_value ) + if (id_qcw > 0) allocate(Atm(n)%inline_mp%qcw(isc:iec,jsc:jec,npz)) + id_qcr = register_diag_field ( trim(field), 'qcr', axes(1:3), Time, & + 'rain water content', 'g/m^2', missing_value=missing_value ) + if (id_qcr > 0) allocate(Atm(n)%inline_mp%qcr(isc:iec,jsc:jec,npz)) + id_qci = register_diag_field ( trim(field), 'qci', axes(1:3), Time, & + 'cloud ice water content', 'g/m^2', missing_value=missing_value ) + if (id_qci > 0) allocate(Atm(n)%inline_mp%qci(isc:iec,jsc:jec,npz)) + id_qcs = register_diag_field ( trim(field), 'qcs', axes(1:3), Time, & + 'snow water content', 'g/m^2', missing_value=missing_value ) + if (id_qcs > 0) allocate(Atm(n)%inline_mp%qcs(isc:iec,jsc:jec,npz)) + id_qcg = register_diag_field ( trim(field), 'qcg', axes(1:3), Time, & + 'graupel water content', 'g/m^2', missing_value=missing_value ) + if (id_qcg > 0) allocate(Atm(n)%inline_mp%qcg(isc:iec,jsc:jec,npz)) + id_rew = register_diag_field ( trim(field), 'rew', axes(1:3), Time, & + 'cloud water effective radius', 'micron', missing_value=missing_value ) + if (id_rew > 0) allocate(Atm(n)%inline_mp%rew(isc:iec,jsc:jec,npz)) + id_rer = register_diag_field ( trim(field), 'rer', axes(1:3), Time, & + 'rain effective radius', 'micron', missing_value=missing_value ) + if (id_rer > 0) allocate(Atm(n)%inline_mp%rer(isc:iec,jsc:jec,npz)) + id_rei = register_diag_field ( trim(field), 'rei', axes(1:3), Time, & + 'cloud ice effective radius', 'micron', missing_value=missing_value ) + if (id_rei > 0) allocate(Atm(n)%inline_mp%rei(isc:iec,jsc:jec,npz)) + id_res = register_diag_field ( trim(field), 'res', axes(1:3), Time, & + 'snow effective radius', 'micron', missing_value=missing_value ) + if (id_res > 0) allocate(Atm(n)%inline_mp%res(isc:iec,jsc:jec,npz)) + id_reg = register_diag_field ( trim(field), 'reg', axes(1:3), Time, & + 'graupel effective radius', 'micron', missing_value=missing_value ) + if (id_reg > 0) allocate(Atm(n)%inline_mp%reg(isc:iec,jsc:jec,npz)) + id_cld = register_diag_field ( trim(field), 'cld', axes(1:3), Time, & + 'cloud fraction', '%', missing_value=missing_value ) + if (id_cld > 0) allocate(Atm(n)%inline_mp%cld(isc:iec,jsc:jec,npz)) +!------------------- +! Microphysical process diagnostic from GFDL MP +!------------------- + id_mppcw = register_diag_field ( trim(field), 'mppcw', axes(1:2), Time, & + 'Condensation (to Cloud Water) Rate', 'mm/day', missing_value=missing_value ) + id_mppew = register_diag_field ( trim(field), 'mppew', axes(1:2), Time, & + 'Evaporation (of Cloud Water) Rate', 'mm/day', missing_value=missing_value ) + id_mppe1 = register_diag_field ( trim(field), 'mppe1', axes(1:2), Time, & + 'Instant Evaporation (of Cloud Water) Rate', 'mm/day', missing_value=missing_value ) + id_mpper = register_diag_field ( trim(field), 'mpper', axes(1:2), Time, & + 'Evaporation (of Rain) Rate', 'mm/day', missing_value=missing_value ) + id_mppdi = register_diag_field ( trim(field), 'mppdi', axes(1:2), Time, & + 'Deposition (to Cloud Ice) Rate', 'mm/day', missing_value=missing_value ) + id_mppd1 = register_diag_field ( trim(field), 'mppd1', axes(1:2), Time, & + 'Instant Deposition (to Cloud Ice) Rate', 'mm/day', missing_value=missing_value ) + id_mppds = register_diag_field ( trim(field), 'mppds', axes(1:2), Time, & + 'Deposition (to Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mppdg = register_diag_field ( trim(field), 'mppdg', axes(1:2), Time, & + 'Deposition (to Graupel) Rate', 'mm/day', missing_value=missing_value ) + id_mppsi = register_diag_field ( trim(field), 'mppsi', axes(1:2), Time, & + 'Sublimation (of Cloud Ice) Rate', 'mm/day', missing_value=missing_value ) + id_mpps1 = register_diag_field ( trim(field), 'mpps1', axes(1:2), Time, & + 'Instant Sublimation (of Cloud Ice) Rate', 'mm/day', missing_value=missing_value ) + id_mppss = register_diag_field ( trim(field), 'mppss', axes(1:2), Time, & + 'Sublimation (of Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mppsg = register_diag_field ( trim(field), 'mppsg', axes(1:2), Time, & + 'Sublimation (of Graupel) Rate', 'mm/day', missing_value=missing_value ) + id_mppfw = register_diag_field ( trim(field), 'mppfw', axes(1:2), Time, & + 'Freezing (of Cloud Water) Rate', 'mm/day', missing_value=missing_value ) + id_mppfr = register_diag_field ( trim(field), 'mppfr', axes(1:2), Time, & + 'Freezing (of Rain) Rate', 'mm/day', missing_value=missing_value ) + id_mppmi = register_diag_field ( trim(field), 'mppmi', axes(1:2), Time, & + 'Melting (of Cloud Ice) Rate', 'mm/day', missing_value=missing_value ) + id_mppms = register_diag_field ( trim(field), 'mppms', axes(1:2), Time, & + 'Melting (of Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mppmg = register_diag_field ( trim(field), 'mppmg', axes(1:2), Time, & + 'Melting (of Graupel) Rate', 'mm/day', missing_value=missing_value ) + id_mppm1 = register_diag_field ( trim(field), 'mppm1', axes(1:2), Time, & + 'Sedimentational Melting (of Cloud Ice) Rate', 'mm/day', missing_value=missing_value ) + id_mppm2 = register_diag_field ( trim(field), 'mppm2', axes(1:2), Time, & + 'Sedimentational Melting (of Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mppm3 = register_diag_field ( trim(field), 'mppm3', axes(1:2), Time, & + 'Sedimentational Melting (of Graupel) Rate', 'mm/day', missing_value=missing_value ) + id_mppar = register_diag_field ( trim(field), 'mppar', axes(1:2), Time, & + 'Autoconversion (to Rain) Rate', 'mm/day', missing_value=missing_value ) + id_mppas = register_diag_field ( trim(field), 'mppas', axes(1:2), Time, & + 'Autoconversion (to Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mppag = register_diag_field ( trim(field), 'mppag', axes(1:2), Time, & + 'Autoconversion (to Graupel) Rate', 'mm/day', missing_value=missing_value ) + id_mpprs = register_diag_field ( trim(field), 'mpprs', axes(1:2), Time, & + 'Riming (to Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mpprg = register_diag_field ( trim(field), 'mpprg', axes(1:2), Time, & + 'Riming (to Graupel) Rate', 'mm/day', missing_value=missing_value ) + id_mppxr = register_diag_field ( trim(field), 'mppxr', axes(1:2), Time, & + 'Accretion (to Rain) Rate', 'mm/day', missing_value=missing_value ) + id_mppxs = register_diag_field ( trim(field), 'mppxs', axes(1:2), Time, & + 'Accretion (to Snow) Rate', 'mm/day', missing_value=missing_value ) + id_mppxg = register_diag_field ( trim(field), 'mppxg', axes(1:2), Time, & + 'Accretion (to Graupel) Rate', 'mm/day', missing_value=missing_value ) +!------------------- !! 3D Tendency terms from GFDL MP and physics !------------------- if (Atm(n)%flagstruct%write_3d_diags) then @@ -782,6 +891,14 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) allocate (Atm(n)%nudge_diag%nudge_v_dt(isc:iec,jsc:jec,npz)) Atm(n)%nudge_diag%nudge_v_dt(isc:iec,jsc:jec,1:npz) = 0.0 endif + id_qv_dt_nudge = register_diag_field('dynamics', & + 'qv_dt_nudge', axes(1:3), Time, & + 'specific humidity tendency from nudging', & + 'kg/kg/s', missing_value=missing_value) + if ((id_qv_dt_nudge > 0) .and. (.not. allocated(Atm(n)%nudge_diag%nudge_qv_dt))) then + allocate (Atm(n)%nudge_diag%nudge_qv_dt(isc:iec,jsc:jec,npz)) + Atm(n)%nudge_diag%nudge_qv_dt(isc:iec,jsc:jec,1:npz) = 0.0 + endif id_t_dt_diabatic = register_diag_field ( trim(field), 'T_dt_diabatic', axes(1:3), Time, & 'temperature tendency from diabatic processes (t_dt_phys + t_dt_gfdlmp)', 'K/s', missing_value=missing_value ) @@ -809,41 +926,59 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) do i=1,nplev write(plev,'(I5)') levs(i) ! Height: - id_h(i) = register_diag_field(trim(field), 'z'//trim(adjustl(plev)), axes(1:2), Time, & + id_h_levs(i) = register_diag_field(trim(field), 'z'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb height', 'm', missing_value=missing_value) ! u-wind: - id_u(i) = register_diag_field(trim(field), 'u'//trim(adjustl(plev)), axes(1:2), Time, & + id_u_levs(i) = register_diag_field(trim(field), 'u'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb u', 'm/s', missing_value=missing_value) ! v-wind: - id_v(i) = register_diag_field(trim(field), 'v'//trim(adjustl(plev)), axes(1:2), Time, & + id_v_levs(i) = register_diag_field(trim(field), 'v'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb v', 'm/s', missing_value=missing_value) ! Temperature (K): - id_t(i) = register_diag_field(trim(field), 't'//trim(adjustl(plev)), axes(1:2), Time, & + id_t_levs(i) = register_diag_field(trim(field), 't'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb temperature', 'K', missing_value=missing_value) ! specific humidity: - id_q(i) = register_diag_field(trim(field), 'q'//trim(adjustl(plev)), axes(1:2), Time, & + id_q_levs(i) = register_diag_field(trim(field), 'q'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb specific humidity', 'kg/kg', missing_value=missing_value) ! cloud water mass mixing ratio: - id_ql(i) = register_diag_field(trim(field), 'ql'//trim(adjustl(plev)), axes(1:2), Time, & + id_ql_levs(i) = register_diag_field(trim(field), 'ql'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb cloud water mass mixing ratio', 'kg/kg', missing_value=missing_value) ! cloud ice mass mixing ratio: - id_qi(i) = register_diag_field(trim(field), 'qi'//trim(adjustl(plev)), axes(1:2), Time, & + id_qi_levs(i) = register_diag_field(trim(field), 'qi'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb cloud ice mass mixing ratio', 'kg/kg', missing_value=missing_value) ! rain mass mixing ratio: - id_qr(i) = register_diag_field(trim(field), 'qr'//trim(adjustl(plev)), axes(1:2), Time, & + id_qr_levs(i) = register_diag_field(trim(field), 'qr'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb rain mass mixing ratio', 'kg/kg', missing_value=missing_value) ! snow mass mixing ratio: - id_qs(i) = register_diag_field(trim(field), 'qs'//trim(adjustl(plev)), axes(1:2), Time, & + id_qs_levs(i) = register_diag_field(trim(field), 'qs'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb snow mass mixing ratio', 'kg/kg', missing_value=missing_value) ! graupel mass mixing ratio: - id_qg(i) = register_diag_field(trim(field), 'qg'//trim(adjustl(plev)), axes(1:2), Time, & + id_qg_levs(i) = register_diag_field(trim(field), 'qg'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb graupel mass mixing ratio', 'kg/kg', missing_value=missing_value) ! cloud fraction: - id_cf(i) = register_diag_field(trim(field), 'cf'//trim(adjustl(plev)), axes(1:2), Time, & + id_cf_levs(i) = register_diag_field(trim(field), 'cf'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb cloud fraction', '1', missing_value=missing_value) ! Omega (Pa/sec): - id_omg(i) = register_diag_field(trim(field), 'omg'//trim(adjustl(plev)), axes(1:2), Time, & + id_omg_levs(i) = register_diag_field(trim(field), 'omg'//trim(adjustl(plev)), axes(1:2), Time, & trim(adjustl(plev))//'-mb omega', 'Pa/s', missing_value=missing_value) +! w (m/s) + id_w_levs(i) = register_diag_field(trim(field), 'w'//trim(adjustl(plev)), axes(1:2), Time, & + trim(adjustl(plev))//'-mb vertical velocity', 'm/s', missing_value=missing_value) +! vort (1/s) + id_vort_levs(i) = register_diag_field(trim(field), 'vort'//trim(adjustl(plev)), axes(1:2), Time, & + trim(adjustl(plev))//'-mb vertical vorticity', '1/s', missing_value=missing_value) +! rh (%) + id_rh_levs(i) = register_diag_field(trim(field), 'rh'//trim(adjustl(plev)), axes(1:2), Time, & + trim(adjustl(plev))//'-mb relative humidity', '%', missing_value=missing_value) +! dp (K) + id_dp_levs(i) = register_diag_field(trim(field), 'dp'//trim(adjustl(plev)), axes(1:2), Time, & + trim(adjustl(plev))//'-mb dew point', 'K', missing_value=missing_value) +! theta (K) + id_theta_levs(i) = register_diag_field(trim(field), 'theta'//trim(adjustl(plev)), axes(1:2), Time, & + trim(adjustl(plev))//'-mb potential temperature', 'K', missing_value=missing_value) +! theta_e (K) + id_theta_e_levs(i) = register_diag_field(trim(field), 'theta_e'//trim(adjustl(plev)), axes(1:2), Time, & + trim(adjustl(plev))//'-mb equivalent potential temperature', 'K', missing_value=missing_value) enddo if (Atm(n)%flagstruct%write_3d_diags) then @@ -876,6 +1011,18 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'cloud fraction', '1', missing_value=missing_value ) id_omg_plev = register_diag_field ( trim(field), 'omg_plev', axe2(1:3), Time, & 'omega', 'Pa/s', missing_value=missing_value ) + id_w_plev = register_diag_field ( trim(field), 'w_plev', axe2(1:3), Time, & + 'vertical velocity', 'm/s', missing_value=missing_value ) + id_vort_plev = register_diag_field ( trim(field), 'vort_plev', axe2(1:3), Time, & + 'vertical vorticity', '1/s', missing_value=missing_value ) + id_rh_plev = register_diag_field ( trim(field), 'rh_plev', axe2(1:3), Time, & + 'relative humidity', '%', missing_value=missing_value ) + id_dp_plev = register_diag_field ( trim(field), 'dp_plev', axe2(1:3), Time, & + 'dew point', 'K', missing_value=missing_value ) + id_theta_plev = register_diag_field ( trim(field), 'theta_plev', axe2(1:3), Time, & + 'potential temperature', 'K', missing_value=missing_value ) + id_theta_e_plev = register_diag_field ( trim(field), 'theta_e_plev', axe2(1:3), Time, & + 'equivalent potential temperature', 'K', missing_value=missing_value ) endif !Layer averages for temperature, moisture, etc. @@ -897,7 +1044,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) if (id_t_dt_phys_plev_ave > 0 .and. .not. allocated(Atm(n)%phys_diag%phys_t_dt) ) allocate(Atm(n)%phys_diag%phys_t_dt(isc:iec,jsc:jec,npz)) ! flag for calculation of geopotential - if ( any(id_h > 0) .or. id_h_plev>0 .or. id_hght3d>0) then + if ( any(id_h_levs > 0) .or. id_h_plev>0 .or. id_hght3d>0) then id_any_hght = 1 else id_any_hght = 0 @@ -965,17 +1112,21 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) id_pt = register_diag_field ( trim(field), 'temp', axes(1:3), Time, & 'temperature', 'K', missing_value=missing_value, range=trange ) endif - id_ppt = register_diag_field ( trim(field), 'ppt', axes(1:3), Time, & - 'potential temperature perturbation', 'K', missing_value=missing_value ) + id_ppt = register_diag_field ( trim(field), 'theta', axes(1:3), Time, & + 'potential temperature', 'K', missing_value=missing_value ) id_theta_e = register_diag_field ( trim(field), 'theta_e', axes(1:3), Time, & - 'theta_e', 'K', missing_value=missing_value ) + 'equivalent potential temperature', 'K', missing_value=missing_value ) id_omga = register_diag_field ( trim(field), 'omega', axes(1:3), Time, & 'omega', 'Pa/s', missing_value=missing_value ) idiag%id_divg = register_diag_field ( trim(field), 'divg', axes(1:3), Time, & - 'mean divergence', '1/s', missing_value=missing_value ) + 'instantaneous divergence', '1/s', missing_value=missing_value ) + idiag%id_divg_mean = register_diag_field ( trim(field), 'divg_mean', axes(1:3), Time, & + 'timestep-mean divergence', '1/s', missing_value=missing_value ) ! diagnotic output for skeb testing id_diss = register_diag_field ( trim(field), 'diss_est', axes(1:3), Time, & - 'random', 'none', missing_value=missing_value, range=skrange ) + 'Dissipation estimate', 'J/kg/s', missing_value=missing_value, range=skrange ) + id_diss_heat = register_diag_field ( trim(field), 'diss_heat', axes(1:3), Time, & + 'Dissipative heating rate', 'K/s', missing_value=missing_value ) id_hght3d = register_diag_field( trim(field), 'hght', axes(1:3), Time, & 'height', 'm', missing_value=missing_value ) @@ -1115,6 +1266,8 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'Echo top ( <= 18.5 dBz )', 'm', missing_value=missing_value2) id_dbz_m10C = register_diag_field ( trim(field), 'm10C_reflectivity', axes(1:2), time, & 'Reflectivity at -10C level', 'm', missing_value=missing_value) + id_40dbzht = register_diag_field ( trim(field), '40dBz_height', axes(1:2), time, & + 'Height of 40 dBz reflectivity', 'm', missing_value=missing_value) !-------------------------- ! Extra surface diagnostics: @@ -1173,15 +1326,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) id_acly = register_diag_field ( trim(field), 'acly', axes(1:2), Time, & 'Column-averaged total chlorine mixing ratio', 'kg/kg', missing_value=missing_value ) -!-------------------------- -! 850-mb vorticity -!-------------------------- - id_vort850 = register_diag_field ( trim(field), 'vort850', axes(1:2), Time, & - '850-mb vorticity', '1/s', missing_value=missing_value ) - - id_vort200 = register_diag_field ( trim(field), 'vort200', axes(1:2), Time, & - '200-mb vorticity', '1/s', missing_value=missing_value ) - ! Cubed_2_latlon interpolation is more accurate, particularly near the poles, using ! winds speed (a scalar), rather than wind vectors or kinetic energy directly. id_s200 = register_diag_field ( trim(field), 's200', axes(1:2), Time, & @@ -1198,24 +1342,12 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) id_qn850 = register_diag_field ( trim(field), 'qn850', axes(1:2), Time, & '850mb condensate', 'kg/m/s^2', missing_value=missing_value ) - id_vort500 = register_diag_field ( trim(field), 'vort500', axes(1:2), Time, & - '500-mb vorticity', '1/s', missing_value=missing_value ) - id_rain5km = register_diag_field ( trim(field), 'rain5km', axes(1:2), Time, & '5-km AGL liquid water', 'kg/kg', missing_value=missing_value ) !-------------------------- ! w on height or pressure levels !-------------------------- if( .not. Atm(n)%flagstruct%hydrostatic ) then - id_w200 = register_diag_field ( trim(field), 'w200', axes(1:2), Time, & - '200-mb w-wind', 'm/s', missing_value=missing_value ) - id_w500 = register_diag_field ( trim(field), 'w500', axes(1:2), Time, & - '500-mb w-wind', 'm/s', missing_value=missing_value ) - id_w700 = register_diag_field ( trim(field), 'w700', axes(1:2), Time, & - '700-mb w-wind', 'm/s', missing_value=missing_value ) - - id_w850 = register_diag_field ( trim(field), 'w850', axes(1:2), Time, & - '850-mb w-wind', 'm/s', missing_value=missing_value ) id_w5km = register_diag_field ( trim(field), 'w5km', axes(1:2), Time, & '5-km AGL w-wind', 'm/s', missing_value=missing_value ) id_w2500m = register_diag_field ( trim(field), 'w2500m', axes(1:2), Time, & @@ -1233,10 +1365,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) ! helicity id_x850 = register_diag_field ( trim(field), 'x850', axes(1:2), Time, & '850-mb vertical comp. of helicity', 'm/s**2', missing_value=missing_value ) -! id_x03 = register_diag_field ( trim(field), 'x03', axes(1:2), Time, & -! '0-3 km vertical comp. of helicity', 'm**2/s**2', missing_value=missing_value ) -! id_x25 = register_diag_field ( trim(field), 'x25', axes(1:2), Time, & -! '2-5 km vertical comp. of helicity', 'm**2/s**2', missing_value=missing_value ) ! Storm Relative Helicity id_srh1 = register_diag_field ( trim(field), 'srh01', axes(1:2), Time, & @@ -1267,77 +1395,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) '100-m AGL v-wind', 'm/s', missing_value=missing_value ) id_wind100m = register_diag_field ( trim(field), 'wind100m', axes(1:2), Time, & '100-m AGL windspeed', 'm/s', missing_value=missing_value ) -!-------------------------- -! relative humidity (physics definition): -!-------------------------- - id_rh10 = register_diag_field ( trim(field), 'rh10', axes(1:2), Time, & - '10-mb relative humidity', '%', missing_value=missing_value ) - id_rh50 = register_diag_field ( trim(field), 'rh50', axes(1:2), Time, & - '50-mb relative humidity', '%', missing_value=missing_value ) - id_rh100 = register_diag_field ( trim(field), 'rh100', axes(1:2), Time, & - '100-mb relative humidity', '%', missing_value=missing_value ) - id_rh200 = register_diag_field ( trim(field), 'rh200', axes(1:2), Time, & - '200-mb relative humidity', '%', missing_value=missing_value ) - id_rh250 = register_diag_field ( trim(field), 'rh250', axes(1:2), Time, & - '250-mb relative humidity', '%', missing_value=missing_value ) - id_rh300 = register_diag_field ( trim(field), 'rh300', axes(1:2), Time, & - '300-mb relative humidity', '%', missing_value=missing_value ) - id_rh500 = register_diag_field ( trim(field), 'rh500', axes(1:2), Time, & - '500-mb relative humidity', '%', missing_value=missing_value ) - id_rh700 = register_diag_field ( trim(field), 'rh700', axes(1:2), Time, & - '700-mb relative humidity', '%', missing_value=missing_value ) - id_rh850 = register_diag_field ( trim(field), 'rh850', axes(1:2), Time, & - '850-mb relative humidity', '%', missing_value=missing_value ) - id_rh925 = register_diag_field ( trim(field), 'rh925', axes(1:2), Time, & - '925-mb relative humidity', '%', missing_value=missing_value ) - id_rh1000 = register_diag_field ( trim(field), 'rh1000', axes(1:2), Time, & - '1000-mb relative humidity', '%', missing_value=missing_value ) -!-------------------------- -! Dew Point -!-------------------------- - id_dp10 = register_diag_field ( trim(field), 'dp10', axes(1:2), Time, & - '10-mb dew point', 'K', missing_value=missing_value ) - id_dp50 = register_diag_field ( trim(field), 'dp50', axes(1:2), Time, & - '50-mb dew point', 'K', missing_value=missing_value ) - id_dp100 = register_diag_field ( trim(field), 'dp100', axes(1:2), Time, & - '100-mb dew point', 'K', missing_value=missing_value ) - id_dp200 = register_diag_field ( trim(field), 'dp200', axes(1:2), Time, & - '200-mb dew point', 'K', missing_value=missing_value ) - id_dp250 = register_diag_field ( trim(field), 'dp250', axes(1:2), Time, & - '250-mb dew point', 'K', missing_value=missing_value ) - id_dp300 = register_diag_field ( trim(field), 'dp300', axes(1:2), Time, & - '300-mb dew point', 'K', missing_value=missing_value ) - id_dp500 = register_diag_field ( trim(field), 'dp500', axes(1:2), Time, & - '500-mb dew point', 'K', missing_value=missing_value ) - id_dp700 = register_diag_field ( trim(field), 'dp700', axes(1:2), Time, & - '700-mb dew point', 'K', missing_value=missing_value ) - id_dp850 = register_diag_field ( trim(field), 'dp850', axes(1:2), Time, & - '850-mb dew point', 'K', missing_value=missing_value ) - id_dp925 = register_diag_field ( trim(field), 'dp925', axes(1:2), Time, & - '925-mb dew point', 'K', missing_value=missing_value ) - id_dp1000 = register_diag_field ( trim(field), 'dp1000', axes(1:2), Time, & - '1000-mb dew point', 'K', missing_value=missing_value ) -!-------------------------- -! equivalent potential temperature: -!-------------------------- - id_theta_e100 = register_diag_field ( trim(field), 'theta_e100', axes(1:2), Time, & - '100-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e200 = register_diag_field ( trim(field), 'theta_e200', axes(1:2), Time, & - '200-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e250 = register_diag_field ( trim(field), 'theta_e250', axes(1:2), Time, & - '250-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e300 = register_diag_field ( trim(field), 'theta_e300', axes(1:2), Time, & - '300-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e500 = register_diag_field ( trim(field), 'theta_e500', axes(1:2), Time, & - '500-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e700 = register_diag_field ( trim(field), 'theta_e700', axes(1:2), Time, & - '700-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e850 = register_diag_field ( trim(field), 'theta_e850', axes(1:2), Time, & - '850-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e925 = register_diag_field ( trim(field), 'theta_e925', axes(1:2), Time, & - '925-mb equivalent potential temperature', 'K', missing_value=missing_value ) - id_theta_e1000 = register_diag_field ( trim(field), 'theta_e1000', axes(1:2), Time, & - '1000-mb equivalent potential temperature', 'K', missing_value=missing_value ) !-------------------------- ! relative humidity (CMIP definition): @@ -1456,9 +1513,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) module_is_initialized=.true. istep = 0 -#ifndef GFS_PHYS - if(id_theta_e >0 ) call qs_init -#endif call fv_diag_column_init(Atm(n), yr_init, mo_init, dy_init, hr_init, do_diag_debug, do_diag_sonde, sound_freq, m_calendar) @@ -1545,12 +1599,12 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) integer :: ngc, nwater real, allocatable :: a2(:,:),a3(:,:,:),a4(:,:,:), wk(:,:,:), wz(:,:,:), ucoor(:,:,:), vcoor(:,:,:) - real, allocatable :: ustm(:,:), vstm(:,:) + real, allocatable :: ustm(:,:), vstm(:,:), ptmp(:,:,:), qtmp(:,:,:), dz(:,:,:), lsm(:,:) real, allocatable :: slp(:,:), depress(:,:), ws_max(:,:), tc_count(:,:) real, allocatable :: u2(:,:), v2(:,:), x850(:,:), var1(:,:), var2(:,:), var3(:,:) real, allocatable :: dmmr(:,:,:), dvmr(:,:,:) real height(2) - real:: plevs(nplev), pout(nplev) + real:: plevs_ln(nplev), plevs(nplev) integer:: idg(nplev), id1(nplev) real :: tot_mq, tmp, sar, slon, slat real :: a1d(Atm(1)%npz) @@ -1579,8 +1633,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) height(2) = 0. ! for sea-level pressure do i=1,nplev - pout(i) = levs(i) * 1.e2 - plevs(i) = log( pout(i) ) + plevs(i) = levs(i) * 1.e2 + plevs_ln(i) = log( plevs(i) ) enddo ntileMe = size(Atm(:)) @@ -1646,9 +1700,9 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if(prt_minmax) then if ( m_calendar ) then - if(master) write(*,*) yr, mon, dd, hr, mn, seconds + if(master) write(*,'(A,I6,5I3)') ' Simulation Time: ', yr, mon, dd, hr, mn, seconds else - if(master) write(*,*) Days, seconds + if(master) write(*,'(A,2I5)') ' Simulation Time: ', Days, seconds endif endif @@ -1656,8 +1710,12 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if( prt_minmax ) then - call prt_mxm('ZS (m): ', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('PS (Pa): ', Atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain) + + call prt_mass(npz, nq, isc, iec, jsc, jec, ngc, Atm(n)%flagstruct%nwat, & + Atm(n)%ps, Atm(n)%delp, Atm(n)%q, Atm(n)%gridstruct%area_64, Atm(n)%domain) + + !call prt_mxm('ZS (m) ', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('PS (Pa) ', Atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) #ifdef HIWPP if (.not. Atm(n)%gridstruct%bounded_domain ) then @@ -1675,65 +1733,62 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo enddo - call prt_mxm('NH PS', a2, isc, iec, jsc, jec, 0, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('SH PS', var2, isc, iec, jsc, jec, 0, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('NH PS', a2, isc, iec, jsc, jec, 0, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('SH PS', var2, isc, iec, jsc, jec, 0, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) deallocate(var2) endif #endif - call prt_mass(npz, nq, isc, iec, jsc, jec, ngc, Atm(n)%flagstruct%nwat, & - Atm(n)%ps, Atm(n)%delp, Atm(n)%q, Atm(n)%gridstruct%area_64, Atm(n)%domain) - #ifndef SW_DYNAMICS if (Atm(n)%flagstruct%consv_te > 1.e-5) then idiag%steps = idiag%steps + 1 idiag%efx_sum = idiag%efx_sum + E_Flux if ( idiag%steps <= max_step ) idiag%efx(idiag%steps) = E_Flux if (master) then - write(*,*) 'Energy_Deficit (W/m**2)', trim(gn), ' = ', E_Flux + write(*,'(2x, A, 2A, G20.8)') ' Energy_Deficit (W/m**2)', trim(gn), ' = ', E_Flux endif endif #endif - call prt_mxm('UA_Top (m/s): ', Atm(n)%ua(isc:iec,jsc:jec,1), & - isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('UA_Bottom (m/s): ', Atm(n)%ua(isc:iec,jsc:jec,npz), & - isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('UA (m/s): ', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('VA_Top (m/s): ', Atm(n)%va(isc:iec,jsc:jec,1), & - isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('VA_Bottom (m/s): ', Atm(n)%va(isc:iec,jsc:jec,npz), & - isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('VA (m/s): ', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('UA_Top (m/s)', Atm(n)%ua(isc:iec,jsc:jec,1), & + isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('UA_Bottom (m/s)', Atm(n)%ua(isc:iec,jsc:jec,npz), & + isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('UA (m/s)', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) + call prt_mxm('VA_Top (m/s)', Atm(n)%va(isc:iec,jsc:jec,1), & + isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('VA_Bottom (m/s)', Atm(n)%va(isc:iec,jsc:jec,npz), & + isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('VA (m/s)', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) if ( .not. Atm(n)%flagstruct%hydrostatic ) then - call prt_mxm('W_Top (m/s): ', Atm(n)%w(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('W_Bottom (m/s): ', Atm(n)%w(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('W (m/s): ', Atm(n)%w , isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('W_Top (m/s)', Atm(n)%w(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('W_Bottom (m/s)', Atm(n)%w(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('W (m/s)', Atm(n)%w , isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) do j=jsc,jec do i=isc,iec a2(i,j) = -Atm(n)%w(i,j,npz)/Atm(n)%delz(i,j,npz) enddo enddo - call prt_mxm('W/dz_Bottom (1/s): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('W/dz_Bottom (1/s)', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_3) if ( Atm(n)%flagstruct%hybrid_z ) call prt_mxm('Hybrid_ZTOP (km)', Atm(n)%ze0(isc:iec,jsc:jec,1), & - isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('DZ_Top (m): ', Atm(n)%delz(isc:iec,jsc:jec,1), & - isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('DZ_Bottom (m): ', Atm(n)%delz(isc:iec,jsc:jec,npz), & - isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('DZ (m): ', Atm(n)%delz(isc:iec,jsc:jec,1:npz), & - isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_3) + call prt_mxm('DZ_Top (m)', Atm(n)%delz(isc:iec,jsc:jec,1), & + isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_3) + call prt_mxm('DZ_Bottom (m)', Atm(n)%delz(isc:iec,jsc:jec,npz), & + isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_3) + call prt_mxm('DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,1:npz), & + isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) endif #ifndef SW_DYNAMICS - call prt_mxm('TA_Top (K): ', Atm(n)%pt(isc:iec,jsc:jec, 1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('TA_Bottom (K): ', Atm(n)%pt(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('TA (K): ', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('OM (pa/s): ', Atm(n)%omga, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('TA_Top (K)', Atm(n)%pt(isc:iec,jsc:jec, 1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('TA_Bottom (K)', Atm(n)%pt(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('TA (K)', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) + call prt_mxm('OM (pa/s)', Atm(n)%omga, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) #endif elseif ( Atm(n)%flagstruct%range_warn ) then @@ -1777,15 +1832,14 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) ! if (id_c_grid_vcomp > 0) used = send_data(id_c_grid_vcomp, Atm(n)%vc(isc:iec,jsc:jec+1,1:npz), Time) #ifdef DYNAMICS_ZS - !This is here for idealized test cases that modify the topography in time do j=jsc,jec do i=isc,iec zsurf(i,j) = ginv * Atm(n)%phis(i,j) enddo enddo - if(id_zsurf > 0) used=send_data(id_zsurf, zsurf, Time) - call prt_mxm('ZS', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain) + if(id_zsurf_t > 0) used=send_data(id_zsurf_t, zsurf, Time) + call prt_mxm('ZS', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) #endif if(id_ps > 0) used=send_data(id_ps, Atm(n)%ps(isc:iec,jsc:jec), Time) @@ -1802,6 +1856,82 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if(id_pres > 0) used=send_data(id_pres, Atm(n)%inline_mp%pres(isc:iec,jsc:jec), Time) if(id_preg > 0) used=send_data(id_preg, Atm(n)%inline_mp%preg(isc:iec,jsc:jec), Time) endif + if(id_mppcw > 0) used=send_data(id_mppcw, Atm(n)%inline_mp%mppcw(isc:iec,jsc:jec), Time) + if(id_mppew > 0) used=send_data(id_mppew, Atm(n)%inline_mp%mppew(isc:iec,jsc:jec), Time) + if(id_mppe1 > 0) used=send_data(id_mppe1, Atm(n)%inline_mp%mppe1(isc:iec,jsc:jec), Time) + if(id_mpper > 0) used=send_data(id_mpper, Atm(n)%inline_mp%mpper(isc:iec,jsc:jec), Time) + if(id_mppdi > 0) used=send_data(id_mppdi, Atm(n)%inline_mp%mppdi(isc:iec,jsc:jec), Time) + if(id_mppd1 > 0) used=send_data(id_mppd1, Atm(n)%inline_mp%mppd1(isc:iec,jsc:jec), Time) + if(id_mppds > 0) used=send_data(id_mppds, Atm(n)%inline_mp%mppds(isc:iec,jsc:jec), Time) + if(id_mppdg > 0) used=send_data(id_mppdg, Atm(n)%inline_mp%mppdg(isc:iec,jsc:jec), Time) + if(id_mppsi > 0) used=send_data(id_mppsi, Atm(n)%inline_mp%mppsi(isc:iec,jsc:jec), Time) + if(id_mpps1 > 0) used=send_data(id_mpps1, Atm(n)%inline_mp%mpps1(isc:iec,jsc:jec), Time) + if(id_mppss > 0) used=send_data(id_mppss, Atm(n)%inline_mp%mppss(isc:iec,jsc:jec), Time) + if(id_mppsg > 0) used=send_data(id_mppsg, Atm(n)%inline_mp%mppsg(isc:iec,jsc:jec), Time) + if(id_mppfw > 0) used=send_data(id_mppfw, Atm(n)%inline_mp%mppfw(isc:iec,jsc:jec), Time) + if(id_mppfr > 0) used=send_data(id_mppfr, Atm(n)%inline_mp%mppfr(isc:iec,jsc:jec), Time) + if(id_mppmi > 0) used=send_data(id_mppmi, Atm(n)%inline_mp%mppmi(isc:iec,jsc:jec), Time) + if(id_mppms > 0) used=send_data(id_mppms, Atm(n)%inline_mp%mppms(isc:iec,jsc:jec), Time) + if(id_mppmg > 0) used=send_data(id_mppmg, Atm(n)%inline_mp%mppmg(isc:iec,jsc:jec), Time) + if(id_mppm1 > 0) used=send_data(id_mppm1, Atm(n)%inline_mp%mppm1(isc:iec,jsc:jec), Time) + if(id_mppm2 > 0) used=send_data(id_mppm2, Atm(n)%inline_mp%mppm2(isc:iec,jsc:jec), Time) + if(id_mppm3 > 0) used=send_data(id_mppm3, Atm(n)%inline_mp%mppm3(isc:iec,jsc:jec), Time) + if(id_mppar > 0) used=send_data(id_mppar, Atm(n)%inline_mp%mppar(isc:iec,jsc:jec), Time) + if(id_mppas > 0) used=send_data(id_mppas, Atm(n)%inline_mp%mppas(isc:iec,jsc:jec), Time) + if(id_mppag > 0) used=send_data(id_mppag, Atm(n)%inline_mp%mppag(isc:iec,jsc:jec), Time) + if(id_mpprs > 0) used=send_data(id_mpprs, Atm(n)%inline_mp%mpprs(isc:iec,jsc:jec), Time) + if(id_mpprg > 0) used=send_data(id_mpprg, Atm(n)%inline_mp%mpprg(isc:iec,jsc:jec), Time) + if(id_mppxr > 0) used=send_data(id_mppxr, Atm(n)%inline_mp%mppxr(isc:iec,jsc:jec), Time) + if(id_mppxs > 0) used=send_data(id_mppxs, Atm(n)%inline_mp%mppxs(isc:iec,jsc:jec), Time) + if(id_mppxg > 0) used=send_data(id_mppxg, Atm(n)%inline_mp%mppxg(isc:iec,jsc:jec), Time) + + if (id_qcw > 0 .and. id_qcr > 0 .and. id_qci > 0 .and. id_qcs > 0 .and. id_qcg > 0 .and. & + id_rew > 0 .and. id_rer > 0 .and. id_rei > 0 .and. id_res > 0 .and. id_reg > 0 .and. id_cld > 0) then + allocate(lsm(isc:iec,jsc:jec)) + allocate(dz(isc:iec,jsc:jec,1:npz)) + allocate(ptmp(isc:iec,jsc:jec,1:npz)) + allocate(qtmp(isc:iec,jsc:jec,1:npz)) + do j=jsc,jec + do i=isc,iec + lsm(i,j) = min (1.,abs(Atm(n)%phis(i,j))/(10.*grav)) + enddo + if (.not. Atm(n)%flagstruct%hydrostatic) then + dz(isc:iec,j,1:npz) = Atm(n)%delz(isc:iec,j,1:npz) + else + dz(isc:iec,j,1:npz) = (Atm(n)%peln(isc:iec,1:npz,j)-Atm(n)%peln (isc:iec,2:npz+1,j))*rdgas/grav*Atm(n)%pt(isc:iec,j,1:npz) + endif + ptmp(isc:iec,j,1:npz) = -Atm(n)%delp(isc:iec,j,1:npz)/(grav*dz(isc:iec,j,1:npz))*rdgas*Atm(n)%pt(isc:iec,j,1:npz) + if (aerosol .gt. 0) then + qtmp(isc:iec,j,1:npz) = Atm(n)%q(isc:iec,j,1:npz,aerosol) + else + qtmp(isc:iec,j,1:npz) = 0.0 + endif + call cld_eff_rad (isc, iec, 1, npz, lsm(isc:iec,j), ptmp(isc:iec,j,1:npz), Atm(n)%delp(isc:iec,j,1:npz), Atm(n)%pt(isc:iec,j,1:npz), & + Atm(n)%q(isc:iec,j,1:npz,sphum), Atm(n)%q(isc:iec,j,1:npz,liq_wat), Atm(n)%q(isc:iec,j,1:npz,ice_wat), & + Atm(n)%q(isc:iec,j,1:npz,rainwat), Atm(n)%q(isc:iec,j,1:npz,snowwat), Atm(n)%q(isc:iec,j,1:npz,graupel), & + qtmp(isc:iec,j,1:npz), Atm(n)%inline_mp%qcw(isc:iec,j,1:npz), Atm(n)%inline_mp%qci(isc:iec,j,1:npz), & + Atm(n)%inline_mp%qcr(isc:iec,j,1:npz), Atm(n)%inline_mp%qcs(isc:iec,j,1:npz), Atm(n)%inline_mp%qcg(isc:iec,j,1:npz), & + Atm(n)%inline_mp%rew(isc:iec,j,1:npz), Atm(n)%inline_mp%rei(isc:iec,j,1:npz), Atm(n)%inline_mp%rer(isc:iec,j,1:npz), & + Atm(n)%inline_mp%res(isc:iec,j,1:npz), Atm(n)%inline_mp%reg(isc:iec,j,1:npz), Atm(n)%inline_mp%cld(isc:iec,j,1:npz), & + Atm(n)%q(isc:iec,j,1:npz,cld_amt)) + enddo + deallocate(lsm) + deallocate(dz) + deallocate(ptmp) + deallocate(qtmp) + endif + + if (id_qcw > 0) used=send_data(id_qcw, Atm(n)%inline_mp%qcw(isc:iec,jsc:jec,1:npz), Time) + if (id_qci > 0) used=send_data(id_qci, Atm(n)%inline_mp%qci(isc:iec,jsc:jec,1:npz), Time) + if (id_qcr > 0) used=send_data(id_qcr, Atm(n)%inline_mp%qcr(isc:iec,jsc:jec,1:npz), Time) + if (id_qcs > 0) used=send_data(id_qcs, Atm(n)%inline_mp%qcs(isc:iec,jsc:jec,1:npz), Time) + if (id_qcg > 0) used=send_data(id_qcg, Atm(n)%inline_mp%qcg(isc:iec,jsc:jec,1:npz), Time) + if (id_rew > 0) used=send_data(id_rew, Atm(n)%inline_mp%rew(isc:iec,jsc:jec,1:npz), Time) + if (id_rei > 0) used=send_data(id_rei, Atm(n)%inline_mp%rei(isc:iec,jsc:jec,1:npz), Time) + if (id_rer > 0) used=send_data(id_rer, Atm(n)%inline_mp%rer(isc:iec,jsc:jec,1:npz), Time) + if (id_res > 0) used=send_data(id_res, Atm(n)%inline_mp%res(isc:iec,jsc:jec,1:npz), Time) + if (id_reg > 0) used=send_data(id_reg, Atm(n)%inline_mp%reg(isc:iec,jsc:jec,1:npz), Time) + if (id_cld > 0) used=send_data(id_cld, Atm(n)%inline_mp%cld(isc:iec,jsc:jec,1:npz), Time) if (id_qv_dt_gfdlmp > 0) used=send_data(id_qv_dt_gfdlmp, Atm(n)%inline_mp%qv_dt(isc:iec,jsc:jec,1:npz), Time) if (id_ql_dt_gfdlmp > 0) used=send_data(id_ql_dt_gfdlmp, Atm(n)%inline_mp%ql_dt(isc:iec,jsc:jec,1:npz), Time) @@ -1832,6 +1962,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if (id_delp_dt_nudge > 0) used=send_data(id_delp_dt_nudge, Atm(n)%nudge_diag%nudge_delp_dt(isc:iec,jsc:jec,1:npz), Time) if (id_u_dt_nudge > 0) used=send_data(id_u_dt_nudge, Atm(n)%nudge_diag%nudge_u_dt(isc:iec,jsc:jec,1:npz), Time) if (id_v_dt_nudge > 0) used=send_data(id_v_dt_nudge, Atm(n)%nudge_diag%nudge_v_dt(isc:iec,jsc:jec,1:npz), Time) + if (id_qv_dt_nudge > 0) used=send_data(id_qv_dt_nudge, Atm(n)%nudge_diag%nudge_qv_dt(isc:iec,jsc:jec,1:npz), Time) if (idiag%id_t_dt_sg > 0) used=send_data(idiag%id_t_dt_sg, Atm(n)%sg_diag%t_dt(isc:iec,jsc:jec,1:npz), Time) if (idiag%id_u_dt_sg > 0) used=send_data(idiag%id_u_dt_sg, Atm(n)%sg_diag%u_dt(isc:iec,jsc:jec,1:npz), Time) @@ -1858,7 +1989,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo endif - if ( id_vort200>0 .or. id_vort500>0 .or. id_vort850>0 .or. id_vorts>0 & + if ( id_vorts>0 .or. ANY(id_vort_levs>0) .or. id_vort_plev>0 & .or. id_vort>0 .or. id_pv>0 .or. id_pv350k>0 .or. id_pv550k>0 & .or. id_rh>0 .or. id_x850>0 .or. id_uh03>0 .or. id_uh25>0 & .or. id_srh1 > 0 .or. id_srh3 > 0 .or. id_srh25 > 0 & @@ -1879,21 +2010,12 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo endif - if( id_vort200>0 ) then - call interpolate_vertical(isc, iec, jsc, jec, npz, & - 200.e2, Atm(n)%peln, wk, a2) - used=send_data(id_vort200, a2, Time) - endif - if( id_vort500>0 ) then - call interpolate_vertical(isc, iec, jsc, jec, npz, & - 500.e2, Atm(n)%peln, wk, a2) - used=send_data(id_vort500, a2, Time) - endif + call make_plevs( wk, plevs_ln, Atm(n)%peln(isc:iec,1:npz+1,jsc:jec), & + npz, -1, id_vort_plev, id_vort_levs, nplev, Atm(n)%bd, Time) - if(id_vort850>0 .or. id_c15>0 .or. id_x850>0) then + if(id_c15>0 .or. id_x850>0) then call interpolate_vertical(isc, iec, jsc, jec, npz, & 850.e2, Atm(n)%peln, wk, a2) - used=send_data(id_vort850, a2, Time) if ( id_x850>0 ) x850(:,:) = a2(:,:) if(id_c15>0) then @@ -1926,7 +2048,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo enddo - call prt_mxm('UH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('UH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) endif endif if ( id_uh25 > 0 ) then @@ -1968,7 +2090,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo enddo - call prt_mxm('SRH (0-1 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('SRH (0-1 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) endif endif @@ -1988,7 +2110,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo enddo - call prt_mxm('SRH (0-3 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('SRH (0-3 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) endif endif @@ -2008,7 +2130,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo enddo - call prt_mxm('SRH (2-5 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('SRH (2-5 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) endif endif @@ -2046,13 +2168,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) used = send_data( id_pv550K, a2, Time) endif deallocate ( a3 ) - if (prt_minmax) call prt_mxm('PV', wk, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + if (prt_minmax) call prt_mxm('PV', wk, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) endif endif ! Relative Humidity - if ( id_rh > 0 ) then + if ( id_rh > 0 .or. ANY(id_rh_levs>0) .or. id_rh_plev>0 .or. ANY(id_dp_levs>0) .or. id_dp_plev>0) then ! Compute FV mean pressure do k=1,npz do j=jsc,jec @@ -2070,9 +2192,9 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo used = send_data ( id_rh, wk, Time ) if(prt_minmax) then - call prt_mxm('RH_Top (%): ', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('RH_Bottom (%): ', wk(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_mxm('RH (%): ', wk, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('RH_Top (%)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('RH_Bottom (%)', wk(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) + call prt_mxm('RH (%)', wk, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) if (.not. Atm(n)%gridstruct%bounded_domain) then tmp = 0. @@ -2086,138 +2208,36 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo call mp_reduce_sum(sar) call mp_reduce_sum(tmp) - if ( sar > 0. ) then - if (master) write(*,*) 'RH200 = ', tmp/sar + if ( sar > 0. .and. user_prt_level >= PRT_LEVEL_2) then + if (master) write(*,'(2x, A, G20.8)') 'RH200 = ', tmp/sar endif endif endif - endif - - ! rel hum from physics at selected press levels (for IPCC) - if (id_rh50>0 .or. id_rh100>0 .or. id_rh200>0 .or. id_rh250>0 .or. & - id_rh300>0 .or. id_rh500>0 .or. id_rh700>0 .or. id_rh850>0 .or. & - id_rh925>0 .or. id_rh1000>0 .or. & - id_dp50>0 .or. id_dp100>0 .or. id_dp200>0 .or. id_dp250>0 .or. & - id_dp300>0 .or. id_dp500>0 .or. id_dp700>0 .or. id_dp850>0 .or. & - id_dp925>0 .or. id_dp1000>0) then - ! compute mean pressure - do k=1,npz - do j=jsc,jec - do i=isc,iec - a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j)) - enddo - enddo - call mqs3d (iec-isc+1, jec-jsc+1, 1, Atm(n)%pt(isc:iec,jsc:jec,k), a2, & - Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k)) - do j=jsc,jec - do i=isc,iec - wk(i,j,k) = 100.*Atm(n)%q(i,j,k,sphum)/wk(i,j,k) - enddo - enddo - enddo - if (id_rh50>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh50, a2, Time) - endif - if (id_rh100>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh100, a2, Time) - endif - if (id_rh200>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh200, a2, Time) - endif - if (id_rh250>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh250, a2, Time) - endif - if (id_rh300>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 300.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh300, a2, Time) - endif - if (id_rh500>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh500, a2, Time) - endif - if (id_rh700>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh700, a2, Time) - endif - if (id_rh850>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh850, a2, Time) - endif - if (id_rh925>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 925.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh925, a2, Time) - endif - if (id_rh1000>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2) - used=send_data(id_rh1000, a2, Time) - endif - if (id_dp50>0 .or. id_dp100>0 .or. id_dp200>0 .or. id_dp250>0 .or. & - id_dp300>0 .or. id_dp500>0 .or. id_dp700>0 .or. id_dp850>0 .or. & - id_dp925>0 .or. id_dp1000>0 ) then + call make_plevs( wk(isc:iec,jsc:jec,:), plevs_ln, Atm(n)%peln(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_rh_plev, id_rh_levs, nplev, Atm(n)%bd, Time) - if (allocated(a3)) deallocate(a3) - allocate(a3(isc:iec,jsc:jec,1:npz)) - !compute dew point (K) - !using formula at https://cals.arizona.edu/azmet/dewpoint.html - do k=1,npz - do j=jsc,jec - do i=isc,iec - tmp = ( log(max(wk(i,j,k)*1.e-2,1.e-2)) + 17.27 * ( Atm(n)%pt(i,j,k) - 273.14 )/ ( -35.84 + Atm(n)%pt(i,j,k)) ) / 17.27 - a3(i,j,k) = 273.14 + 237.3*tmp/ ( 1. - tmp ) - enddo - enddo - enddo + if (ANY(id_dp_levs>0) .or. id_dp_plev>0) then + if (allocated(a3)) deallocate(a3) + allocate(a3(isc:iec,jsc:jec,1:npz)) + !compute dew point (K) !DEW POINT CALCULATION + !using formula at https://cals.arizona.edu/azmet/dewpoint.html + do k=1,npz + do j=jsc,jec + do i=isc,iec + tmp = ( log(max(wk(i,j,k)*1.e-2,1.e-2)) + 17.27 * ( Atm(n)%pt(i,j,k) - 273.14 )/ ( -35.84 + Atm(n)%pt(i,j,k)) ) / 17.27 + a3(i,j,k) = 273.14 + 237.3*tmp/ ( 1. - tmp ) + enddo + enddo + enddo + call make_plevs( a3(isc:iec,jsc:jec,:), plevs_ln, Atm(n)%peln(isc:iec,1:npz+1,jsc:jec), & + npz, 1, id_dp_plev, id_dp_levs, nplev, Atm(n)%bd, Time) + deallocate(a3) - if (id_dp50>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp50, a2, Time) - endif - if (id_dp100>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp100, a2, Time) - endif - if (id_dp200>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp200, a2, Time) - endif - if (id_dp250>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp250, a2, Time) - endif - if (id_dp300>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 300.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp300, a2, Time) - endif - if (id_dp500>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp500, a2, Time) - endif - if (id_dp700>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp700, a2, Time) - endif - if (id_dp850>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp850, a2, Time) - endif - if (id_dp925>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 925.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp925, a2, Time) - endif - if (id_dp1000>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, Atm(n)%peln, a3, a2) - used=send_data(id_dp1000, a2, Time) - endif - deallocate(a3) + endif + endif - endif - endif ! rel hum (CMIP definition) at selected press levels (for IPCC) if (id_rh10_cmip>0 .or. id_rh50_cmip>0 .or. id_rh100_cmip>0 .or. & @@ -2301,7 +2321,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) call get_height_field(isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%delz, & wz, Atm(n)%pt, Atm(n)%q, Atm(n)%peln, zvir) if( prt_minmax ) & - call prt_mxm('ZTOP (m): ',wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('ZTOP (m)',wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_1) if (id_hght3d > 0) then used = send_data(id_hght3d, 0.5*(wz(isc:iec,jsc:jec,1:npz)+wz(isc:iec,jsc:jec,2:npz+1)), Time) @@ -2319,8 +2339,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif used = send_data (id_slp, slp, Time) if( prt_minmax ) then - call prt_mxm('SLP (Pa): ', slp, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_maxmin('SLP', slp, isc, iec, jsc, jec, 0, 1, 1.) + call prt_mxm('SLP (Pa)', slp, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_0) + call prt_maxmin('SLP', slp, isc, iec, jsc, jec, 0, 1, 1., PRT_LEVEL_2) if ( .not. Atm(n)%gridstruct%bounded_domain ) then ! US Potential Landfall TCs (PLT): do j=jsc,jec @@ -2333,31 +2353,31 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo enddo - call prt_mxm('SLP_ATL (Pa): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('SLP_ATL (Pa)', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_2) endif endif endif ! Compute H3000 and/or H500 - if( id_tm>0 .or. id_any_hght>0 .or. id_ppt>0) then + if( id_tm>0 .or. id_any_hght>0 .or. id_ppt>0 .or. ANY(id_theta_levs>0) .or. id_theta_plev>0) then allocate( a3(isc:iec,jsc:jec,nplev) ) - idg(:) = id_h(:) + idg(:) = id_h_levs(:) !Determine which levels have been registered and need writing out if ( id_tm>0 ) then idg(k300) = 1 ! 300-mb idg(k500) = 1 ! 500-mb else - idg(k300) = id_h(k300) - idg(k500) = id_h(k500) + idg(k300) = id_h_levs(k300) + idg(k500) = id_h_levs(k500) endif - call get_height_given_pressure(isc, iec, jsc, jec, npz, wz, nplev, idg, plevs, Atm(n)%peln, a3) + call get_height_given_pressure(isc, iec, jsc, jec, npz, wz, nplev, idg, plevs_ln, Atm(n)%peln, a3) ! reset - idg(k300) = id_h(k300) - idg(k500) = id_h(k500) + idg(k300) = id_h_levs(k300) + idg(k500) = id_h_levs(k500) do i=1,nplev if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) @@ -2365,21 +2385,21 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if (id_h_plev>0) then id1(:) = 1 - call get_height_given_pressure(isc, iec, jsc, jec, npz, wz, nplev, id1, plevs, Atm(n)%peln, a3) + call get_height_given_pressure(isc, iec, jsc, jec, npz, wz, nplev, id1, plevs_ln, Atm(n)%peln, a3) used=send_data(id_h_plev, a3(isc:iec,jsc:jec,:), Time) endif if( prt_minmax ) then - if(id_h(k100)>0 .or. (id_h_plev>0 .and. k100>0)) & - call prt_mxm('Z100 (m): ',a3(isc:iec,jsc:jec,k100),isc,iec,jsc,jec,0,1,1.E-3,Atm(n)%gridstruct%area_64,Atm(n)%domain) + if(id_h_levs(k100)>0 .or. (id_h_plev>0 .and. k100>0)) & + call prt_mxm('Z100 (m)',a3(isc:iec,jsc:jec,k100),isc,iec,jsc,jec,0,1,1.E-3,Atm(n)%gridstruct%area_64,Atm(n)%domain, PRT_LEVEL_2) - if(id_h(k500)>0 .or. (id_h_plev>0 .and. k500>0)) then + if(id_h_levs(k500)>0 .or. (id_h_plev>0 .and. k500>0)) then if (Atm(n)%gridstruct%bounded_domain) then - call prt_mxm('Z500 (m): ',a3(isc:iec,jsc:jec,k500),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain) + call prt_mxm('Z500 (m)',a3(isc:iec,jsc:jec,k500),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain, PRT_LEVEL_1) else call prt_gb_nh_sh('Z500', isc,iec, jsc,jec, a3(isc,jsc,k500), Atm(n)%gridstruct%area_64(isc:iec,jsc:jec), & - Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2)) + Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2), PRT_LEVEL_1) endif endif @@ -2387,13 +2407,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) ! mean virtual temp 300mb to 500mb if( id_tm>0 ) then - if ( (id_h(k500) <= 0 .or. id_h(k300) <= 0) .and. (id_h_plev>0 .and. (k300<=0 .or. k500<=0))) then + if ( (id_h_levs(k500) <= 0 .or. id_h_levs(k300) <= 0) .and. (id_h_plev>0 .and. (k300<=0 .or. k500<=0))) then call mpp_error(NOTE, "Could not find levs for 300--500 mb mean temperature, setting to missing_value") a2 = missing_value else do j=jsc,jec do i=isc,iec - a2(i,j) = grav*(a3(i,j,k500)-a3(i,j,k300))/(rdgas*(plevs(k300)-plevs(k500))) + a2(i,j) = grav*(a3(i,j,k500)-a3(i,j,k300))/(rdgas*(plevs_ln(k300)-plevs_ln(k500))) enddo enddo endif @@ -2529,7 +2549,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif ! Temperature: - idg(:) = id_t(:) + idg(:) = id_t_levs(:) do_cs_intp = .false. do i=1,nplev @@ -2539,20 +2559,20 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif enddo + !Height calculation no longer needed?? if (.not. allocated(wz)) allocate ( wz(isc:iec,jsc:jec,npz+1) ) - call get_height_field(isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%delz, & wz, Atm(n)%pt, Atm(n)%q, Atm(n)%peln, zvir) - if ( do_cs_intp ) then ! log(pe) as the coordinaite for temp re-construction + if ( do_cs_intp ) then ! log(pe) as the coordinate for temp re-construction if(.not. allocated (a3) ) allocate( a3(isc:iec,jsc:jec,nplev) ) call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%pt(isc:iec,jsc:jec,:), nplev, & - plevs(1:nplev), wz, Atm(n)%peln, idg, a3, 1) + plevs_ln(1:nplev), Atm(n)%peln, idg, a3, 1) do i=1,nplev if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) enddo - if ( id_t(k100)>0 .and. prt_minmax ) then - call prt_mxm('T100 (K): ', a3(isc:iec,jsc:jec,k100), isc, iec, jsc, jec, 0, 1, 1., & + if ( id_t_levs(k100)>0 .and. prt_minmax ) then + call prt_mxm('T100 (K)', a3(isc:iec,jsc:jec,k100), isc, iec, jsc, jec, 0, 1, 1., & Atm(n)%gridstruct%area_64, Atm(n)%domain) if (.not. Atm(n)%gridstruct%bounded_domain) then tmp = 0. @@ -2569,15 +2589,15 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo call mp_reduce_sum(sar) call mp_reduce_sum(tmp) - if ( sar > 0. ) then - if (master) write(*,*) 'Tropical [10s,10n] mean T100 = ', tmp/sar + if ( sar > 0. .and. user_prt_level >= PRT_LEVEL_2) then + if (master) write(*,'(2x, A, G20.8)') 'Tropical [10s,10n] mean T100 = ', tmp/sar else if (master) write(*,*) 'Warning: problem computing tropical mean T100' endif endif endif - if ( id_t(k200) > 0 .and. prt_minmax ) then - call prt_mxm('T200 (K): ', a3(isc:iec,jsc:jec,k200), isc, iec, jsc, jec, 0, 1, 1., & + if ( id_t_levs(k200) > 0 .and. prt_minmax ) then + call prt_mxm('T200 (K)', a3(isc:iec,jsc:jec,k200), isc, iec, jsc, jec, 0, 1, 1., & Atm(n)%gridstruct%area_64, Atm(n)%domain) if (.not. Atm(n)%gridstruct%bounded_domain) then tmp = 0. @@ -2593,8 +2613,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo call mp_reduce_sum(sar) call mp_reduce_sum(tmp) - if ( sar > 0. ) then - if (master) write(*,*) 'Tropical [-20.,20.] mean T200 = ', tmp/sar + if ( sar > 0. .and. user_prt_level >= PRT_LEVEL_2) then + if (master) write(*,'(2x, A, G20.8)') 'Tropical [-20.,20.] mean T200 = ', tmp/sar endif endif endif @@ -2605,7 +2625,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if(.not. allocated (a3) ) allocate( a3(isc:iec,jsc:jec,nplev) ) id1(:) = 1 call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%pt(isc:iec,jsc:jec,:), nplev, & - plevs(1:nplev), wz, Atm(n)%peln, id1, a3, 1) + plevs_ln(1:nplev), Atm(n)%peln, id1, a3, 1) used=send_data(id_t_plev, a3(isc:iec,jsc:jec,:), Time) deallocate( a3 ) endif @@ -2619,11 +2639,11 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo enddo used = send_data(id_mq, a2, Time) - if( prt_minmax ) then + if( prt_minmax .and. user_prt_level >= PRT_LEVEL_2) then tot_mq = g_sum( Atm(n)%domain, a2, isc, iec, jsc, jec, ngc, Atm(n)%gridstruct%area_64, 0) idiag%mtq_sum = idiag%mtq_sum + tot_mq if ( idiag%steps <= max_step ) idiag%mtq(idiag%steps) = tot_mq - if(master) write(*,*) 'Total (global) mountain torque (Hadleys)=', tot_mq + if(master) write(*,'(2x, A, G20.8)') 'Total (global) mountain torque (Hadleys)=', tot_mq endif endif @@ -2721,15 +2741,15 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) einf = max(einf, abs(a2(i,j) - qcly0)) enddo enddo - if (prt_minmax .and. .not. Atm(n)%gridstruct%bounded_domain) then + if (prt_minmax .and. .not. Atm(n)%gridstruct%bounded_domain .and. user_prt_level >= PRT_LEVEL_2) then call mp_reduce_sum(qm) call mp_reduce_max(einf) call mp_reduce_sum(e2) if (master) then - write(*,*) ' TERMINATOR TEST: ' - write(*,*) ' chlorine mass: ', qm/(4.*pi*RADIUS*RADIUS) - write(*,*) ' L2 err: ', sqrt(e2)/sqrt(4.*pi*RADIUS*RADIUS)/qcly0 - write(*,*) ' max err: ', einf/qcly0 + write(*,'(2x, A)') ' TERMINATOR TEST: ' + write(*,'(2x, A, G20.8)') ' chlorine mass: ', qm/(4.*pi*RADIUS*RADIUS) + write(*,'(2x, A, G20.8)') ' L2 err: ', sqrt(e2)/sqrt(4.*pi*RADIUS*RADIUS)/qcly0 + write(*,'(2x, A, G20.8)') ' max err: ', einf/qcly0 endif endif endif @@ -2902,16 +2922,16 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo if ( id_ctt>0 ) then used = send_data(id_ctt, a2, Time) - if(prt_minmax) call prt_mxm('Cloud_top_T (K): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + if(prt_minmax) call prt_mxm('Cloud_top_T (K)', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) endif if ( id_ctp>0 ) then used = send_data(id_ctp, var1, Time) - if(prt_minmax) call prt_mxm('Cloud_top_P (mb): ', var1, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + if(prt_minmax) call prt_mxm('Cloud_top_P (mb)', var1, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) endif deallocate ( var1 ) if ( id_ctz>0 ) then used = send_data(id_ctz, var2, Time) - if(prt_minmax) call prt_mxm('Cloud_top_Z (m): ', var2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + if(prt_minmax) call prt_mxm('Cloud_top_Z (m)', var2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) endif deallocate ( var2 ) endif @@ -3013,14 +3033,14 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo used=send_data(id_us, u2, Time) used=send_data(id_vs, v2, Time) - if(prt_minmax) call prt_mxm('Surf_Wind_Speed (m/s): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + if(prt_minmax) call prt_mxm('Surf_Wind_Speed (m/s)', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) endif if(id_tb > 0) then a2(:,:) = Atm(n)%pt(isc:iec,jsc:jec,npz) used=send_data(id_tb, a2, Time) if( prt_minmax ) & - call prt_mxm('T_Bottom (K): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call prt_mxm('T_Bottom (K)', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) endif if(id_ua > 0) used=send_data(id_ua, Atm(n)%ua(isc:iec,jsc:jec,:), Time) @@ -3044,7 +3064,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) used=send_data(id_ke, a2, Time) if(prt_minmax) then tot_mq = g_sum( Atm(n)%domain, a2, isc, iec, jsc, jec, ngc, Atm(n)%gridstruct%area_64, 1) - if (master) write(*,*) 'SQRT(2.*KE; m/s)=', sqrt(2.*tot_mq) + if (master .and. user_prt_level >= PRT_LEVEL_3) write(*,*) 'SQRT(2.*KE; m/s)=', sqrt(2.*tot_mq) endif endif @@ -3065,10 +3085,33 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) #else if(id_delp > 0) used=send_data(id_delp, Atm(n)%delp(isc:iec,jsc:jec,:), Time) #endif - if( ( (.not. Atm(n)%flagstruct%hydrostatic) .and. (id_pfnh > 0 .or. id_ppnh > 0)) .or. id_cape > 0 .or. id_cin > 0 .or. & - id_brn > 0 .or. id_shear06 > 0) then - do k=1,npz + !!! Compute pressure and variables requiring pressure (CAPE, CIN, BRN; latter needs shear06 too) + + if ( id_pfnh > 0 .or. id_ppnh > 0 .or. & + id_cape > 0 .or. id_cin > 0 .or. & + id_brn > 0 .or. id_shear06 > 0 ) then + + allocate(a3(isc:iec,jsc:jec,npz)) + + if (Atm(n)%flagstruct%hydrostatic .or. id_pfhy > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec +#ifdef GFS_PHYS + wk(i,j,k) = 0.5 *(Atm(n)%pe(i,k,j)+Atm(n)%pe(i,k+1,j)) +#else + wk(i,j,k) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j)) +#endif + enddo + enddo + enddo + used=send_data(id_pfhy, wk, Time) + endif + + + if ( .not. Atm(n)%flagstruct%hydrostatic ) then + do k=1,npz do j=jsc,jec do i=isc,iec #ifdef GFS_PHYS @@ -3081,98 +3124,86 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) #endif enddo enddo - enddo -! if (prt_minmax) then -! call prt_mxm(' PFNH (mb)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, npz, 1.E-2, Atm(n)%gridstruct%area_64, Atm(n)%domain) -! endif - used=send_data(id_pfnh, wk, Time) - if (id_ppnh > 0) then - do k=1,npz - do j=jsc,jec - do i=isc,iec - !wk(i,j,k) = wk(i,j,k) - a3(i,j,k) + enddo + used=send_data(id_pfnh, wk, Time) + if (prt_minmax) then + call prt_mxm(' PFNH (mb)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, npz, 1.E-2, Atm(n)%gridstruct%area_64, Atm(n)%domain, PRT_LEVEL_3) + endif + + if (id_ppnh > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec #ifdef GFS_PHYS - wk(i,j,k) = wk(i,j,k)/(1.-sum(Atm(n)%q(i,j,k,2:Atm(n)%flagstruct%nwat))) !Need to correct + wk(i,j,k) = wk(i,j,k)/(1.-sum(Atm(n)%q(i,j,k,2:Atm(n)%flagstruct%nwat))) !Correction for moist mass #endif - tmp = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j)) - wk(i,j,k) = wk(i,j,k) - tmp + tmp = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j)) + a3(i,j,k) = wk(i,j,k) - tmp enddo enddo - enddo - if (id_ppnh > 0) used=send_data(id_ppnh, wk, Time) - endif + enddo + used=send_data(id_ppnh, a3, Time) + endif -! if (allocated(a3)) deallocate(a3) + end if - endif - - if( Atm(n)%flagstruct%hydrostatic .and. (id_pfhy > 0 .or. id_cape > 0 .or. id_cin > 0 .or. id_brn > 0 .or. id_shear06 > 0) ) then - do k=1,npz - do j=jsc,jec - do i=isc,iec -#ifdef GFS_PHYS - wk(i,j,k) = 0.5 *(Atm(n)%pe(i,k,j)+Atm(n)%pe(i,k+1,j)) -#else - wk(i,j,k) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j)) -#endif - enddo - enddo - enddo - used=send_data(id_pfhy, wk, Time) - endif - - if (id_cape > 0 .or. id_cin > 0 .or. id_brn > 0 .or. id_shear06 > 0) then + !TODO: ONLY defined for non-hydrostatic for now; requires hydrostatic re-calculation of delz -- lmh 15 feb 24 + if (id_cape > 0 .or. id_cin > 0 .or. id_brn > 0 .or. id_shear06 > 0) then !wk here contains layer-mean pressure - allocate(var2(isc:iec,jsc:jec)) - allocate(a3(isc:iec,jsc:jec,npz)) + if (Atm(n)%flagstruct%hydrostatic) then + call mpp_error(NOTE, " CAPE, CIN, BRN, shear06 currently not implemented for hydrostatic dynamics.") + else + + allocate(var2(isc:iec,jsc:jec)) - call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd,jsd,1,sphum), & - isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys) + call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd,jsd,1,sphum), & + isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys) !$OMP parallel do default(shared) - do j=jsc,jec - do i=isc,iec - a2(i,j) = 0. - var2(i,j) = 0. + do j=jsc,jec + do i=isc,iec + a2(i,j) = 0. + var2(i,j) = 0. - call getcape(npz, wk(i,j,:), Atm(n)%pt(i,j,:), -Atm(n)%delz(i,j,:), Atm(n)%q(i,j,:,sphum), a3(i,j,:), a2(i,j), var2(i,j), source_in=1) - enddo - enddo + call getcape(npz, wk(i,j,:), Atm(n)%pt(i,j,:), -Atm(n)%delz(i,j,:), Atm(n)%q(i,j,:,sphum), a3(i,j,:), a2(i,j), var2(i,j), source_in=1) + enddo + enddo - if (id_cape > 0) then - if (prt_minmax) then - call prt_mxm(' CAPE (J/kg)', a2, isc,iec,jsc,jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - endif - used=send_data(id_cape, a2, Time) - endif - if (id_cin > 0) then - if (prt_minmax) then - call prt_mxm(' CIN (J/kg)', var2, isc,iec,jsc,jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - endif - used=send_data(id_cin, var2, Time) - endif + if (id_cape > 0) then + if (prt_minmax) then + call prt_mxm('CAPE (J/kg)', a2, isc,iec,jsc,jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + endif + used=send_data(id_cape, a2, Time) + endif + if (id_cin > 0) then + if (prt_minmax) then + call prt_mxm('CIN (J/kg)', var2, isc,iec,jsc,jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + endif + used=send_data(id_cin, var2, Time) + endif - if (id_brn > 0 .or. id_shear06 > 0) then - call compute_brn(Atm(n)%ua,Atm(n)%va,Atm(n)%delp,Atm(n)%delz,a2,Atm(n)%bd,npz,Time) - endif + if (id_brn > 0 .or. id_shear06 > 0) then + call compute_brn(Atm(n)%ua,Atm(n)%va,Atm(n)%delp,Atm(n)%delz,a2,Atm(n)%bd,npz,Time) + endif - deallocate(var2) - deallocate(a3) + deallocate(var2) + endif endif + deallocate(a3) + endif - - if((.not. Atm(n)%flagstruct%hydrostatic) .and. id_delz > 0) then - do k=1,npz - do j=jsc,jec - do i=isc,iec - wk(i,j,k) = -Atm(n)%delz(i,j,k) - enddo - enddo - enddo - used=send_data(id_delz, wk, Time) - endif + if((.not. Atm(n)%flagstruct%hydrostatic) .and. id_delz > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + wk(i,j,k) = -Atm(n)%delz(i,j,k) + enddo + enddo + enddo + used=send_data(id_delz, wk, Time) + endif ! pressure for masking p-level fields @@ -3199,7 +3230,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif if ( id_u100m>0 .or. id_v100m>0 .or. id_wind100m>0 .or. id_w100m>0 .or. id_w5km>0 .or. id_w2500m>0 & - & .or. id_w1km>0 .or. id_basedbz>0 .or. id_dbz4km>0) then + & .or. id_w1km>0 .or. id_basedbz>0 .or. id_dbz4km>0 .or. id_40dbzht>0) then if (.not.allocated(wz)) allocate ( wz(isc:iec,jsc:jec,npz+1) ) if ( Atm(n)%flagstruct%hydrostatic) then rgrav = 1. / grav @@ -3229,8 +3260,6 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo enddo endif - if( prt_minmax ) & - call prt_mxm('ZTOP', wz(isc:iec,jsc:jec,1)+Atm(n)%phis(isc:iec,jsc:jec)/grav, isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain) endif if ( id_rain5km>0 ) then @@ -3285,7 +3314,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif if ( rainwat > 0 .and. (id_dbz>0 .or. id_maxdbz>0 .or. id_basedbz>0 .or. id_dbz4km>0 & - & .or. id_dbztop>0 .or. id_dbz_m10C>0)) then + & .or. id_dbztop>0 .or. id_dbz_m10C>0 .or. id_40dbzht>0)) then if (.not. allocated(a3)) allocate(a3(isc:iec,jsc:jec,npz)) @@ -3317,7 +3346,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) do i=isc,iec a2(i,j) = missing_value2 do k=2,npz - if (wz(i,j,k) >= 25000. ) continue ! nothing above 25 km + if (wz(i,j,k) >= 25000. ) cycle ! nothing above 25 km if (a3(i,j,k) >= 18.5 ) then a2(i,j) = wz(i,j,k) exit @@ -3342,10 +3371,25 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo used=send_data(id_dbz_m10C, a2, time) endif + if (id_40dbzht > 0) then + do j=jsc,jec + do i=isc,iec + a2(i,j) = missing_value + do k=1,npz + if (wz(i,j,k) >= 25000.) cycle + if (a3(i,j,k) >= 40.) then + a2(i,j) = wz(i,j,k) + exit + endif + enddo + enddo + enddo + used=send_data(id_40dbzht, a2, time) + endif - if (prt_minmax) then + if (prt_minmax .and. user_prt_level >= PRT_LEVEL_1) then call mpp_max(allmax) - if (master) write(*,*) 'max reflectivity = ', allmax, ' dBZ' + if (master) write(*,'(2x, A16, G20.8, A4)') 'max reflectivity = ', allmax, ' dBZ' endif deallocate(a3) @@ -3354,278 +3398,43 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) !------------------------------------------------------- ! Applying cubic-spline as the intepolator for (u,v,T,q) !------------------------------------------------------- - if(.not. allocated(a3)) allocate( a3(isc:iec,jsc:jec,nplev) ) ! u-winds: - idg(:) = id_u(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%ua(isc:iec,jsc:jec,:), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, -1) -! plevs(1:nplev), Atm(n)%peln, idg, a3, -1) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_u_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%ua(isc:iec,jsc:jec,:), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, -1) - used=send_data(id_u_plev, a3(isc:iec,jsc:jec,:), Time) - endif + call make_plevs( Atm(n)%ua(isc:iec,jsc:jec,:), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, -1, id_u_plev, id_u_levs, nplev, Atm(n)%bd, Time) ! v-winds: - idg(:) = id_v(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%va(isc:iec,jsc:jec,:), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, -1) -! plevs(1:nplev), Atm(n)%peln, idg, a3, -1) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_v_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%va(isc:iec,jsc:jec,:), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, -1) - used=send_data(id_v_plev, a3(isc:iec,jsc:jec,:), Time) - endif + call make_plevs( Atm(n)%va(isc:iec,jsc:jec,:), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, -1, id_v_plev, id_v_levs, nplev, Atm(n)%bd, Time) ! Specific humidity - idg(:) = id_q(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,sphum), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_q_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,sphum), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_q_plev, a3(isc:iec,jsc:jec,:), Time) - endif + call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,sphum), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_q_plev, id_q_levs, nplev, Atm(n)%bd, Time) ! cloud water mass mixing ratio - idg(:) = id_ql(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,liq_wat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_ql_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,liq_wat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_ql_plev, a3(isc:iec,jsc:jec,:), Time) - endif - -! cloud ice mass mixing ratio - idg(:) = id_qi(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,ice_wat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_qi_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,ice_wat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_qi_plev, a3(isc:iec,jsc:jec,:), Time) - endif - -! rain mass mixing ratio - idg(:) = id_qr(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,rainwat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_qr_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,rainwat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_qr_plev, a3(isc:iec,jsc:jec,:), Time) - endif - -! snow mass mixing ratio - idg(:) = id_qs(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,snowwat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif +!NOTE: Can set this up for *ANY* tracers - if (id_qs_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,snowwat), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_qs_plev, a3(isc:iec,jsc:jec,:), Time) - endif + if (liq_wat > 0) call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,liq_wat), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_ql_plev, id_ql_levs, nplev, Atm(n)%bd, Time) -! graupel mass mixing ratio - idg(:) = id_qg(:) + if (ice_wat > 0) call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,ice_wat), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_qi_plev, id_qi_levs, nplev, Atm(n)%bd, Time) - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo + if (rainwat > 0) call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,rainwat), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_qr_plev, id_qr_levs, nplev, Atm(n)%bd, Time) - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,graupel), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif + if (snowwat > 0) call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,snowwat), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_qs_plev, id_qs_levs, nplev, Atm(n)%bd, Time) - if (id_qg_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,graupel), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_qg_plev, a3(isc:iec,jsc:jec,:), Time) - endif + if (graupel > 0) call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,graupel), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_qg_plev, id_qg_levs, nplev, Atm(n)%bd, Time) ! cloud fraction - idg(:) = id_cf(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,cld_amt), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0) -! plevs(1:nplev), Atm(n)%peln, idg, a3, 0) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_cf_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,cld_amt), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0) - used=send_data(id_cf_plev, a3(isc:iec,jsc:jec,:), Time) - endif + if (cld_amt > 0) call make_plevs( Atm(n)%q(isc:iec,jsc:jec,:,cld_amt), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, 0, id_cf_plev, id_cf_levs, nplev, Atm(n)%bd, Time) ! Omega - idg(:) = id_omg(:) - - do_cs_intp = .false. - do i=1,nplev - if ( idg(i)>0 ) then - do_cs_intp = .true. - exit - endif - enddo - if ( do_cs_intp ) then - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%omga(isc:iec,jsc:jec,:), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, -1) -! plevs(1:nplev), Atm(n)%peln, idg, a3) - do i=1,nplev - if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time) - enddo - endif - - if (id_omg_plev>0) then - id1(:) = 1 - call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%omga(isc:iec,jsc:jec,:), nplev, & - pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, -1) - used=send_data(id_omg_plev, a3(isc:iec,jsc:jec,:), Time) - endif - - if( allocated(a3) ) deallocate (a3) -! *** End cs_intp + call make_plevs( Atm(n)%omga(isc:iec,jsc:jec,:), plevs, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), & + npz, -1, id_omg_plev, id_omg_levs, nplev, Atm(n)%bd, Time) !!! BEGIN LAYER-AVERAGED DIAGNOSTICS allocate(a3(isc:iec,jsc:jec,nplev_ave)) @@ -3703,32 +3512,19 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) used=send_data(id_sl13, a2, Time) endif - if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. id_w200>0 ) then - call interpolate_vertical(isc, iec, jsc, jec, npz, & - 200.e2, Atm(n)%peln, Atm(n)%w(isc:iec,jsc:jec,:), a2) - used=send_data(id_w200, a2, Time) - endif -! 500-mb - if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. id_w500>0 ) then - call interpolate_vertical(isc, iec, jsc, jec, npz, & - 500.e2, Atm(n)%peln, Atm(n)%w(isc:iec,jsc:jec,:), a2) - used=send_data(id_w500, a2, Time) - endif - if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. id_w700>0 ) then - call interpolate_vertical(isc, iec, jsc, jec, npz, & - 700.e2, Atm(n)%peln, Atm(n)%w(isc:iec,jsc:jec,:), a2) - used=send_data(id_w700, a2, Time) + if ( .not. Atm(n)%flagstruct%hydrostatic ) then + call make_plevs( Atm(n)%w(isc:iec,jsc:jec,:), plevs_ln, Atm(n)%peln(isc:iec,1:npz+1,jsc:jec), & + npz, -1, id_w_plev, id_w_levs, nplev, Atm(n)%bd, Time) endif - if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. id_w850>0 .or. id_x850>0) then + + + if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. id_x850>0) then call interpolate_vertical(isc, iec, jsc, jec, npz, & 850.e2, Atm(n)%peln, Atm(n)%w(isc:iec,jsc:jec,:), a2) - used=send_data(id_w850, a2, Time) - if ( id_x850>0 .and. id_vort850>0 ) then - x850(:,:) = x850(:,:)*a2(:,:) - used=send_data(id_x850, x850, Time) - deallocate ( x850 ) - endif + x850(:,:) = x850(:,:)*a2(:,:) + used=send_data(id_x850, x850, Time) + deallocate ( x850 ) endif @@ -3760,13 +3556,10 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if(id_pt > 0) used=send_data(id_pt , Atm(n)%pt (isc:iec,jsc:jec,:), Time) if(id_omga > 0) used=send_data(id_omga, Atm(n)%omga(isc:iec,jsc:jec,:), Time) if(id_diss > 0) used=send_data(id_diss, Atm(n)%diss_est(isc:iec,jsc:jec,:), Time) + if(id_diss_heat > 0) used=send_data(id_diss_heat, Atm(n)%heat_source(isc:iec,jsc:jec,:), Time) allocate( a3(isc:iec,jsc:jec,npz) ) - if(id_theta_e > 0 .or. & - id_theta_e100>0 .or. id_theta_e200>0 .or. id_theta_e250>0 .or. id_theta_e300>0 .or. & - id_theta_e500>0 .or. id_theta_e700>0 .or. id_theta_e850>0 .or. id_theta_e925>0 .or. & - id_theta_e1000>0) then - + if(id_theta_e > 0 .or. ANY(id_theta_e_levs > 0) .or. id_theta_e_plev > 0) then if ( Atm(n)%flagstruct%adiabatic .and. Atm(n)%flagstruct%kord_tm>0 ) then do k=1,npz do j=jsc,jec @@ -3780,43 +3573,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys) endif - - if (id_theta_e100>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e100, a2, Time) - endif - if (id_theta_e200>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e200, a2, Time) - endif - if (id_theta_e250>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e250, a2, Time) - endif - if (id_theta_e300>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 300.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e300, a2, Time) - endif - if (id_theta_e500>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e500, a2, Time) - endif - if (id_theta_e700>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e700, a2, Time) - endif - if (id_theta_e850>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e850, a2, Time) - endif - if (id_theta_e925>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 925.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e925, a2, Time) - endif - if (id_theta_e1000>0) then - call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, Atm(n)%peln, a3(isc:iec,jsc:jec,:), a2) - used=send_data(id_theta_e1000, a2, Time) - endif + call make_plevs( a3, plevs_ln, Atm(n)%peln(isc:iec,1:npz+1,jsc:jec), & + npz, 1, id_theta_e_plev, id_theta_e_levs, nplev, Atm(n)%bd, Time) if (id_theta_e > 0) then if( prt_minmax ) call prt_mxm('Theta_E', a3, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) @@ -3850,7 +3608,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif - if(id_ppt> 0) then + if(id_ppt> 0 .or. ANY(id_theta_levs>0) .or. id_theta_plev>0) then ! Potential temperature perturbation for gravity wave test_case allocate ( pt1(npz) ) if( .not. allocated(a3) ) allocate ( a3(isc:iec,jsc:jec,npz) ) @@ -3880,12 +3638,17 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo enddo endif - used=send_data(id_ppt, wk, Time) + if (id_ppt > 0) then + used=send_data(id_ppt, wk, Time) - if( prt_minmax ) then - call prt_mxm('PoTemp', wk, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + if( prt_minmax ) then + call prt_mxm('PoTemp', wk, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + endif endif + call make_plevs( wk, plevs_ln, Atm(n)%peln(isc:iec,1:npz+1,jsc:jec), & + npz, 1, id_theta_plev, id_theta_levs, nplev, Atm(n)%bd, Time) + if( allocated(a3) ) deallocate ( a3 ) deallocate ( pt1 ) endif @@ -3898,10 +3661,10 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) used = send_data (id_tracer(itrac), Atm(n)%q(isc:iec,jsc:jec,:,itrac), Time ) endif if (itrac .le. nq) then - if( prt_minmax ) call prt_mxm(trim(tname)//": ", Atm(n)%q(:,:,1,itrac), & + if( prt_minmax ) call prt_mxm(trim(tname), Atm(n)%q(:,:,1,itrac), & isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) else - if( prt_minmax ) call prt_mxm(trim(tname)//": ", Atm(n)%qdiag(:,:,1,itrac), & + if( prt_minmax ) call prt_mxm(trim(tname), Atm(n)%qdiag(:,:,1,itrac), & isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) endif !------------------------------- @@ -4165,7 +3928,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo enddo call prt_gb_nh_sh('Max_cld',isc,iec, jsc,jec, a2, Atm(n)%gridstruct%area_64(isc:iec,jsc:jec), & - Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2)) + Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2), PRT_LEVEL_1) endif endif @@ -4267,7 +4030,6 @@ subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort end subroutine get_vorticity - subroutine get_height_field(is, ie, js, je, ng, km, hydrostatic, delz, wz, pt, q, peln, zvir) integer, intent(in):: is, ie, js, je, km, ng real, intent(in):: peln(is:ie,km+1,js:je) @@ -4448,16 +4210,22 @@ subroutine range_check_2d(qname, q, is, ie, js, je, n_g, pos, q_low, q_hi, bad_r end subroutine range_check_2d - subroutine prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac) + subroutine prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac, prt_level) character(len=*), intent(in):: qname integer, intent(in):: is, ie, js, je integer, intent(in):: n_g, km + integer, intent(in), OPTIONAL :: prt_level real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km) real, intent(in):: fac real qmin, qmax integer i,j,k - character(len=12) :: display_name + character(len=16) :: display_name + + if (present(prt_level)) then + if (prt_level > user_prt_level) return + endif + !mpp_root_pe doesn't appear to recognize nested grid master = (mpp_pe()==mpp_root_pe()) .or. is_master() @@ -4482,19 +4250,20 @@ subroutine prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac) call mp_reduce_max(qmax) if(master) then - j = min(len(trim(qname)),12) + j = min(len(trim(qname)),16) display_name = qname(1:j) - write(*,*) display_name, ' ', trim(gn), ' max=', qmax*fac, 'min=',qmin*fac + write(*,'(2x, A16, A, A1, A5, G20.8, A5, G20.8)') display_name, trim(gn), ':', ' max=', qmax*fac, 'min=',qmin*fac endif end subroutine prt_maxmin - subroutine prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain) + subroutine prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain, prt_level) character(len=*), intent(in):: qname integer, intent(in):: is, ie, js, je integer, intent(in):: n_g, km real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km) real, intent(in):: fac + integer, intent(in), OPTIONAL :: prt_level ! BUG !!! ! real, intent(IN):: area(is-n_g:ie+n_g, js-n_g:je+n_g, km) real(kind=R_GRID), intent(IN):: area(is-3:ie+3, js-3:je+3) @@ -4502,7 +4271,11 @@ subroutine prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain) ! real qmin, qmax, gmean integer i,j,k - character(len=8) :: display_name + character(len=16) :: display_name + + if (present(prt_level)) then + if (prt_level > user_prt_level) return + endif !mpp_root_pe doesn't appear to recognize nested grid master = (mpp_pe()==mpp_root_pe()) .or. is_master() @@ -4532,15 +4305,16 @@ subroutine prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain) gmean = g_sum(domain, q(is:ie,js:je,km), is, ie, js, je, 3, area, 1) if(master) then - j = min(len(trim(qname)),8) + j = min(len(trim(qname)),16) display_name = qname(1:j) - write(6,*) display_name, trim(gn), qmax*fac, qmin*fac, gmean*fac + write(6,'(2x,A16,A,A1,3G20.8)') display_name, trim(gn), ':', qmax*fac, qmin*fac, gmean*fac endif end subroutine prt_mxm !Added nwat == 1 case for water vapor diagnostics - subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain) + subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, & + area, domain, prt_level_in) integer, intent(in):: is, ie, js, je integer, intent(in):: nq, n_g, km, nwat @@ -4549,12 +4323,17 @@ subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km, nq) real(kind=R_GRID), intent(IN):: area(is-n_g:ie+n_g,js-n_g:je+n_g) type(domain2d), intent(INOUT) :: domain + integer, intent(in), OPTIONAL :: prt_level_in ! Local: - real psq(is:ie,js:je,nwat), psqv(is:ie,js:je) + real psq(is:ie,js:je,nq), psqv(is:ie,js:je) real q_strat(is:ie,js:je) real qtot(nwat), qwat real psmo, totw, psdry integer k, n, kstrat + integer :: prt_level = 1 + + if (present(prt_level_in)) prt_level = prt_level_in + if (prt_level <= PRT_LEVEL_0) return !Needed when calling prt_mass in fv_restart? sphum = get_tracer_index (MODEL_ATMOS, 'sphum') @@ -4565,11 +4344,11 @@ subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') graupel = get_tracer_index (MODEL_ATMOS, 'graupel') - if (master) write(*,*) '--- Mass Diagnostics ------------------------' + if (master) write(*,*) ' Mass Diagnostics:' if ( nwat==0 ) then psmo = g_sum(domain, ps(is:ie,js:je), is, ie, js, je, n_g, area, 1) - if( master ) write(*,*) 'Total surface pressure (mb)', trim(gn), ' = ', 0.01*psmo + if( master ) write(*,*) ' Total surface pressure (mb)', trim(gn), ' = ', 0.01*psmo call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,1 ), psqv(is,js)) return endif @@ -4594,16 +4373,18 @@ subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain ! Mean water vapor in the "stratosphere" (75 mb and above): - if ( phalf(2)< 75. ) then - kstrat = 1 - do k=1,km - if ( phalf(k+1) > 75. ) exit - kstrat = k - enddo - call z_sum(is, ie, js, je, kstrat, n_g, delp, q(is-n_g,js-n_g,1,sphum), q_strat(is,js)) - psmo = g_sum(domain, q_strat(is,js), is, ie, js, je, n_g, area, 1) * 1.e6 & - / p_sum(is, ie, js, je, kstrat, n_g, delp, area, domain) - if(master) write(*,*) 'Mean_Specific_Humidity (mg/kg) above 75 mb', trim(gn), ' = ', psmo + if (prt_level >= PRT_LEVEL_2) then + if ( phalf(2)< 75. ) then + kstrat = 1 + do k=1,km + if ( phalf(k+1) > 75. ) exit + kstrat = k + enddo + call z_sum(is, ie, js, je, kstrat, n_g, delp, q(is-n_g,js-n_g,1,sphum), q_strat(is,js)) + psmo = g_sum(domain, q_strat(is,js), is, ie, js, je, n_g, area, 1) * 1.e6 & + / p_sum(is, ie, js, je, kstrat, n_g, delp, area, domain) + if(master) write(*,*) ' Mean Specific Humidity (mg/kg) above 75 mb', trim(gn), ' = ', psmo + endif endif @@ -4620,23 +4401,23 @@ subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain psdry = psmo - totw if( master ) then - write(*,*) 'Total_Surface_Pressure (mb)', trim(gn), ' = ', 0.01*psmo - write(*,*) 'Mean_Dry_Surface_Pressure (mb)', trim(gn), ' = ', 0.01*psdry - write(*,*) 'Total_Water_Vapor (kg/m**2)', trim(gn), ' = ', qtot(sphum)*ginv + write(*,*) ' Total Surface Pressure (mb) ', trim(gn), ' = ', 0.01*psmo + write(*,*) ' Mean Dry Surface Pressure (mb)', trim(gn), ' = ', 0.01*psdry + write(*,*) ' Total Water Vapor (kg/m**2) ', trim(gn), ' = ', qtot(sphum)*ginv if ( nwat> 2 ) then - write(*,*) '--- Micro Phys water substances (kg/m**2) ---' - write(*,*) 'Total_Cloud_Water', trim(gn), ' = ', qtot(liq_wat)*ginv + write(*,*) ' Micro Phys water substances (kg/m**2) ' + write(*,*) ' Total Cloud Water', trim(gn), ' = ', qtot(liq_wat)*ginv if (rainwat > 0) & - write(*,*) 'Total_Rain_Water ', trim(gn), ' = ', qtot(rainwat)*ginv + write(*,*) ' Total Rain Water ', trim(gn), ' = ', qtot(rainwat)*ginv if (ice_wat > 0) & - write(*,*) 'Total_Cloud_Ice ', trim(gn), ' = ', qtot(ice_wat)*ginv + write(*,*) ' Total Cloud Ice ', trim(gn), ' = ', qtot(ice_wat)*ginv if (snowwat > 0) & - write(*,*) 'Total_Snow ', trim(gn), ' = ', qtot(snowwat)*ginv + write(*,*) ' Total Snow ', trim(gn), ' = ', qtot(snowwat)*ginv if (graupel > 0) & - write(*,*) 'Total_Graupel ', trim(gn), ' = ', qtot(graupel)*ginv - write(*,*) '---------------------------------------------' + write(*,*) ' Total Graupel ', trim(gn), ' = ', qtot(graupel)*ginv + !write(*,*) '---------------------------------------------' elseif ( nwat==2 ) then - write(*,*) 'GFS_Condensate (kg/m^2)', trim(gn), ' = ', qtot(liq_wat)*ginv + write(*,*) ' GFS Condensate (kg/m^2)', trim(gn), ' = ', qtot(liq_wat)*ginv endif endif @@ -4806,6 +4587,8 @@ subroutine prt_height(qname, is, ie, js, je, ng, km, press, phis, delz, peln, ar real(kind=R_GRID):: log_p integer i,j,k, k2, l + if (PRT_LEVEL_1 > user_prt_level) return + log_p = log(press) k2 = max(12, km/2+1) @@ -4837,22 +4620,27 @@ subroutine prt_height(qname, is, ie, js, je, ng, km, press, phis, delz, peln, ar enddo 1000 continue enddo - call prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat) + call prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat, PRT_LEVEL_1) end subroutine prt_height - subroutine prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat) + subroutine prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat, prt_level) character(len=*), intent(in):: qname integer, intent(in):: is, ie, js, je real, intent(in), dimension(is:ie, js:je):: a2 real(kind=R_GRID), intent(in), dimension(is:ie, js:je):: area, lat + integer, intent(in), OPTIONAL :: prt_level ! Local: real(R_GRID), parameter:: rad2deg = 180./pi real(R_GRID):: slat real:: t_eq, t_nh, t_sh, t_gb real:: area_eq, area_nh, area_sh, area_gb integer:: i,j - character(len=12) :: display_name + character(len=16) :: display_name + + if (present(prt_level)) then + if (prt_level > user_prt_level) return + endif t_eq = 0. ; t_nh = 0.; t_sh = 0.; t_gb = 0. area_eq = 0.; area_nh = 0.; area_sh = 0.; area_gb = 0. @@ -4887,26 +4675,24 @@ subroutine prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat) if (area_sh <= 1.) area_sh = -1.0 if (area_eq <= 1.) area_eq = -1.0 if (is_master()) then - j = min(len(trim(qname)),12) + j = min(len(trim(qname)),16) display_name = qname(1:j) - write(*,*) display_name, 'GB=',t_gb/area_gb, 'NH=',t_nh/area_nh - display_name='' - write(*,*) display_name, 'SH=',t_sh/area_sh, 'EQ=',t_eq/area_eq + write(6,'(2x,A16,A6,G20.8,A4,G20.8)') display_name, ': GB =',t_gb/area_gb, 'NH =',t_nh/area_nh + write(6,'(20x,A4,G20.8,A4,G20.8)') 'SH =',t_sh/area_sh, 'EQ =',t_eq/area_eq endif end subroutine prt_gb_nh_sh - subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout, iv) + subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, plevs, pe, id, qout, iv) ! iv =-1: winds ! iv = 0: positive definite scalars ! iv = 1: temperature integer, intent(in):: is, ie, js, je, km, iv integer, intent(in):: kd ! vertical dimension of the ouput height integer, intent(in):: id(kd) - real, intent(in):: pout(kd) ! must be monotonically increasing with increasing k + real, intent(in):: plevs(kd) ! must be monotonically increasing with increasing k real, intent(in):: pe(is:ie,km+1,js:je) real, intent(in):: qin(is:ie,js:je,km) - real, intent(in):: wz(is:ie,js:je,km+1) real, intent(out):: qout(is:ie,js:je,kd) ! local: real, parameter:: gcp = grav / cp_air @@ -4915,7 +4701,7 @@ subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout, real:: s0, a6, alpha, pbot, ts, t0, tmp integer:: i,j,k, n, k1 -!$OMP parallel do default(none) shared(iv,id,is,ie,js,je,km,kd,pout,qin,qout,pe,wz) & +!$OMP parallel do default(none) shared(iv,id,is,ie,js,je,km,kd,plevs,qin,qout,pe,zsurf) & !$OMP private(k1,s0,a6,q2,dp,qe,pbot,alpha,ts,t0,tmp) do j=js,je @@ -4932,47 +4718,47 @@ subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout, k1 = 1 do n=1,kd if ( id(n) > 0 ) then - if( pout(n) <= pe(i,1,j) ) then + if( plevs(n) <= pe(i,1,j) ) then ! Higher than the top: qout(i,j,n) = qe(i,1) - elseif ( pout(n) >= pe(i,km+1,j) ) then + elseif ( plevs(n) >= pe(i,km+1,j) ) then ! lower than the bottom surface: if ( iv==1 ) then ! Temperature !----------------------------------------------------------------------- ! Linjiong Zhou: this idea is good, but the formula is wrong. ! lower than the bottom surface: ! mean (hydro) potential temp based on lowest 2-3 layers (NCEP method) -! temp = ptm * p**cappa = ptm * exp(cappa*log(pout)) -! qout(i,j,n) = gcp*exp(kappa*pout(n)) * (wz(i,j,km-2) - wz(i,j,km)) / & +! temp = ptm * p**cappa = ptm * exp(cappa*log(plevs)) +! qout(i,j,n) = gcp*exp(kappa*plevs(n)) * (wz(i,j,km-2) - wz(i,j,km)) / & ! ( exp(kappa*pe(i,km,j)) - exp(kappa*pe(i,km-2,j)) ) !----------------------------------------------------------------------- ! ECMWF Method: Trenberth et al., 1993 alpha = 0.0065*rdgas/grav pbot = (exp(pe(i,km+1,j))-exp(pe(i,km,j)))/(pe(i,km+1,j)-pe(i,km,j)) ts = (q2(i,km)+alpha*q2(i,km)*(exp(pe(i,km+1,j))/pbot-1)) - t0 = ts+0.0065*wz(i,j,km+1) + t0 = ts+0.0065*zsurf(i,j) tmp = min(t0,298.0) - if (wz(i,j,km+1).ge.2000.0) then - if (wz(i,j,km+1).le.2500.0) then - tmp = 0.002*((2500-wz(i,j,km+1))*t0+(wz(i,j,km+1)-2000)*tmp) + if (zsurf(i,j).ge.2000.0) then + if (zsurf(i,j).le.2500.0) then + tmp = 0.002*((2500-zsurf(i,j))*t0+(zsurf(i,j)-2000)*tmp) endif if (tmp-ts.lt.0) then alpha = 0 else - alpha = rdgas*(tmp-ts)/(wz(i,j,km+1)*grav) + alpha = rdgas*(tmp-ts)/(zsurf(i,j)*grav) endif endif - qout(i,j,n) = ts*exp(alpha*(pout(n)-pe(i,km+1,j))) + qout(i,j,n) = ts*exp(alpha*(plevs(n)-pe(i,km+1,j))) !----------------------------------------------------------------------- else qout(i,j,n) = qe(i,km+1) endif else do k=k1,km - if ( pout(n)>=pe(i,k,j) .and. pout(n) <= pe(i,k+1,j) ) then + if ( plevs(n)>=pe(i,k,j) .and. plevs(n) <= pe(i,k+1,j) ) then ! PPM distribution: f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) a6 = 3.*(2.*q2(i,k) - (qe(i,k)+qe(i,k+1))) - s0 = (pout(n)-pe(i,k,j)) / dp(i,k) + s0 = (plevs(n)-pe(i,k,j)) / dp(i,k) qout(i,j,n) = qe(i,k) + s0*(qe(i,k+1)-qe(i,k)+a6*(1.-s0)) k1 = k ! next level go to 500 @@ -5889,8 +5675,7 @@ subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, np end subroutine eqv_pot -#endif - +#endif SIMPLIFIED_THETA_E subroutine compute_brn(ua, va, delp, delz, cape, bd, npz, Time) @@ -6564,4 +6349,47 @@ function Mw_air_3d(sum_wat) result(out) out = WTMAIR*WTMH2O/((1.-sum_wat)*WTMH2O+sum_wat*WTMAIR) end function Mw_air_3d + subroutine make_plevs( field, plevs, pe, npz, iv, id_plev, id_levs, nplev, bd, Time, field_plev_out) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npz, nplev + real, intent(IN) :: field(bd%is:bd%ie,bd%js:bd%je,npz) !Data domain only!! + real, intent(IN) :: plevs(nplev) !plevs and pe *must* be the same quantity (pe, peln, theta, etc.) + real, intent(IN) :: pe(bd%is:bd%ie,npz+1,bd%js:bd%je) !Data domain only!! + integer, intent(IN) :: iv, id_plev, id_levs(nplev) + type(time_type), intent(IN) :: Time + real, intent(OUT), OPTIONAL :: field_plev_out(bd%isc:bd%iec,bd%jsc:bd%jec,nplev) + + real :: field_plev(bd%isc:bd%iec,bd%jsc:bd%jec,nplev) + integer, dimension(nplev) :: id1 + integer :: i, used + integer :: isc, iec, jsc, jec + + isc = bd%is + iec = bd%ie + jsc = bd%js + jec = bd%je + + id1(:) = 1. + + if (ANY(id_levs > 0)) then + call cs3_interpolator(isc,iec,jsc,jec,npz, field, nplev, & + plevs, pe, id_levs, field_plev, iv) + do i=1,nplev + if (id_levs(i)>0) used=send_data(id_levs(i), field_plev(isc:iec,jsc:jec,i), Time) + enddo + endif + + if (id_plev > 0) then + call cs3_interpolator(isc,iec,jsc,jec,npz, field, nplev, & + plevs, pe, id1, field_plev, iv) + used=send_data(id_plev, field_plev(isc:iec,jsc:jec,:), Time) + endif + + if (present(field_plev_out)) then + field_plev_out = field_plev + endif + + end subroutine make_plevs + end module fv_diagnostics_mod diff --git a/tools/fv_diagnostics.h b/tools/fv_diagnostics.h index 8206f43b2..1191858f8 100644 --- a/tools/fv_diagnostics.h +++ b/tools/fv_diagnostics.h @@ -23,7 +23,7 @@ #define _FV_DIAG__ integer ::id_ps, id_slp, id_ua, id_va, id_pt, id_omga, id_vort, & - id_tm, id_pv, id_zsurf, id_oro, id_sgh, id_w, & + id_tm, id_pv, id_zsurf, id_zsurf_t, id_oro, id_sgh, id_w, & id_ke, id_zs, id_ze, id_mq, id_vorts, id_us, id_vs, & id_tq, id_rh, id_c15, id_c25, id_c35, id_c45, & id_f15, id_f25, id_f35, id_f45, id_ctp, & @@ -32,33 +32,29 @@ id_pfhy, id_pfnh, id_ppnh, & id_qn, id_qn200, id_qn500, id_qn850, id_qp, & id_qdt, id_acly, id_acl, id_acl2, & - id_dbz, id_maxdbz, id_basedbz, id_dbz4km, id_dbztop, id_dbz_m10C, & + id_dbz, id_maxdbz, id_basedbz, id_dbz4km, & + id_dbztop, id_dbz_m10C, id_40dbzht, & id_ctz, id_w1km, id_wmaxup, id_wmaxdn, id_cape, id_cin, id_brn, id_shear06 ! Selected theta-level fields from 3D variables: integer :: id_pv350K, id_pv550K ! Selected p-level fields from 3D variables: - integer :: id_vort200, id_vort500, id_w500, id_w700 - integer :: id_vort850, id_w850, id_x850, id_srh25, & + integer :: id_x850, id_srh25, & id_uh03, id_uh25, id_theta_e, & - id_w200, id_s200, id_sl12, id_sl13, id_w5km, id_rain5km, id_w2500m + id_s200, id_sl12, id_sl13, id_w5km, id_rain5km, id_w2500m integer :: id_srh1, id_srh3, id_ustm, id_vstm -! NGGPS 31-level diag - integer, allocatable :: id_u(:), id_v(:), id_t(:), id_h(:), id_q(:), id_omg(:) - integer, allocatable :: id_ql(:), id_qi(:), id_qr(:), id_qs(:), id_qg(:), id_cf(:) +! plev and plev_ave diagnostics + integer, allocatable :: id_u_levs(:), id_v_levs(:), id_t_levs(:), id_h_levs(:), id_q_levs(:), id_omg_levs(:) + integer, allocatable :: id_ql_levs(:), id_qi_levs(:), id_qr_levs(:), id_qs_levs(:), id_qg_levs(:), id_cf_levs(:) + integer, allocatable :: id_w_levs(:), id_vort_levs(:), id_rh_levs(:), id_dp_levs(:), id_theta_e_levs(:), id_theta_levs(:) integer:: id_u_plev, id_v_plev, id_t_plev, id_h_plev, id_q_plev, id_omg_plev integer:: id_ql_plev, id_qi_plev, id_qr_plev, id_qs_plev, id_qg_plev, id_cf_plev integer:: id_t_plev_ave, id_q_plev_ave, id_qv_dt_gfdlmp_plev_ave, id_t_dt_gfdlmp_plev_ave, id_qv_dt_phys_plev_ave, id_t_dt_phys_plev_ave + integer:: id_w_plev, id_vort_plev, id_rh_plev, id_dp_plev, id_theta_e_plev, id_theta_plev - integer :: id_theta_e100, id_theta_e200, id_theta_e250, id_theta_e300, & - id_theta_e500, id_theta_e700, id_theta_e850, id_theta_e925, id_theta_e1000 ! IPCC diag - integer :: id_rh10, id_rh50, id_rh100, id_rh200, id_rh250, id_rh300, & - id_rh500, id_rh700, id_rh850, id_rh925, id_rh1000 - integer :: id_dp10, id_dp50, id_dp100, id_dp200, id_dp250, id_dp300, & - id_dp500, id_dp700, id_dp850, id_dp925, id_dp1000 integer :: id_rh1000_cmip, id_rh925_cmip, id_rh850_cmip, id_rh700_cmip, id_rh500_cmip, & id_rh300_cmip, id_rh250_cmip, id_rh100_cmip, id_rh50_cmip, id_rh10_cmip @@ -66,46 +62,51 @@ integer :: id_hght3d, id_any_hght integer :: id_u100m, id_v100m, id_w100m, id_wind100m - ! For initial conditions: - integer ic_ps, ic_ua, ic_va, ic_ppt - integer ic_sphum - integer, allocatable :: id_tracer(:) + ! For initial conditions: + integer ic_ps, ic_ua, ic_va, ic_ppt + integer ic_sphum + integer, allocatable :: id_tracer(:) ! dissipation estimates - integer :: id_diss + integer :: id_diss, id_diss_heat ! ESM requested diagnostics - dry mass/volume mixing ratios integer, allocatable :: id_tracer_dmmr(:) integer, allocatable :: id_tracer_dvmr(:) integer, allocatable :: id_tracer_burden(:) - real, allocatable :: w_mr(:) logical, allocatable :: conv_vmr_mmr(:) - real, allocatable :: phalf(:) - real, allocatable :: zsurf(:,:) - real, allocatable :: pt1(:) - - integer :: id_pret, id_prew, id_prer, id_prei, id_pres, id_preg - integer :: id_prefluxw, id_prefluxr, id_prefluxi, id_prefluxs, id_prefluxg - integer :: id_qv_dt_gfdlmp, id_T_dt_gfdlmp, id_ql_dt_gfdlmp, id_qi_dt_gfdlmp - integer :: id_qr_dt_gfdlmp, id_qg_dt_gfdlmp, id_qs_dt_gfdlmp - integer :: id_liq_wat_dt_gfdlmp, id_ice_wat_dt_gfdlmp - integer :: id_u_dt_gfdlmp, id_v_dt_gfdlmp - integer :: id_t_dt_phys, id_qv_dt_phys, id_ql_dt_phys, id_qi_dt_phys, id_u_dt_phys, id_v_dt_phys - integer :: id_qr_dt_phys, id_qg_dt_phys, id_qs_dt_phys - integer :: id_liq_wat_dt_phys, id_ice_wat_dt_phys - integer :: id_intqv, id_intql, id_intqi, id_intqr, id_intqs, id_intqg - integer :: id_t_dt_diabatic, id_qv_dt_diabatic +! Microphysical diagnostics + integer :: id_pret, id_prew, id_prer, id_prei, id_pres, id_preg + integer :: id_prefluxw, id_prefluxr, id_prefluxi, id_prefluxs, id_prefluxg + integer :: id_qv_dt_gfdlmp, id_T_dt_gfdlmp, id_ql_dt_gfdlmp, id_qi_dt_gfdlmp + integer :: id_qr_dt_gfdlmp, id_qg_dt_gfdlmp, id_qs_dt_gfdlmp + integer :: id_liq_wat_dt_gfdlmp, id_ice_wat_dt_gfdlmp + integer :: id_u_dt_gfdlmp, id_v_dt_gfdlmp + integer :: id_t_dt_phys, id_qv_dt_phys, id_ql_dt_phys, id_qi_dt_phys, id_u_dt_phys, id_v_dt_phys + integer :: id_qr_dt_phys, id_qg_dt_phys, id_qs_dt_phys + integer :: id_liq_wat_dt_phys, id_ice_wat_dt_phys + integer :: id_intqv, id_intql, id_intqi, id_intqr, id_intqs, id_intqg + integer :: id_t_dt_diabatic, id_qv_dt_diabatic + + integer :: id_mppcw, id_mppew, id_mppe1, id_mpper, id_mppdi + integer :: id_mppd1, id_mppds, id_mppdg, id_mppsi, id_mpps1 + integer :: id_mppss, id_mppsg, id_mppfw, id_mppfr, id_mppmi + integer :: id_mppms, id_mppmg, id_mppar, id_mppas, id_mppag + integer :: id_mpprs, id_mpprg, id_mppxr, id_mppxs, id_mppxg + integer :: id_mppm1, id_mppm2, id_mppm3 + + integer :: id_qcw, id_qcr, id_qci, id_qcs, id_qcg + integer :: id_rew, id_rer, id_rei, id_res, id_reg, id_cld ! ESM/CM 3-D diagostics - integer :: id_uq, id_vq, id_wq, id_iuq, id_ivq, id_iwq, & ! moisture flux & vertical integral - id_ut, id_vt, id_wt, id_iut, id_ivt, id_iwt, & ! heat flux - id_uu, id_uv, id_vv, id_ww, & ! momentum flux - id_iuu, id_iuv, id_iuw, id_ivv, id_ivw, id_iww ! vertically integral of momentum flux - - integer :: id_uw, id_vw - integer :: id_lagrangian_tendency_of_hydrostatic_pressure - integer :: id_t_dt_nudge, id_ps_dt_nudge, id_delp_dt_nudge, id_u_dt_nudge, id_v_dt_nudge + integer :: id_uq, id_vq, id_wq, id_iuq, id_ivq, id_iwq, & ! moisture flux & vertical integral + id_ut, id_vt, id_wt, id_iut, id_ivt, id_iwt, & ! heat flux + id_uu, id_uv, id_vv, id_ww, & ! momentum flux + id_iuu, id_iuv, id_iuw, id_ivv, id_ivw, id_iww ! vertically integral of momentum flux + + integer :: id_uw, id_vw + integer :: id_t_dt_nudge, id_ps_dt_nudge, id_delp_dt_nudge, id_u_dt_nudge, id_v_dt_nudge, id_qv_dt_nudge #ifdef GFS_PHYS integer :: id_delp_total #endif diff --git a/tools/fv_io.F90 b/tools/fv_io.F90 index cf7b02878..bf46d5d6e 100644 --- a/tools/fv_io.F90 +++ b/tools/fv_io.F90 @@ -61,6 +61,8 @@ module fv_io_mod use fv_treat_da_inc_mod, only: read_da_inc use mpp_parameter_mod, only: DGRID_NE use fv_grid_utils_mod, only: cubed_a2d + use fv_operators_mod, only: remap_2d + use constants_mod, only: rvgas, rdgas, grav implicit none private @@ -620,7 +622,6 @@ end subroutine fv_io_read_tracers subroutine remap_restart(Atm) - use fv_mapz_mod, only: rst_remap type(fv_atmos_type), intent(inout) :: Atm(:) @@ -823,6 +824,300 @@ subroutine remap_restart(Atm) end subroutine remap_restart + subroutine rst_remap(km, kn, is,ie,js,je, isd,ied,jsd,jed, nq, ntp, & + delp_r, u0_r, v0_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, & + delp, u0, v0, u, v, w, delz, pt, q, qdiag, & + ak_r, bk_r, ptop, ak, bk, hydrostatic, make_nh, & + domain, square_domain, is_ideal_case) +!------------------------------------ +! Assuming hybrid sigma-P coordinate: +!------------------------------------ +! !INPUT PARAMETERS: + integer, intent(in):: km ! Restart z-dimension + integer, intent(in):: kn ! Run time dimension + integer, intent(in):: nq, ntp ! number of tracers (including h2o) + integer, intent(in):: is,ie,isd,ied ! starting & ending X-Dir index + integer, intent(in):: js,je,jsd,jed ! starting & ending Y-Dir index + logical, intent(in):: hydrostatic, make_nh, square_domain, is_ideal_case + real, intent(IN) :: ptop + real, intent(in) :: ak_r(km+1) + real, intent(in) :: bk_r(km+1) + real, intent(in) :: ak(kn+1) + real, intent(in) :: bk(kn+1) + real, intent(in):: delp_r(is:ie,js:je,km) ! pressure thickness + real, intent(in):: u0_r(is:ie, js:je+1,km) ! initial (t=0) u-wind (m/s) + real, intent(in):: v0_r(is:ie+1,js:je ,km) ! initial (t=0) v-wind (m/s) + real, intent(in):: u_r(is:ie, js:je+1,km) ! u-wind (m/s) + real, intent(in):: v_r(is:ie+1,js:je ,km) ! v-wind (m/s) + real, intent(inout):: pt_r(is:ie,js:je,km) + real, intent(in):: w_r(is:ie,js:je,km) + real, intent(in):: q_r(is:ie,js:je,km,1:ntp) + real, intent(in):: qdiag_r(is:ie,js:je,km,ntp+1:nq) + real, intent(inout)::delz_r(is:ie,js:je,km) + type(domain2d), intent(INOUT) :: domain +! Output: + real, intent(out):: delp(isd:ied,jsd:jed,kn) ! pressure thickness + real, intent(out):: u0(isd:,jsd:,1:) ! initial (t=0) u-wind (m/s) + real, intent(out):: v0(isd:,jsd:,1:) ! initial (t=0) v-wind (m/s) + real, intent(out):: u(isd:ied ,jsd:jed+1,kn) ! u-wind (m/s) + real, intent(out):: v(isd:ied+1,jsd:jed ,kn) ! v-wind (m/s) + real, intent(out):: w(isd: ,jsd: ,1:) ! vertical velocity (m/s) + real, intent(out):: pt(isd:ied ,jsd:jed ,kn) ! temperature + real, intent(out):: q(isd:ied,jsd:jed,kn,1:ntp) + real, intent(out):: qdiag(isd:ied,jsd:jed,kn,ntp+1:nq) + real, intent(out):: delz(is:,js:,1:) ! delta-height (m) +!----------------------------------------------------------------------- + real r_vir, rgrav + real ps(isd:ied,jsd:jed) ! surface pressure + real pe1(is:ie,km+1) + real pe2(is:ie,kn+1) + real pv1(is:ie+1,km+1) + real pv2(is:ie+1,kn+1) + + integer i,j,k , iq + !CS operator replaces original mono PPM 4 --- lmh 19apr23 + integer, parameter:: kord=4 ! 13 + +#ifdef HYDRO_DELZ_REMAP + if (is_master() .and. .not. hydrostatic) then + print*, '' + print*, ' REMAPPING IC: INITIALIZING DELZ WITH HYDROSTATIC STATE ' + print*, '' + endif +#endif + +#ifdef HYDRO_DELZ_EXTRAP + if (is_master() .and. .not. hydrostatic) then + print*, '' + print*, ' REMAPPING IC: INITIALIZING DELZ WITH HYDROSTATIC STATE ABOVE INPUT MODEL TOP ' + print*, '' + endif +#endif + +#ifdef ZERO_W_EXTRAP + if (is_master() .and. .not. hydrostatic) then + print*, '' + print*, ' REMAPPING IC: INITIALIZING W TO ZERO ABOVE INPUT MODEL TOP ' + print*, '' + endif +#endif + + r_vir = rvgas/rdgas - 1. + rgrav = 1./grav + +!$OMP parallel do default(none) shared(is,ie,js,je,ps,ak_r) + do j=js,je + do i=is,ie + ps(i,j) = ak_r(1) + enddo + enddo + +! this OpenMP do-loop setup cannot work in it's current form.... +!$OMP parallel do default(none) shared(is,ie,js,je,km,ps,delp_r) + do j=js,je + do k=1,km + do i=is,ie + ps(i,j) = ps(i,j) + delp_r(i,j,k) + enddo + enddo + enddo + +! only one cell is needed + if ( square_domain ) then + call mpp_update_domains(ps, domain, whalo=1, ehalo=1, shalo=1, nhalo=1, complete=.true.) + else + call mpp_update_domains(ps, domain, complete=.true.) + endif + +! Compute virtual Temp +!$OMP parallel do default(none) shared(is,ie,js,je,km,pt_r,r_vir,q_r) + do k=1,km + do j=js,je + do i=is,ie + pt_r(i,j,k) = pt_r(i,j,k) * (1.+r_vir*q_r(i,j,k,1)) + enddo + enddo + enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,km,ak_r,bk_r,ps,kn,ak,bk,u0_r,u_r,u0,u,delp, & +!$OMP ntp,nq,hydrostatic,make_nh,w_r,w,delz_r,delp_r,delz, & +!$OMP pt_r,pt,v0_r,v_r,v0,v,q,q_r,qdiag,qdiag_r,is_ideal_case) & +!$OMP private(pe1, pe2, pv1, pv2) + do 1000 j=js,je+1 +!------ +! map u +!------ + do k=1,km+1 + do i=is,ie + pe1(i,k) = ak_r(k) + 0.5*bk_r(k)*(ps(i,j-1)+ps(i,j)) + enddo + enddo + + do k=1,kn+1 + do i=is,ie + pe2(i,k) = ak(k) + 0.5*bk(k)*(ps(i,j-1)+ps(i,j)) + enddo + enddo + + if (is_ideal_case) then + call remap_2d(km, pe1, u0_r(is:ie,j:j,1:km), & + kn, pe2, u0(is:ie,j:j,1:kn), & + is, ie, -1, kord) + endif + + call remap_2d(km, pe1, u_r(is:ie,j:j,1:km), & + kn, pe2, u(is:ie,j:j,1:kn), & + is, ie, -1, kord) + + if ( j /= (je+1) ) then + +!--------------- +! Hybrid sigma-p +!--------------- + do k=1,km+1 + do i=is,ie + pe1(i,k) = ak_r(k) + bk_r(k)*ps(i,j) + enddo + enddo + + do k=1,kn+1 + do i=is,ie + pe2(i,k) = ak(k) + bk(k)*ps(i,j) + enddo + enddo + +!------------- +! Compute delp +!------------- + do k=1,kn + do i=is,ie + delp(i,j,k) = pe2(i,k+1) - pe2(i,k) + enddo + enddo + +!---------------- +! Map constituents +!---------------- + if( nq /= 0 ) then + do iq=1,ntp + call remap_2d(km, pe1, q_r(is:ie,j:j,1:km,iq:iq), & + kn, pe2, q(is:ie,j:j,1:kn,iq:iq), & + is, ie, 0, kord) + enddo + do iq=ntp+1,nq + call remap_2d(km, pe1, qdiag_r(is:ie,j:j,1:km,iq:iq), & + kn, pe2, qdiag(is:ie,j:j,1:kn,iq:iq), & + is, ie, 0, kord) + enddo + endif + + if ( .not. hydrostatic .and. .not. make_nh) then +! Remap vertical wind: + call remap_2d(km, pe1, w_r(is:ie,j:j,1:km), & + kn, pe2, w(is:ie,j:j,1:kn), & + is, ie, -1, kord) + +#ifdef ZERO_W_EXTRAP + do k=1,kn + do i=is,ie + if (pe2(i,k) < pe1(i,1)) then + w(i,j,k) = 0. + endif + enddo + enddo +#endif + +#ifndef HYDRO_DELZ_REMAP +! Remap delz for hybrid sigma-p coordinate + do k=1,km + do i=is,ie + delz_r(i,j,k) = -delz_r(i,j,k)/delp_r(i,j,k) ! ="specific volume"/grav + enddo + enddo + call remap_2d(km, pe1, delz_r(is:ie,j:j,1:km), & + kn, pe2, delz(is:ie,j:j,1:kn), & + is, ie, 1, kord) + do k=1,kn + do i=is,ie + delz(i,j,k) = -delz(i,j,k)*delp(i,j,k) + enddo + enddo +#endif + endif + +! Geopotential conserving remap of virtual temperature: + do k=1,km+1 + do i=is,ie + pe1(i,k) = log(pe1(i,k)) + enddo + enddo + do k=1,kn+1 + do i=is,ie + pe2(i,k) = log(pe2(i,k)) + enddo + enddo + + call remap_2d(km, pe1, pt_r(is:ie,j:j,1:km), & + kn, pe2, pt(is:ie,j:j,1:kn), & + is, ie, 1, kord) + +#ifdef HYDRO_DELZ_REMAP + !initialize delz from the hydrostatic state + do k=1,kn + do i=is,ie + delz(i,j,k) = (rdgas*rgrav)*pt(i,j,k)*(pe2(i,k)-pe2(i,k+1)) + enddo + enddo +#endif +#ifdef HYDRO_DELZ_EXTRAP + !initialize delz from the hydrostatic state + do k=1,kn + do i=is,ie + if (pe2(i,k) < pe1(i,1)) then + delz(i,j,k) = (rdgas*rgrav)*pt(i,j,k)*(pe2(i,k)-pe2(i,k+1)) + endif + enddo + enddo +#endif +!------ +! map v +!------ + do k=1,km+1 + do i=is,ie+1 + pv1(i,k) = ak_r(k) + 0.5*bk_r(k)*(ps(i-1,j)+ps(i,j)) + enddo + enddo + do k=1,kn+1 + do i=is,ie+1 + pv2(i,k) = ak(k) + 0.5*bk(k)*(ps(i-1,j)+ps(i,j)) + enddo + enddo + + if (is_ideal_case) then + call remap_2d(km, pv1, v0_r(is:ie+1,j:j,1:km), & + kn, pv2, v0(is:ie+1,j:j,1:kn), & + is, ie+1, -1, kord) + endif + + call remap_2d(km, pv1, v_r(is:ie+1,j:j,1:km), & + kn, pv2, v(is:ie+1,j:j,1:kn), & + is, ie+1, -1, kord) + + endif !(j < je+1) +1000 continue + +!$OMP parallel do default(none) shared(is,ie,js,je,kn,pt,r_vir,q) + do k=1,kn + do j=js,je + do i=is,ie + pt(i,j,k) = pt(i,j,k) / (1.+r_vir*q(i,j,k,1)) + enddo + enddo + enddo + + end subroutine rst_remap + + !##################################################################### ! @@ -1415,14 +1710,14 @@ subroutine fv_io_register_restart_BCs(Atm) fname_ne, fname_sw, 'delz', var_bc=Atm%neststruct%delz_BC, mandatory=.false.) ! fname_ne, fname_sw, 'delz', Atm%delz, Atm%neststruct%delz_BC, mandatory=.false.) endif -#ifdef USE_COND + if (Atm%thermostruct%use_cond) then call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & fname_ne, fname_sw,'q_con', var_bc=Atm%neststruct%q_con_BC, mandatory=.false.) -#ifdef MOIST_CAPPA + endif + if (Atm%thermostruct%moist_kappa) then call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & fname_ne, fname_sw, 'cappa', var_bc=Atm%neststruct%cappa_BC, mandatory=.false.) -#endif -#endif + endif #endif if (Atm%flagstruct%is_ideal_case) then call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & diff --git a/tools/fv_nudge.F90 b/tools/fv_nudge.F90 index 3923cfe67..f68c81690 100644 --- a/tools/fv_nudge.F90 +++ b/tools/fv_nudge.F90 @@ -44,7 +44,7 @@ module fv_nwp_nudge_mod use fv_grid_utils_mod, only: latlon2xyz, vect_cross, normalize_vect use fv_diagnostics_mod,only: prt_maxmin, fv_time use tp_core_mod, only: copy_corners - use fv_mapz_mod, only: mappm + use fv_operators_mod, only: mappm use fv_mp_mod, only: mp_reduce_sum, mp_reduce_min, mp_reduce_max, is_master use fv_timing_mod, only: timing_on, timing_off @@ -99,19 +99,20 @@ module fv_nwp_nudge_mod ! Namelist variables: ! ---> h1g, add the list of input NCEP analysis data files, 2012-10-22 - character(len=128):: input_fname_list ="" ! a file lists the input NCEP analysis data - character(len=128):: analysis_file_first ="" ! the first NCEP analysis file to be used for nudging, - ! by default, the first file in the "input_fname_list" - character(len=128):: analysis_file_last="" ! the last NCEP analysis file to be used for nudging - ! by default, the last file in the "input_fname_list" + character(len=128):: input_fname_list ="" !< text file that lists the input NCEP analysis data + !< only enabled if set. + character(len=128):: analysis_file_first ="" !< the first NCEP analysis file to be used for nudging, + !< by default, the first file in the "input_fname_list" + character(len=128):: analysis_file_last="" !< the last NCEP analysis file to be used for nudging + !< by default, the last file in the "input_fname_list" - real :: P_relax = 30.E2 ! from P_relax upwards, nudging is reduced linearly - ! proportional to pfull/P_relax + real :: P_relax = 30.E2 !< from P_relax upwards, nudging is reduced linearly + !< proportional to pfull/P_relax (in Pa) - real :: P_norelax = 0.0 ! from P_norelax upwards, no nudging + real :: P_norelax = 0.0 !< from P_norelax (in Pa) upwards, no nudging ! <--- h1g, 2012-10-22 - character(len=128):: file_names(nfile_max) + character(len=128):: file_names(nfile_max) !< comma-separated list of input analysis files to nudge towards. character(len=128):: track_file_name integer :: nfile_total = 0 ! =5 for 1-day (if datasets are 6-hr apart) real :: p_wvp = 100.E2 ! cutoff level for specific humidity nudging @@ -177,6 +178,7 @@ module fv_nwp_nudge_mod ! track dataset: 'INPUT/tropical_cyclones.txt' + logical :: do_breed_TC = .true. ! Preserves older default behavior logical :: breed_srf_w = .false. real :: grid_size = 28.E3 real :: tau_vt_slp = 1200. @@ -232,7 +234,7 @@ module fv_nwp_nudge_mod tau_vt_rad, r_lo, r_hi, use_high_top, add_bg_wind, conserve_mom, conserve_hgt, & min_nobs, min_mslp, nudged_time, r_fac, r_min, r_inc, ibtrack, track_file_name, file_names, & input_fname_list, analysis_file_first, analysis_file_last, P_relax, P_norelax, & - nwp_nudge_int, time_varying_nwp, q_lat_varying, do_q_bias, do_t_bias, using_merra2, climate_nudging + nwp_nudge_int, time_varying_nwp, q_lat_varying, do_q_bias, do_t_bias, using_merra2, climate_nudging, do_breed_TC contains @@ -339,7 +341,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt mask(i,j) = 1. enddo enddo - if ( tc_mask ) call get_tc_mask(time, mask, agrid) + if ( do_breed_TC .and. tc_mask ) call get_tc_mask(time, mask, agrid) ! The following profile is suitable only for nwp purposes; if the analysis has a good representation ! of the strat-meso-sphere the profile for upper layers should be changed. @@ -655,7 +657,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt enddo else do j=js,je - do i=is,ie + do i=is,ie t_dt(i,j,k) = prof_t(k)*(t_obs(i,j,k)/(1.+zvir*q(i,j,k,1))-pt(i,j,k))*rdt enddo enddo @@ -786,8 +788,9 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt deallocate ( q_obs ) deallocate ( ps_obs ) - if ( breed_srf_w .and. nudge_winds ) & - call breed_srf_winds(Time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, ua, va, u_dt, v_dt, pt, q, nwat, zvir, gridstruct) + if ( do_breed_TC .and. breed_srf_w .and. nudge_winds ) then + call breed_srf_winds(Time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, ua, va, u_dt, v_dt, pt, q, nwat, zvir, gridstruct) + endif if ( nudge_debug) then call prt_maxmin('T increment=', t_dt, is, ie, js, je, 0, npz, dt) @@ -1003,7 +1006,7 @@ subroutine ps_bias_correction ( ps_dt, is, ie, js, je, isd, ied, jsd, jed, area bias = g0_sum(ps_dt, is, ie, js, je, 1, .true., isd, ied, jsd, jed, area) if ( abs(bias) < esl ) then - if(master .and. nudge_debug) write(*,*) 'Very small PS bias=', -bias, ' No bais adjustment' + if(master .and. nudge_debug) write(*,*) 'Very small PS bias=', -bias, ' No bias adjustment' return else if(master .and. nudge_debug) write(*,*) 'Significant PS bias=', -bias @@ -1529,9 +1532,10 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct enddo endif - if ( k_breed==0 ) k_breed = max(1, ks) - - call slp_obs_init + if (do_breed_tc) then + if ( k_breed==0 ) k_breed = max(1, ks) + call slp_obs_init + endif !----------------------------------------------------------- ! Initialize lat-lon to Cubed bi-linear interpolation coeff: @@ -2290,6 +2294,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del real(kind=R_GRID), pointer :: agrid(:,:,:) if ( forecast_mode ) return + if ( .not. do_breed_TC ) return agrid => gridstruct%agrid_64 area => gridstruct%area @@ -2645,6 +2650,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del !-------------------------- ! Update delp halo regions: +! (may need modification for nest/regional) !-------------------------- call mpp_update_domains(delp, domain_local, complete=.true.) @@ -3679,6 +3685,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) !$OMP parallel do default(none) shared(is,ie,js,je,kmd,q,qdt) do k=1,kmd + q(:,:,k) = 0.0 !init haloes to 0. do j=js,je do i=is,ie q(i,j,k) = qdt(i,j,k) diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90 index 34ece7132..882351a49 100644 --- a/tools/fv_restart.F90 +++ b/tools/fv_restart.F90 @@ -704,7 +704,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ Atm(n)%gridstruct, & Atm(n)%npx, Atm(n)%npy, npz, 1, & Atm(n)%gridstruct%grid_type, Atm(n)%domain, & - Atm(n)%gridstruct%bounded_domain, Atm(n)%flagstruct%c2l_ord, Atm(n)%bd) + Atm(n)%gridstruct%bounded_domain, 4, Atm(n)%bd) call prt_maxmin('UA ', Atm(n)%ua, isc, iec, jsc, jec, Atm(n)%ng, npz, 1.) call prt_maxmin('VA ', Atm(n)%va, isc, iec, jsc, jec, Atm(n)%ng, npz, 1.) @@ -741,7 +741,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ Atm(n)%gridstruct, & Atm(n)%npx, Atm(n)%npy, npz, 1, & Atm(n)%gridstruct%grid_type, Atm(n)%domain, & - Atm(n)%gridstruct%bounded_domain, Atm(n)%flagstruct%c2l_ord, Atm(n)%bd) + Atm(n)%gridstruct%bounded_domain, 4, Atm(n)%bd) do j=jsc,jec do i=isc,iec Atm(n)%u_srf(i,j) = Atm(n)%ua(i,j,npz) diff --git a/tools/fv_surf_map.F90 b/tools/fv_surf_map.F90 index 54c77fcc3..b5e86c309 100644 --- a/tools/fv_surf_map.F90 +++ b/tools/fv_surf_map.F90 @@ -54,33 +54,31 @@ module fv_surf_map_mod ! 5min ! nlon = 4320 ! nlat = 2160 -! surf_format: netcdf (default) -! binary +! surf_format: netcdf (only) ! New NASA SRTM30 data: SRTM30.nc ! nlon = 43200 ! nlat = 21600 - logical:: zs_filter = .true. - logical:: zero_ocean = .true. ! if true, no diffusive flux into water/ocean area - integer :: nlon = 21600 - integer :: nlat = 10800 - real:: cd4 = 0.15 ! Dimensionless coeff for del-4 diffusion (with FCT) - real:: cd2 = -1. ! Dimensionless coeff for del-2 diffusion (-1 gives resolution-determined value) - real:: peak_fac = 1.05 ! overshoot factor for the mountain peak - real:: max_slope = 0.15 ! max allowable terrain slope: 1 --> 45 deg - ! 0.15 for C768 or lower; 0.25 C1536; 0.3 for C3072 - integer:: n_del2_weak = 12 - integer:: n_del2_strong = -1 - integer:: n_del4 = -1 - - - character(len=128):: surf_file = "INPUT/topo1min.nc" - character(len=6) :: surf_format = 'netcdf' + logical:: zs_filter = .true. !< Perform filtering after creating topography. This option is not used for external_ic = .true. (that is controlled by fv_core_nml::full_zs_filter) + logical:: zero_ocean = .true. !< limits diffusive flux into water/ocean area + integer :: nlon + integer :: nlat + real:: cd4 = 0.15 !< Dimensionless coeff for del-4 diffusion (with FCT) + real:: cd2 = -1. !< Dimensionless coeff for del-2 diffusion (-1 gives resolution-determined value) + real:: peak_fac = 1.05 !< overshoot factor for the mountain peak + real:: max_slope = 0.15 !< max allowable terrain slope: 1 --> 45 deg + !< 0.15 for C768 or lower; 0.25 C1536; 0.3 for C3072 + integer:: n_del2_weak = 12 !< number of passes of weak del-2 diffusion (cd2 = 0.12*da_min) + integer:: n_del2_strong = -1 !< number of passes of strong del-2 diffusion (in cd2 or hard-coded to 0.16*da_min) + integer:: n_del4 = -1 !< number of passes of del-4 diffusion + + + character(len=128):: surf_file = "INPUT/topo1min.nc" !< source lat-lon file for on-line topography creation and filtering logical :: namelist_read = .false. real cos_grid character(len=3) :: grid_string = '' - namelist /surf_map_nml/ surf_file,surf_format,nlon,nlat, zero_ocean, zs_filter, & + namelist /surf_map_nml/ surf_file,zero_ocean, zs_filter, & cd4, peak_fac, max_slope, n_del2_weak, n_del2_strong, cd2, n_del4 ! real, allocatable:: zs_g(:,:), sgh_g(:,:), oro_g(:,:) @@ -181,7 +179,6 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ ! surface file must be in NetCDF format ! if ( file_exists(surf_file) ) then - if (surf_format == "netcdf") then status = nf_open (surf_file, NF_NOWRITE, ncid) if (status .ne. NF_NOERR) call handle_err(status) @@ -200,15 +197,12 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ if ( is_master() ) then if ( nlon==43200 ) then - write(*,*) 'Opening NASA datset file:', surf_file, surf_format, nlon, nlat + write(*,*) 'Opening NASA datset file:', surf_file, nlon, nlat else - write(*,*) 'Opening USGS datset file:', surf_file, surf_format, nlon, nlat + write(*,*) 'Opening USGS datset file:', surf_file, nlon, nlat endif endif - else - call error_mesg ( 'surfdrv','Raw IEEE data format no longer supported !!!', FATAL ) - endif else call error_mesg ( 'surfdrv','surface file '//trim(surf_file)//' not found !', FATAL ) endif @@ -238,94 +232,91 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ !------------------------------------- call timing_on('map_to_cubed') - if (surf_format == "netcdf") then ! Find latitude strips reading data - lats = pi/2. - latn = -pi/2. - do j=js,je - do i=is,ie - lats = min( lats, grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2), agrid(i,j,2) ) - latn = max( latn, grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2), agrid(i,j,2) ) - enddo + lats = pi/2. + latn = -pi/2. + do j=js,je + do i=is,ie + lats = min( lats, grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2), agrid(i,j,2) ) + latn = max( latn, grid(i,j,2), grid(i+1,j,2), grid(i,j+1,2), grid(i+1,j+1,2), agrid(i,j,2) ) enddo + enddo ! Enlarge the search zone: ! To account for the curvature of the coordinates: - !I have had trouble running c90 with 600 pes unless the search region is expanded - ! due to failures in finding latlon points in the source data. - !This sets a larger search region if the number of cells on a PE is too small. - !(Alternately you can just cold start the topography using a smaller number of PEs) - if (min(je-js+1,ie-is+1) < 15) then - delg = max( 0.4*(latn-lats), pi/real(npx_global-1), 2.*pi/real(nlat) ) - else - delg = max( 0.2*(latn-lats), pi/real(npx_global-1), 2.*pi/real(nlat) ) + !I have had trouble running c90 with 600 pes unless the search region is expanded + ! due to failures in finding latlon points in the source data. + !This sets a larger search region if the number of cells on a PE is too small. + !(Alternately you can just cold start the topography using a smaller number of PEs) + if (min(je-js+1,ie-is+1) < 15) then + delg = max( 0.4*(latn-lats), pi/real(npx_global-1), 2.*pi/real(nlat) ) + else + delg = max( 0.2*(latn-lats), pi/real(npx_global-1), 2.*pi/real(nlat) ) + endif + lats = max( -0.5*pi, lats - delg ) + latn = min( 0.5*pi, latn + delg ) + + jstart = 1 + do j=2,nlat + if ( lats < lat1(j) ) then + jstart = j-1 + exit endif - lats = max( -0.5*pi, lats - delg ) - latn = min( 0.5*pi, latn + delg ) - - jstart = 1 - do j=2,nlat - if ( lats < lat1(j) ) then - jstart = j-1 - exit - endif - enddo - jstart = max(jstart-1, 1) + enddo + jstart = max(jstart-1, 1) - jend = nlat - do j=2,nlat - if ( latn < lat1(j+1) ) then - jend = j+1 - exit - endif - enddo - jend = min(jend+1, nlat) + jend = nlat + do j=2,nlat + if ( latn < lat1(j+1) ) then + jend = j+1 + exit + endif + enddo + jend = min(jend+1, nlat) - jt = jend - jstart + 1 - igh = nlon/8 + nlon/(2*(npx_global-1)) + jt = jend - jstart + 1 + igh = nlon/8 + nlon/(2*(npx_global-1)) - if (is_master()) write(*,*) 'Terrain dataset =', nlon, 'jt=', jt - if (is_master()) write(*,*) 'igh (terrain ghosting)=', igh + if (is_master()) write(*,*) 'Terrain dataset =', nlon, 'jt=', jt + if (is_master()) write(*,*) 'igh (terrain ghosting)=', igh - status = nf_inq_varid (ncid, 'ftopo', ftopoid) - if (status .ne. NF_NOERR) call handle_err(status) - nread = 1; start = 1 - nread(1) = nlon - start(2) = jstart; nread(2) = jend - jstart + 1 + status = nf_inq_varid (ncid, 'ftopo', ftopoid) + if (status .ne. NF_NOERR) call handle_err(status) + nread = 1; start = 1 + nread(1) = nlon + start(2) = jstart; nread(2) = jend - jstart + 1 - allocate ( ft(-igh:nlon+igh,jt) ) - status = nf_get_vara_real (ncid, ftopoid, start, nread, ft(1:nlon,1:jt)) - if (status .ne. NF_NOERR) call handle_err(status) + allocate ( ft(-igh:nlon+igh,jt) ) + status = nf_get_vara_real (ncid, ftopoid, start, nread, ft(1:nlon,1:jt)) + if (status .ne. NF_NOERR) call handle_err(status) - do j=1,jt - do i=-igh,0 - ft(i,j) = ft(i+nlon,j) - enddo - do i=nlon+1,nlon+igh - ft(i,j) = ft(i-nlon,j) - enddo + do j=1,jt + do i=-igh,0 + ft(i,j) = ft(i+nlon,j) enddo - - status = nf_inq_varid (ncid, 'htopo', htopoid) - if (status .ne. NF_NOERR) call handle_err(status) - allocate ( zs(-igh:nlon+igh,jt) ) - status = nf_get_vara_real (ncid, htopoid, start, nread, zs(1:nlon,1:jt)) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) -! Ghost Data - do j=1,jt - do i=-igh,0 - zs(i,j) = zs(i+nlon,j) - enddo - do i=nlon+1,nlon+igh - zs(i,j) = zs(i-nlon,j) - enddo + do i=nlon+1,nlon+igh + ft(i,j) = ft(i-nlon,j) enddo + enddo - endif + status = nf_inq_varid (ncid, 'htopo', htopoid) + if (status .ne. NF_NOERR) call handle_err(status) + allocate ( zs(-igh:nlon+igh,jt) ) + status = nf_get_vara_real (ncid, htopoid, start, nread, zs(1:nlon,1:jt)) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_close (ncid) + if (status .ne. NF_NOERR) call handle_err(status) + ! Ghost Data + do j=1,jt + do i=-igh,0 + zs(i,j) = zs(i+nlon,j) + enddo + do i=nlon+1,nlon+igh + zs(i,j) = zs(i-nlon,j) + enddo + enddo ! special SP treatment: ! if ( jstart == 1 ) then diff --git a/tools/fv_treat_da_inc.F90 b/tools/fv_treat_da_inc.F90 index fe0fb4fec..2eb3eee18 100644 --- a/tools/fv_treat_da_inc.F90 +++ b/tools/fv_treat_da_inc.F90 @@ -350,7 +350,7 @@ subroutine read_da_inc(Atm, fv_domain) !rab Atm%gridstruct, Atm%flagstruct%npx, Atm%flagstruct%npy, & !rab Atm%flagstruct%npz, 1, Atm%gridstruct%grid_type, & !rab fv_domain, Atm%gridstruct%nested, & -!rab Atm%flagstruct%c2l_ord, Atm%bd) +!rab Atm%bd) !------ winds clean up ------ deallocate ( pt_c, pt_d, ud_inc, vd_inc ) diff --git a/tools/test_cases.F90 b/tools/test_cases.F90 index 907186b40..37da15c42 100644 --- a/tools/test_cases.F90 +++ b/tools/test_cases.F90 @@ -31,7 +31,7 @@ module test_cases_mod use fv_mp_mod, only: is_master, & domain_decomp, fill_corners, XDir, YDir, & mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather - use fv_grid_utils_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere, & + use fv_grid_utils_mod, only: great_circle_dist, mid_pt_sphere, & ptop_min, inner_prod, get_latlon_vector, get_unit_vect2, & g_sum, latlon2xyz, cart_to_latlon, make_eta_level, f_p, project_sphere_v use fv_surf_map_mod, only: surfdrv @@ -4606,7 +4606,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, real :: pe_v(bd%is:bd%ie+1,npz+1,bd%js:bd%je) real :: ps_u(bd%is:bd%ie,bd%js:bd%je+1) real :: ps_v(bd%is:bd%ie+1,bd%js:bd%je) - + real(kind=R_GRID) :: p1(2), p2(2), p3(2), p4(2) real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3) integer :: z @@ -5025,7 +5025,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, do k=1,npz zm = 0.5*(ze1(k)+ze1(k+1)) - utmp = us0*tanh(zm/3.E3) - us0*0.5 ! subtract off mean wind + utmp = Umean*tanh(zm/3.E3) - Umean*0.5 ! subtract off mean wind do j=js,je+1 do i=is,ie u(i,j,k) = utmp @@ -5039,10 +5039,10 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ! *** Add Initial perturbation *** if (bubble_do) then - pturb = 2. - r0 = 10.e3 + pturb = dt_amp ! 2. + r0 = dt_rad ! 10.e3 zc = 1.4e3 ! center of bubble from surface - icenter = (npx-1)/3 + 1 + icenter = (npx-1)/2 + 1 jcenter = (npy-1)/2 + 1 do k=1, npz zm = 0.5*(ze1(k)+ze1(k+1)) @@ -5060,7 +5060,6 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, !--------------------------- ! Doubly periodic SuperCell, quarter circle hodograph ! M. Toy, Apr 2013, MWR - pturb = 2.5 zvir = rvgas/rdgas - 1. p00 = 1000.E2 ps(:,:) = p00 @@ -5100,18 +5099,22 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, do i=is,ie pt(i,j,k) = ts1(k) q(i,j,k,1) = qs1(k) - delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)) + !delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)) enddo enddo enddo + call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & + pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & + moist_phys, .false., nwat, domain, flagstruct%adiabatic, .true.) + + ze1(npz+1) = 0. do k=npz,1,-1 ze1(k) = ze1(k+1) - delz(is,js,k) enddo ! Quarter-circle hodograph (Harris approximation) - us0 = 30. do k=1,npz zm = 0.5*(ze1(k)+ze1(k+1)) if ( zm .le. 2.e3 ) then @@ -5145,10 +5148,10 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ! *** Add Initial perturbation *** if (bubble_do) then - pturb = 2. - r0 = 10.e3 + pturb = dt_amp ! 2. + r0 = dt_rad ! 10.e3 zc = 1.4e3 ! center of bubble from surface - icenter = (npx-1)/3 + 1 + icenter = (npx-1)/2 + 1 jcenter = (npy-1)/2 + 1 do k=1, npz zm = 0.5*(ze1(k)+ze1(k+1)) @@ -5261,7 +5264,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, enddo enddo - else + else if (bubble_do) then ! *** Add Initial perturbation (Ellipse) *** pturb = dt_amp @@ -5290,9 +5293,9 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ! adapted from case 55 - Joseph M. !--------------------------------------------------------- - !p0(1) = (0.) * pi / 180. + !p0(1) = (0.) * pi / 180. p0(1) = (-50.) * pi / 180. !weird physics IC (tsc) when this is around 0 - p0(2) = (flagstruct%deglat) * pi / 180. + p0(2) = (flagstruct%deglat) * pi / 180. !original !dp = 1115. @@ -6525,7 +6528,7 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp) write(*,*) 'Computing sounding for super-cell test' endif - call qs_init + !call qs_init dz0 = 50. zs(ns) = 0. @@ -6570,8 +6573,10 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp) ! if ( (is_master()) ) write(*,*) k, temp1, rh(k) if ( pk(k) > 0. ) then pp(k) = exp(log(pk(k))/kappa) - qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k))) + !qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k))) !qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k))) + qs(k) = 380./pp(k)*exp(17.27*(temp1-273.)/(temp1-36.)) + qs(k) = min( qv0, rh(k)*qs(k) ) !if ( (is_master()) ) write(*,*) 0.001*pp(k), qs(k) else !if ( (is_master()) ) write(*,*) n, k, pk(k) @@ -6597,12 +6602,15 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp) goto 555 endif enddo - endif + endif + 555 continue do k=1,km tp(k) = tp(k)*pk1(k) ! temperature tp(k) = max(Tmin, tp(k)) + if (is_master()) print*, k, exp(cp_air/rdgas*log(pk1(k))), tp(k), qp(k) + enddo end subroutine SuperCell_Sounding @@ -6717,6 +6725,7 @@ subroutine SuperCell_Sounding_Marine(km, ps, pk1, tp, qp) do k=1,km tp(k) = tp(k)*pk1(k) ! temperature tp(k) = max(Tmin, tp(k)) + if (is_master()) print*, k, exp(cp_air/rdgas*log(pk1(k))), tp(k), qp(k) enddo end subroutine SuperCell_Sounding_Marine @@ -6801,19 +6810,9 @@ subroutine Marine_Sounding(km, ps, pk1, tp, qp) ! if ( (is_master()) ) write(*,*) k, temp1, rh(k) if ( pk(k) > 0. ) then pp(k) = exp(log(pk(k))/kappa) -#ifdef SUPER_K +! qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k))) qs(k) = 380./pp(k)*exp(17.27*(temp1-273.)/(temp1-36.)) qs(k) = min( qv0, rh(k)*qs(k) ) - !if ( (is_master()) ) write(*,*) 0.01*pp(k), qs(k) -#else - -#ifdef USE_MIXED_TABLE - qs(k) = min(qv0, rh(k)*mqs(temp1, pp(k), qs(k))) -#else - qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k))) -#endif - -#endif else !if ( (is_master()) ) write(*,*) n, k, pk(k) call mpp_error(FATAL, 'Super-Cell case: pk < 0') @@ -6844,6 +6843,7 @@ subroutine Marine_Sounding(km, ps, pk1, tp, qp) do k=1,km tp(k) = tp(k)*pk1(k) ! temperature tp(k) = max(Tmin, tp(k)) + if (is_master()) print*, k, exp(cp_air/rdgas*log(pk1(k))), tp(k), qp(k) enddo end subroutine Marine_Sounding