From 2fcff2eb0e1411941cfe847463f7d55676f72921 Mon Sep 17 00:00:00 2001
From: laurenchilutti <60401591+laurenchilutti@users.noreply.github.com>
Date: Thu, 7 Apr 2022 17:39:43 -0400
Subject: [PATCH] Release 042022 (#184)
* Merge of updates from GFDL Weather and Climate Dynamics Division (202204):
*add license header to missing files and fix typo in header
*updates needed for fv3_gfsphysics to have access to bounded_domain
*remove obsoleted driver/SHiELD files
*updating to fix bug where long_name and units attributes were not being captured in the RESTARTS
*remove unused function fv_diagnostics::max_vorticity_hy1
*remove avec timer remnants
*adding ability to specify prefix and directory when reading and writing restarts
*remove old style namelist read in favor of read from internal character variable
*Added option for a mean wind
*The planetary radius and rotation rate are now re-scalable by a namelist parameter (small_earth_scale) instead of using exclusively the hard-coded FMS constant.
*fv_mapz: Cleanup and added helpful annotations to avoid getting lost so easily
* remove duplicate code and fix lstatus on all grids depending on gfs_data and gfs_data.tile1
* New idealized tests
*Makes the non-hydrostatic restart variables optional for reads to allow hydrostatic ICs
*Fix the hydrostatic TE remapping; Add GMAO cubic for TE remapping, which is used if kord_tm=0 and remap_te=.true.
*Add a TE remapping option (kord_tm=0)
*Addressing GNU Warnings
*Add the L75 vertical config from HAFS
* clean up fms_mp_mod and remove mp_bcst
---
CODE_STYLE.md | 2 +-
GFDL_tools/fv_ada_nudge.F90 | 55 +-
GFDL_tools/fv_climate_nudge.F90 | 18 +-
GFDL_tools/fv_cmip_diag.F90 | 2 +-
GFDL_tools/read_climate_nudge_data.F90 | 2 +-
README.md | 2 +-
RELEASE.md | 24 +
driver/GFDL/atmosphere.F90 | 2 +-
driver/SHiELD/atmosphere.F90 | 314 +-
driver/solo/atmosphere.F90 | 608 +++
driver/solo/fv_phys.F90 | 2625 +++++++++++++
driver/solo/hswf.F90 | 232 ++
driver/solo/monin_obukhov_drag.F90 | 668 ++++
driver/solo/ocean_rough.F90 | 225 ++
driver/solo/qs_tables.F90 | 135 +
model/a2b_edge.F90 | 3 +-
model/boundary.F90 | 4 +-
.../cld_eff_rad.F90 | 175 +-
model/dyn_core.F90 | 64 +-
model/{fv_cmp.F90 => fast_sat_adj.F90} | 440 ++-
model/fv_arrays.F90 | 115 +-
model/fv_control.F90 | 53 +-
model/fv_dynamics.F90 | 300 +-
model/fv_fill.F90 | 3 +-
model/fv_grid_utils.F90 | 87 +-
model/fv_mapz.F90 | 2974 ++++++++++-----
model/fv_nesting.F90 | 37 +-
model/fv_regional_bc.F90 | 67 +-
model/fv_sg.F90 | 11 +-
model/fv_tracer2d.F90 | 3 +-
model/fv_update_phys.F90 | 11 +-
.../gfdl_cld_mp.F90 | 3334 +++++++++--------
model/gfdl_mp.F90 | 2880 +++++++++-----
model/nh_core.F90 | 3 +-
model/nh_utils.F90 | 20 +-
model/sw_core.F90 | 31 +-
model/tp_core.F90 | 3 +-
tools/coarse_grained_diagnostics.F90 | 843 ++++-
tools/coarse_grained_restart_files.F90 | 95 +-
tools/coarse_graining.F90 | 2658 ++++++++++++-
tools/external_ic.F90 | 67 +-
tools/external_sst.F90 | 3 +-
tools/fv_diag_column.F90 | 619 +++
tools/fv_diagnostics.F90 | 591 ++-
tools/fv_diagnostics.h | 13 +-
tools/fv_eta.F90 | 53 +-
tools/fv_eta.h | 386 +-
tools/fv_grid_tools.F90 | 67 +-
tools/fv_iau_mod.F90 | 521 +++
tools/fv_io.F90 | 477 ++-
tools/fv_mp_mod.F90 | 369 +-
tools/fv_nggps_diag.F90 | 100 +-
tools/fv_nudge.F90 | 36 +-
tools/fv_restart.F90 | 69 +-
tools/fv_surf_map.F90 | 5 +-
tools/fv_timing.F90 | 3 +-
tools/fv_treat_da_inc.F90 | 96 +-
tools/init_hydro.F90 | 186 +-
tools/rad_ref.F90 | 235 ++
tools/sim_nc_mod.F90 | 14 +-
tools/sorted_index.F90 | 3 +-
tools/statistics.F90 | 266 ++
tools/test_cases.F90 | 1196 ++++--
63 files changed, 18799 insertions(+), 5704 deletions(-)
create mode 100644 driver/solo/atmosphere.F90
create mode 100644 driver/solo/fv_phys.F90
create mode 100644 driver/solo/hswf.F90
create mode 100644 driver/solo/monin_obukhov_drag.F90
create mode 100644 driver/solo/ocean_rough.F90
create mode 100644 driver/solo/qs_tables.F90
rename driver/SHiELD/cloud_diagnosis.F90 => model/cld_eff_rad.F90 (78%)
rename model/{fv_cmp.F90 => fast_sat_adj.F90} (76%)
rename driver/SHiELD/gfdl_cloud_microphys.F90 => model/gfdl_cld_mp.F90 (56%)
create mode 100644 tools/fv_diag_column.F90
create mode 100644 tools/fv_iau_mod.F90
create mode 100644 tools/rad_ref.F90
create mode 100644 tools/statistics.F90
diff --git a/CODE_STYLE.md b/CODE_STYLE.md
index 733885f36..74013dbdb 100644
--- a/CODE_STYLE.md
+++ b/CODE_STYLE.md
@@ -70,7 +70,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
diff --git a/GFDL_tools/fv_ada_nudge.F90 b/GFDL_tools/fv_ada_nudge.F90
index b660b9a75..49b6ed6cd 100644
--- a/GFDL_tools/fv_ada_nudge.F90
+++ b/GFDL_tools/fv_ada_nudge.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -262,7 +262,7 @@ module fv_ada_nudge_mod
contains
- subroutine fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, zvir, ptop, &
+ subroutine fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, zvir, &
ak, bk, ts, ps, delp, ua, va, pt, nwat, q, phis, gridstruct, &
bd, domain )
@@ -271,7 +271,7 @@ subroutine fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt
integer, intent(in):: npz ! vertical dimension
integer, intent(in):: nwat
real, intent(in):: dt
- real, intent(in):: zvir, ptop
+ real, intent(in):: zvir
type(domain2d), intent(INOUT), target :: domain
type(fv_grid_bounds_type), intent(IN) :: bd
real, intent(in ), dimension(npz+1):: ak, bk
@@ -435,7 +435,7 @@ subroutine fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt
call get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_obs, v_obs, t_obs, q_obs, &
- phis, gz_int, ua, va, u_dt, v_dt, npx, npy, npz, factor, mask, ptop, bd, gridstruct, domain)
+ phis, gz_int, ua, va, u_dt, v_dt, npx, npy, npz, factor, mask, bd, gridstruct, domain)
! *t_obs* is virtual temperature
#ifdef ENABLE_ADA ! snz
@@ -1269,10 +1269,10 @@ end subroutine compute_slp
subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_obs, v_obs, t_obs, q_obs, &
- phis, gz_int, ua, va, u_dt, v_dt, npx, npy, npz, factor, mask, ptop, bd, gridstruct, domain)
+ phis, gz_int, ua, va, u_dt, v_dt, npx, npy, npz, factor, mask, bd, gridstruct, domain)
type(time_type), intent(in):: Time
integer, intent(in):: npz, nwat, npx, npy
- real, intent(in):: zvir, ptop
+ real, intent(in):: zvir
real, intent(in):: dt, factor
real, intent(in), dimension(npz+1):: ak, bk
type(fv_grid_bounds_type), intent(IN) :: bd
@@ -1423,26 +1423,26 @@ subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_
if ( nudge_winds ) then
call remap_uv(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,1), u_dat(:,:,:,1), v_dat(:,:,:,1), ptop, bd )
+ km, ps_dat(is:ie,js:je,1), u_dat(:,:,:,1), v_dat(:,:,:,1), bd )
u_obs(:,:,:) = alpha*ut(:,:,:)
v_obs(:,:,:) = alpha*vt(:,:,:)
call remap_uv(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,2), u_dat(:,:,:,2), v_dat(:,:,:,2), ptop, bd )
+ km, ps_dat(is:ie,js:je,2), u_dat(:,:,:,2), v_dat(:,:,:,2), bd )
u_obs(:,:,:) = u_obs(:,:,:) + beta*ut(:,:,:)
v_obs(:,:,:) = v_obs(:,:,:) + beta*vt(:,:,:)
endif
call remap_tq(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,1), t_dat(:,:,:,1), q_dat(:,:,:,1), zvir, ptop, bd)
+ km, ps_dat(is:ie,js:je,1), t_dat(:,:,:,1), q_dat(:,:,:,1), zvir, bd)
t_obs(:,:,:) = alpha*ut(:,:,:)
q_obs(:,:,:) = alpha*vt(:,:,:)
call remap_tq(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,2), t_dat(:,:,:,2), q_dat(:,:,:,2), zvir, ptop, bd)
+ km, ps_dat(is:ie,js:je,2), t_dat(:,:,:,2), q_dat(:,:,:,2), zvir, bd)
t_obs(:,:,:) = t_obs(:,:,:) + beta*ut(:,:,:)
q_obs(:,:,:) = q_obs(:,:,:) + beta*vt(:,:,:)
@@ -2309,9 +2309,9 @@ end subroutine get_int_hght
subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
- kmd, ps0, ta, qa, zvir, ptop, bd)
+ kmd, ps0, ta, qa, zvir, bd)
integer, intent(in):: npz, kmd
- real, intent(in):: zvir, ptop
+ real, intent(in):: zvir
real, intent(in):: ak(npz+1), bk(npz+1)
type(fv_grid_bounds_type), intent(IN) :: bd
real, intent(in), dimension(bd%is:bd%ie,bd%js:bd%je):: ps0
@@ -2373,7 +2373,7 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
qp(i,k) = qa(i,j,k)
enddo
enddo
- call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_data, ptop)
+ call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_data)
do k=1,npz
do i=is,ie
q(i,j,k) = qn1(i,k)
@@ -2388,7 +2388,7 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
tp(i,k) = ta(i,j,k)
enddo
enddo
- call mappm(kmd, pn0, tp, npz, pn1, qn1, is,ie, 1, kord_data, ptop)
+ call mappm(kmd, pn0, tp, npz, pn1, qn1, is,ie, 1, kord_data)
do k=1,npz
do i=is,ie
@@ -2401,9 +2401,8 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
end subroutine remap_tq
- subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, ptop, bd)
+ subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, bd)
integer, intent(in):: npz
- real, intent(IN):: ptop
real, intent(in):: ak(npz+1), bk(npz+1)
type(fv_grid_bounds_type), intent(IN) :: bd
real, intent(inout):: ps(bd%is:bd%ie,bd%js:bd%je)
@@ -2460,7 +2459,7 @@ subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, ptop, bd)
qt(i,k) = u0(i,j,k)
enddo
enddo
- call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data, ptop)
+ call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data)
do k=1,npz
do i=is,ie
u(i,j,k) = qn1(i,k)
@@ -2474,7 +2473,7 @@ subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, ptop, bd)
qt(i,k) = v0(i,j,k)
enddo
enddo
- call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data, ptop)
+ call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data)
do k=1,npz
do i=is,ie
v(i,j,k) = qn1(i,k)
@@ -2516,14 +2515,34 @@ subroutine fv_ada_nudge_end
call fv_io_register_axis(ada_driver_restart, numx=1, numy=1, numz=1, zsize=(/size(Atm_var%u_adj,3)/))
call register_restart_field(ada_driver_restart, &
& "u_adj", Atm_var%u_adj(:,:,:), dim_names_4d)
+ call register_variable_attribute(ada_driver_restart, &
+ & "u_adj", "long_name", "u_adj", str_len=len("u_adj"))
+ call register_variable_attribute(ada_driver_restart, &
+ & "u_adj", "units", "none", str_len=len("none"))
call register_restart_field(ada_driver_restart, &
& "v_adj", Atm_var%v_adj(:,:,:), dim_names_4d)
+ call register_variable_attribute(ada_driver_restart, &
+ & "v_adj", "long_name", "v_adj", str_len=len("v_adj"))
+ call register_variable_attribute(ada_driver_restart, &
+ & "v_adj", "units", "none", str_len=len("none"))
call register_restart_field(ada_driver_restart, &
& "t_adj", Atm_var%t_adj(:,:,:), dim_names_4d)
+ call register_variable_attribute(ada_driver_restart, &
+ & "t_adj", "long_name", "t_adj", str_len=len("t_adj"))
+ call register_variable_attribute(ada_driver_restart, &
+ & "t_adj", "units", "none", str_len=len("none"))
call register_restart_field(ada_driver_restart, &
& "q_adj", Atm_var%q_adj(:,:,:), dim_names_4d)
+ call register_variable_attribute(ada_driver_restart, &
+ & "q_adj", "long_name", "q_adj", str_len=len("q_adj"))
+ call register_variable_attribute(ada_driver_restart, &
+ & "q_adj", "units", "none", str_len=len("none"))
call register_restart_field(ada_driver_restart, &
& "ps_adj", Atm_var%ps_adj(:,:), dim_names_4d)
+ call register_variable_attribute(ada_driver_restart, &
+ & "ps_adj", "long_name", "ps_adj", str_len=len("ps_adj"))
+ call register_variable_attribute(ada_driver_restart, &
+ & "ps_adj", "units", "none", str_len=len("none"))
call write_restart(ada_driver_restart)
call close_file(ada_driver_restart)
endif
diff --git a/GFDL_tools/fv_climate_nudge.F90 b/GFDL_tools/fv_climate_nudge.F90
index b392bef2e..41cfd1134 100644
--- a/GFDL_tools/fv_climate_nudge.F90
+++ b/GFDL_tools/fv_climate_nudge.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -262,12 +262,11 @@ end subroutine fv_climate_nudge_init
!###################################################################################
subroutine fv_climate_nudge (Time, dt, is, ie, js, je, npz, pfull, &
- lon, lat, phis, ptop, ak, bk, &
+ lon, lat, phis, ak, bk, &
ps, u, v, t, q, psdt, udt, vdt, tdt, qdt )
type(time_type), intent(in) :: Time
real, intent(in) :: dt
integer, intent(in) :: is, ie, js, je, npz
-real, intent(IN) :: ptop
real, intent(in) :: phis(is:ie,js:je)
real, intent(in) :: lon (is:ie,js:je)
@@ -439,15 +438,15 @@ subroutine fv_climate_nudge (Time, dt, is, ie, js, je, npz, pfull, &
enddo
if (get_wind) then
- call remap_3d (is, ie, js, je, nlev_obs, npz, phaf_obs, u_obs, phaf, State(n)%u, -1, ptop)
- call remap_3d (is, ie, js, je, nlev_obs, npz, phaf_obs, v_obs, phaf, State(n)%v, -1, ptop)
+ call remap_3d (is, ie, js, je, nlev_obs, npz, phaf_obs, u_obs, phaf, State(n)%u, -1)
+ call remap_3d (is, ie, js, je, nlev_obs, npz, phaf_obs, v_obs, phaf, State(n)%v, -1)
endif
if (get_qhum .or. get_temp) then
- call remap_3d (is, ie, js, je, nlev_obs, npz, phaf_obs, q_obs, phaf, State(n)%q(:,:,:,1), 0, ptop)
+ call remap_3d (is, ie, js, je, nlev_obs, npz, phaf_obs, q_obs, phaf, State(n)%q(:,:,:,1), 0)
endif
if (get_temp) then
! use logp
- call remap_3d (is, ie, js, je, nlev_obs, npz, lphaf_obs, t_obs, lphaf, State(n)%t, 1, ptop)
+ call remap_3d (is, ie, js, je, nlev_obs, npz, lphaf_obs, t_obs, lphaf, State(n)%t, 1)
State(n)%t = State(n)%t/(1.+ZVIR*State(n)%q(:,:,:,1)) ! virtual effect
endif
@@ -1023,7 +1022,7 @@ end subroutine remap_ps
!---------------------------------------------------
subroutine remap_3d( is, ie, js, je, km, npz, &
- pe0, qn0, pe1, qn1, n, ptop )
+ pe0, qn0, pe1, qn1, n )
!--------
! Input:
@@ -1035,7 +1034,6 @@ subroutine remap_3d( is, ie, js, je, km, npz, &
real, intent(in):: qn0(is:ie,js:je,km) ! scalar quantity on input data levels
real, intent(in):: pe1(is:ie,js:je,npz+1) ! pressure at layer interfaces for model data
integer, intent(in):: n ! -1 wind; 0 sphum; +1 ptemp
- real, intent(IN):: ptop
!--------
! Output:
@@ -1046,7 +1044,7 @@ subroutine remap_3d( is, ie, js, je, km, npz, &
integer :: i, j, k
do j = js,je
- call mappm(km, pe0(is:ie,j,:), qn0(is:ie,j,:), npz, pe1(is:ie,j,:), qn1(is:ie,j,:), is,ie, n, 8, ptop)
+ call mappm(km, pe0(is:ie,j,:), qn0(is:ie,j,:), npz, pe1(is:ie,j,:), qn1(is:ie,j,:), is,ie, n, 8)
enddo
end subroutine remap_3d
diff --git a/GFDL_tools/fv_cmip_diag.F90 b/GFDL_tools/fv_cmip_diag.F90
index 0ef4e558a..c7fed4de0 100644
--- a/GFDL_tools/fv_cmip_diag.F90
+++ b/GFDL_tools/fv_cmip_diag.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
diff --git a/GFDL_tools/read_climate_nudge_data.F90 b/GFDL_tools/read_climate_nudge_data.F90
index 05b40f6de..870811de1 100644
--- a/GFDL_tools/read_climate_nudge_data.F90
+++ b/GFDL_tools/read_climate_nudge_data.F90
@@ -11,7 +11,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
diff --git a/README.md b/README.md
index 8331d92e6..7292e7fe5 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,6 @@
# GFDL_atmos_cubed_sphere
-The source contained herein reflects the 202107 release of the Finite Volume Cubed-Sphere Dynamical Core (FV3) from GFDL
+The source contained herein reflects the 202204 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 c6a71294b..0794ce729 100644
--- a/RELEASE.md
+++ b/RELEASE.md
@@ -1,3 +1,27 @@
+# RELEASE NOTES for FV3 202204: Summary
+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
+
+This release includes the following:
+- Release of stand-alone solo_core functionality with simple physics.
+- Updated GFDL Microphysics, used for real-time 2021 C-SHiELD and T-SHiELD. (L Zhou)
+- Merges numerous updates from dev/emc.
+- Leverage DA functionality from UFS with additional changes (M Tong).
+- Updates to use the latest FMS release, including fms2_io.
+- Adds license header to missing files and fixes typo in header.
+- Fixes a bug where long_name and units attributes were not being captured in restart files.
+- Adds the ability to specify prefix and directory when reading and writing restarts.
+- The planetary radius and rotation rate are now re-scalable by a namelist parameter (small_earth_scale) instead of using exclusively the hard-coded FMS constant.
+- Removes obsolete driver/SHiELD files.
+- Removes unused function fv_diagnostics::max_vorticity_hy1.
+- Removes avec timer remnants.
+- Removes old style namelist read in favor of read from internal character variable.
+- Adds option for a mean wind.
+- Addresses GNU warnings.
+
# RELEASE NOTES for FV3 202107: Summary
diff --git a/driver/GFDL/atmosphere.F90 b/driver/GFDL/atmosphere.F90
index ccab7590a..756a927f0 100644
--- a/driver/GFDL/atmosphere.F90
+++ b/driver/GFDL/atmosphere.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
diff --git a/driver/SHiELD/atmosphere.F90 b/driver/SHiELD/atmosphere.F90
index 869bf2cfe..0585c959f 100644
--- a/driver/SHiELD/atmosphere.F90
+++ b/driver/SHiELD/atmosphere.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module atmosphere_mod
#include
@@ -53,6 +54,8 @@ module atmosphere_mod
use tracer_manager_mod, only: get_tracer_index, get_number_tracers, &
NO_TRACER, get_tracer_names
use IPD_typedefs, only: IPD_data_type, kind_phys
+use data_override_mod, only: data_override_init
+use fv_iau_mod, only: IAU_external_data_type
!-----------------
! FV core modules:
@@ -61,6 +64,7 @@ module atmosphere_mod
use fv_control_mod, only: fv_control_init, fv_end, ngrids
use fv_eta_mod, only: get_eta_level
use fv_fill_mod, only: fill_gfs
+use dyn_core_mod, only: del2_cubed
use fv_dynamics_mod, only: fv_dynamics
use fv_nesting_mod, only: twoway_nesting
use fv_diagnostics_mod, only: fv_diag_init, fv_diag, fv_time, prt_maxmin, prt_height
@@ -75,14 +79,15 @@ module atmosphere_mod
use fv_regional_mod, only: start_regional_restart, read_new_bc_data
use fv_regional_mod, only: a_step, p_step
use fv_regional_mod, only: current_time_in_seconds
+use fv_grid_utils_mod, only: g_sum
use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain
use gfdl_mp_mod, only: gfdl_mp_init, gfdl_mp_end
-use cloud_diagnosis_mod,only: cloud_diagnosis_init
+use cld_eff_rad_mod, only: cld_eff_rad_init
+use diag_manager_mod, only: send_data
use coarse_graining_mod, only: coarse_graining_init
use coarse_grained_diagnostics_mod, only: fv_coarse_diag_init, fv_coarse_diag
use coarse_grained_restart_files_mod, only: fv_coarse_restart_init
-use diag_manager_mod, only: send_data
implicit none
private
@@ -98,13 +103,16 @@ module atmosphere_mod
atmosphere_diag_axes, atmosphere_etalvls, &
atmosphere_hgt, atmosphere_scalar_field_halo, &
!rab atmosphere_tracer_postinit, &
-! atmosphere_diss_est, &
+ atmosphere_diss_est, & ! dissipation estimate for SKEB
atmosphere_nggps_diag, &
get_bottom_mass, get_bottom_wind, &
- get_stock_pe, set_atmosphere_pelist
+ get_stock_pe, set_atmosphere_pelist, &
+ atmosphere_coarse_diag_axes
!--- physics/radiation data exchange routines
public :: atmos_phys_driver_statein
+public :: atmosphere_coarse_graining_parameters
+public :: atmosphere_coarsening_strategy
!-----------------------------------------------------------------------
! version number of this module
@@ -114,7 +122,7 @@ module atmosphere_mod
!---- private data ----
type (time_type) :: Time_step_atmos
- public Atm
+ public Atm, mygrid
!These are convenience variables for local use only, and are set to values in Atm%
real :: dt_atmos
@@ -142,7 +150,7 @@ module atmosphere_mod
!---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys
real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt, qv_dt
- real, allocatable :: pref(:,:), dum1d(:)
+ real, allocatable :: pref(:,:), dum1d(:), ps_dt(:,:)
logical :: first_diag = .true.
@@ -150,9 +158,10 @@ module atmosphere_mod
- subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area)
+ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data)
type (time_type), intent(in) :: Time_init, Time, Time_step
type(grid_box_type), intent(inout) :: Grid_box
+ type(iau_external_data_type), intent(out) :: IAU_Data
real(kind=kind_phys), pointer, dimension(:,:), intent(inout) :: area
!--- local variables ---
integer :: i, n
@@ -268,16 +277,16 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area)
allocate( u_dt(isd:ied,jsd:jed,npz), &
v_dt(isd:ied,jsd:jed,npz), &
t_dt(isc:iec,jsc:jec,npz), &
- qv_dt(isc:iec,jsc:jec,npz) )
+ qv_dt(isc:iec,jsc:jec,npz), &
+ ps_dt(isd:ied,jsd:jed) )
+
!--- allocate pref
allocate(pref(npz+1,2), dum1d(npz+1))
- if (Atm(mygrid)%flagstruct%do_inline_mp) then
- call gfdl_mp_init(mpp_pe(), mpp_root_pe(), nlunit, input_nml_file, stdlog(), fn_nml)
- call cloud_diagnosis_init(nlunit, input_nml_file, stdlog(), fn_nml)
- endif
-
- call fv_restart(Atm(mygrid)%domain, Atm, dt_atmos, seconds, days, cold_start, Atm(mygrid)%gridstruct%grid_type, mygrid)
+ call gfdl_mp_init(input_nml_file, stdlog())
+ call cld_eff_rad_init(input_nml_file, stdlog())
+ call fv_restart(Atm(mygrid)%domain, Atm, dt_atmos, seconds, days, cold_start, &
+ Atm(mygrid)%gridstruct%grid_type, mygrid)
fv_time = Time
@@ -348,10 +357,15 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area)
#ifdef DEBUG
call fv_diag(Atm(mygrid:mygrid), zvir, Time, -1)
if (Atm(mygrid)%coarse_graining%write_coarse_diagnostics) then
- call fv_coarse_diag(Atm(mygrid:mygrid), fv_time)
+ call fv_coarse_diag(Atm(mygrid:mygrid), fv_time, zvir)
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
+ call data_override_init(Atm_domain_in = Atm(mygrid)%domain)
+ endif
+
end subroutine atmosphere_init
@@ -434,6 +448,10 @@ subroutine atmosphere_dynamics ( Time )
call read_new_bc_data(Atm(n), Time, Time_step_atmos, p_split, &
isd, ied, jsd, jed )
endif
+
+!save ps to ps_dt before dynamics update
+ ps_dt(:,:)=Atm(n)%ps(:,:)
+
do psc=1,abs(p_split)
p_step = psc
call timing_on('fv_dynamics')
@@ -454,8 +472,8 @@ subroutine atmosphere_dynamics ( Time )
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)%parent_grid, Atm(n)%domain, Atm(n)%inline_mp, &
+ Atm(n)%diss_est)
call timing_off('fv_dynamics')
if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then
@@ -466,6 +484,24 @@ subroutine atmosphere_dynamics ( Time )
endif
end do !p_split
+
+ if (.not. Atm(n)%flagstruct%hydrostatic .and. .not. Atm(n)%flagstruct%pass_full_omega_to_physics_in_non_hydrostatic_mode) then
+ Atm(n)%local_omga(isc:iec,jsc:jec,1:npz) = Atm(n)%delp(isc:iec,jsc:jec,1:npz) / Atm(n)%delz(isc:iec,jsc:jec,1:npz) * Atm(n)%w(isc:iec,jsc:jec,1:npz)
+ if(Atm(n)%flagstruct%nf_omega>0) then
+ call del2_cubed(&
+ Atm(n)%local_omga, &
+ 0.18*Atm(n)%gridstruct%da_min, &
+ Atm(n)%gridstruct, &
+ Atm(n)%domain, &
+ Atm(n)%npx, &
+ Atm(n)%npy, &
+ Atm(n)%npz, &
+ Atm(n)%flagstruct%nf_omega, &
+ Atm(n)%bd)
+ endif
+ endif
+
+
call mpp_clock_end (id_dynam)
!-----------------------------------------------------
@@ -475,6 +511,10 @@ subroutine atmosphere_dynamics ( Time )
call mpp_clock_begin (id_subgridz)
u_dt(:,:,:) = 0. ! These are updated by fv_subgrid_z
v_dt(:,:,:) = 0.
+! t_dt is used for two different purposes:
+! 1 - to calculate the diagnostic temperature tendency from fv_subgrid_z
+! 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,:)
qv_dt(:,:,:) = Atm(n)%q (isc:iec,jsc:jec,:,sphum)
@@ -506,20 +546,23 @@ subroutine atmosphere_dynamics ( Time )
endif
#endif
- if (Atm(1)%idiag%id_u_dt_sg > 0) then
- used = send_data(Atm(1)%idiag%id_u_dt_sg, u_dt(isc:iec,jsc:jec,:), fv_time)
- end if
- if (Atm(1)%idiag%id_v_dt_sg > 0) then
- used = send_data(Atm(1)%idiag%id_v_dt_sg, v_dt(isc:iec,jsc:jec,:), fv_time)
- end if
- if (Atm(1)%idiag%id_t_dt_sg > 0) then
+ if (allocated(Atm(n)%sg_diag%u_dt)) then
+ Atm(n)%sg_diag%u_dt = u_dt(isc:iec,jsc:jec,:)
+ endif
+ if (allocated(Atm(n)%sg_diag%v_dt)) then
+ 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(:,:,:))
- used = send_data(Atm(1)%idiag%id_t_dt_sg, t_dt, fv_time)
- end if
- if (Atm(1)%idiag%id_qv_dt_sg > 0) then
+ 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(:,:,:))
- used = send_data(Atm(1)%idiag%id_qv_dt_sg, qv_dt, fv_time)
- end if
+ Atm(n)%sg_diag%qv_dt = qv_dt(isc:iec,jsc:jec,:)
+ endif
+
+! zero out t_dt for use as an accumulator
+ t_dt = 0.
call mpp_clock_end (id_subgridz)
@@ -533,8 +576,7 @@ subroutine atmosphere_end (Time, Grid_box )!rab, Radiation, Physics)
!rab type (physics_type), intent(inout) :: Physics
! initialize domains for writing global physics data
- if ( Atm(mygrid)%flagstruct%nudge ) call fv_nwp_nudge_end
-
+ if ( Atm(mygrid)%flagstruct%nudge ) call fv_nwp_nudge_end
if (Atm(mygrid)%flagstruct%do_inline_mp) then
call gfdl_mp_end ( )
@@ -545,7 +587,7 @@ subroutine atmosphere_end (Time, Grid_box )!rab, Radiation, Physics)
call fv_diag(Atm(mygrid:mygrid), zvir, fv_time, Atm(mygrid)%flagstruct%print_freq)
call fv_nggps_diag(Atm(mygrid:mygrid), zvir, fv_time)
if (Atm(mygrid)%coarse_graining%write_coarse_diagnostics) then
- call fv_coarse_diag(Atm(mygrid:mygrid), fv_time)
+ call fv_coarse_diag(Atm(mygrid:mygrid), fv_time, zvir)
endif
first_diag = .false.
call timing_off('FV_DIAG')
@@ -554,7 +596,7 @@ subroutine atmosphere_end (Time, Grid_box )!rab, Radiation, Physics)
call fv_end(Atm, mygrid)
deallocate (Atm)
- deallocate( u_dt, v_dt, t_dt, qv_dt, pref, dum1d )
+ deallocate( u_dt, v_dt, t_dt, qv_dt, ps_dt, pref, dum1d )
end subroutine atmosphere_end
@@ -601,9 +643,10 @@ subroutine atmosphere_pref (p_ref)
end subroutine atmosphere_pref
- subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro)
+ subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num)
integer, intent(out) :: i1, i2, j1, j2, kt
logical, intent(out), optional :: p_hydro, hydro
+ integer, intent(out), optional :: tile_num
i1 = Atm(mygrid)%bd%isc
i2 = Atm(mygrid)%bd%iec
j1 = Atm(mygrid)%bd%jsc
@@ -612,7 +655,13 @@ subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro)
if (present(p_hydro)) p_hydro = Atm(mygrid)%flagstruct%phys_hydrostatic
if (present( hydro)) hydro = Atm(mygrid)%flagstruct%hydrostatic
-
+ if (present(tile_num)) then
+ if (Atm(mygrid)%gridstruct%nested) then
+ tile_num = Atm(mygrid)%tile_of_mosaic + 6
+ else
+ tile_num = Atm(mygrid)%tile_of_mosaic
+ endif
+ endif
end subroutine atmosphere_control_data
@@ -664,10 +713,11 @@ subroutine set_atmosphere_pelist ()
end subroutine set_atmosphere_pelist
- subroutine atmosphere_domain ( fv_domain, layout, regional )
+ subroutine atmosphere_domain ( fv_domain, layout, regional, bounded_domain )
type(domain2d), intent(out) :: fv_domain
integer, intent(out) :: layout(2)
logical, intent(out) :: regional
+ logical, intent(out) :: bounded_domain
! returns the domain2d variable associated with the coupling grid
! note: coupling is done using the mass/temperature grid with no halos
@@ -675,6 +725,7 @@ subroutine atmosphere_domain ( fv_domain, layout, regional )
layout(1:2) = Atm(mygrid)%layout(1:2)
regional = Atm(mygrid)%flagstruct%regional
+ bounded_domain = Atm(mygrid)%gridstruct%bounded_domain
end subroutine atmosphere_domain
@@ -691,6 +742,17 @@ subroutine atmosphere_diag_axes ( axes )
end subroutine atmosphere_diag_axes
+ !>@brief The subroutine 'atmosphere_coarse_diag_axes' is an API to return the axis indices
+ !! for the coarse atmospheric (mass) grid.
+ subroutine atmosphere_coarse_diag_axes(coarse_axes)
+ integer, intent(out) :: coarse_axes(4)
+
+ coarse_axes = (/ &
+ Atm(mygrid)%coarse_graining%id_xt_coarse, &
+ Atm(mygrid)%coarse_graining%id_yt_coarse, &
+ Atm(mygrid)%coarse_graining%id_pfull, &
+ Atm(mygrid)%coarse_graining%id_phalf /)
+ end subroutine atmosphere_coarse_diag_axes
subroutine atmosphere_etalvls (ak, bk, flip)
real(kind=kind_phys), pointer, dimension(:), intent(inout) :: ak, bk
@@ -858,6 +920,30 @@ subroutine atmosphere_scalar_field_halo (data, halo, isize, jsize, ksize, data_p
return
end subroutine atmosphere_scalar_field_halo
+ subroutine atmosphere_diss_est (npass)
+ use dyn_core_mod, only: del2_cubed
+ !--- interface variables ---
+ integer, intent(in) :: npass
+ !--- local variables
+ integer:: k
+
+ !horizontally smooth dissiapation estimate for SKEB
+ ! 3 passes before taking absolute value
+ do k = 1,min(3,npass)
+ call del2_cubed(Atm(mygrid)%diss_est, 0.25*Atm(mygrid)%gridstruct%da_min, Atm(mygrid)%gridstruct, &
+ Atm(mygrid)%domain, npx, npy, npz, 3, Atm(mygrid)%bd)
+ enddo
+
+ Atm(mygrid)%diss_est=abs(Atm(mygrid)%diss_est)
+
+ do k = 4,npass
+ call del2_cubed(Atm(mygrid)%diss_est, 0.25*Atm(mygrid)%gridstruct%da_min, Atm(mygrid)%gridstruct, &
+ Atm(mygrid)%domain, npx, npy, npz, 3, Atm(mygrid)%bd)
+ enddo
+ ! provide back sqrt of dissipation estimate
+ Atm(mygrid)%diss_est=sqrt(abs(Atm(mygrid)%diss_est))
+
+ end subroutine atmosphere_diss_est
subroutine atmosphere_nggps_diag (Time, init)
!----------------------------------------------
@@ -1056,17 +1142,19 @@ subroutine get_stock_pe(index, value)
end subroutine get_stock_pe
- subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
+ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block)
!--- interface variables ---
type(time_type), intent(in) :: Time
type(IPD_data_type), intent(in) :: IPD_Data(:)
+ type(IAU_external_data_type), intent(in) :: IAU_Data
type(block_control_type), intent(in) :: Atm_block
!--- local variables ---
type(time_type) :: Time_prev, Time_next
integer :: i, j, ix, k, k1, n, w_diff, nt_dyn, iq
integer :: nb, blen, nwat, dnats, nq_adv
real(kind=kind_phys):: rcp, q0, qwat(nq), qt, rdt
- real :: tracer_clock, lat_thresh
+ real :: psum, qsum, psumb, qsumb, betad, psdt_mean
+ real :: tracer_clock, lat_thresh, fhr
character(len=32) :: tracer_name
Time_prev = Time
@@ -1081,6 +1169,57 @@ subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
if( nq<3 ) call mpp_error(FATAL, 'GFS phys must have 3 interactive tracers')
+ if (IAU_Data%in_interval) then
+ if (IAU_Data%drymassfixer) then
+ ! global mean total pressure and water before IAU
+ psumb = g_sum(Atm(n)%domain,sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz),dim=3),&
+ isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.)
+ qsumb = g_sum(Atm(n)%domain,&
+ sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz)*sum(Atm(n)%q(isc:iec,jsc:jec,1:npz,1:nwat),4),dim=3),&
+ isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.)
+ if (is_master()) then
+ print *,'dry ps before IAU/physics',psumb+Atm(n)%ptop-qsumb
+ endif
+ endif
+
+! IAU increments are in units of 1/sec
+
+! add analysis increment to u,v,t tendencies
+! directly update delp with analysis increment
+ do k = 1, npz
+ do j = jsc,jec
+ do i = isc,iec
+ u_dt(i,j,k) = u_dt(i,j,k) + IAU_Data%ua_inc(i,j,k)
+ v_dt(i,j,k) = v_dt(i,j,k) + IAU_Data%va_inc(i,j,k)
+ t_dt(i,j,k) = t_dt(i,j,k) + IAU_Data%temp_inc(i,j,k)
+ Atm(n)%delp(i,j,k) = Atm(n)%delp(i,j,k) + IAU_Data%delp_inc(i,j,k)*dt_atmos
+ enddo
+ enddo
+ enddo
+ if (.not. Atm(n)%flagstruct%hydrostatic) then
+ do k = 1, npz
+ do j = jsc,jec
+ do i = isc,iec
+ Atm(n)%delz(i,j,k) = Atm(n)%delz(i,j,k) + IAU_Data%delz_inc(i,j,k)*dt_atmos
+ enddo
+ enddo
+ enddo
+ endif
+! add analysis increment to tracers to output from physics
+ do nb = 1,Atm_block%nblks
+ !if (nb.EQ.1) print*,'in block_update',IAU_Data%in_interval,IAU_Data%temp_inc(isc,jsc,30)
+ blen = Atm_block%blksz(nb)
+ do k = 1, npz
+ k1 = 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)
+ IPD_Data(nb)%Stateout%gq0(ix,k,:) = IPD_Data(nb)%Stateout%gq0(ix,k,:) + IAU_Data%tracer_inc(i,j,k1,:)*dt_atmos
+ enddo
+ enddo
+ enddo
+ endif
+
call timing_on('GFS_TENDENCIES')
call atmos_phys_qdt_diag(Atm(n)%q, Atm(n)%phys_diag, nt_dyn, dt_atmos, .true.)
@@ -1114,7 +1253,8 @@ subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
j = Atm_block%index(nb)%jj(ix)
u_dt(i,j,k1) = u_dt(i,j,k1) + (IPD_Data(nb)%Stateout%gu0(ix,k) - IPD_Data(nb)%Statein%ugrs(ix,k)) * rdt
v_dt(i,j,k1) = v_dt(i,j,k1) + (IPD_Data(nb)%Stateout%gv0(ix,k) - IPD_Data(nb)%Statein%vgrs(ix,k)) * rdt
- t_dt(i,j,k1) = (IPD_Data(nb)%Stateout%gt0(ix,k) - IPD_Data(nb)%Statein%tgrs(ix,k)) * rdt
+ t_dt(i,j,k1) = t_dt(i,j,k1) + (IPD_Data(nb)%Stateout%gt0(ix,k) - IPD_Data(nb)%Statein%tgrs(ix,k)) * rdt
+ !t_dt(i,j,k1) = (IPD_Data(nb)%Stateout%gt0(ix,k) - IPD_Data(nb)%Statein%tgrs(ix,k)) * rdt
! SJL notes:
! ---- DO not touch the code below; dry mass conservation may change due to 64bit <-> 32bit conversion
! GFS total air mass = dry_mass + water_vapor (condensate excluded)
@@ -1166,6 +1306,25 @@ subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
enddo ! nb-loop
+! dry mass fixer in IAU interval following
+! https://onlinelibrary.wiley.com/doi/full/10.1111/j.1600-0870.2007.00299.x
+ if (IAU_Data%in_interval .and. IAU_data%drymassfixer) then
+ ! global mean total pressure
+ psum = g_sum(Atm(n)%domain,sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz),dim=3),&
+ isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.)
+ ! global mean total water (before adjustment)
+ qsum = g_sum(Atm(n)%domain,&
+ sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz)*sum(Atm(n)%q(isc:iec,jsc:jec,1:npz,1:nwat),4),dim=3),&
+ isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.)
+ betad = (psum - (psumb - qsumb))/qsum
+ !if (is_master()) print *,'dry ps after IAU/physics',psum+Atm(n)%ptop-qsum, betad
+ Atm(n)%q(:,:,:,1:nwat) = betad*Atm(n)%q(:,:,:,1:nwat)
+ qsum = g_sum(Atm(n)%domain,&
+ sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz)*sum(Atm(n)%q(isc:iec,jsc:jec,1:npz,1:nwat),4),dim=3),&
+ isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1)
+ !if (is_master()) print *,'dry ps after iau_drymassfixer',psum+Atm(n)%ptop-qsum
+ endif
+
call atmos_phys_qdt_diag(Atm(n)%q, Atm(n)%phys_diag, nt_dyn, dt_atmos, .false.)
call timing_off('GFS_TENDENCIES')
@@ -1212,17 +1371,38 @@ subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
call timing_off('FV_UPDATE_PHYS')
call mpp_clock_end (id_dynam)
+!MT surface pressure tendency (hPa/3hr)
+ ps_dt(:,:)=(Atm(n)%ps(:,:)-ps_dt(:,:))*rdt*108.
+ psdt_mean = g_sum(Atm(n)%domain,ABS(ps_dt(isc:iec,jsc:jec)),isc,iec,jsc,jec, &
+ Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.)
+ 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)
+ IPD_Data(nb)%intdiag%ps_dt(ix)=ps_dt(i,j)
+ enddo
+ enddo
+
+ if (is_master()) then
+ fhr=time_type_to_real( Time_next - Atm(n)%Time_init )/3600.
+ if (fhr <= 12.0 .or. (fhr - int(fhr)) == 0.0) then
+ write(555,*) fhr, psdt_mean
+ endif
+ endif
!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
+ lat_thresh = 15.*pi/180.
do iq = 1, nq
call get_tracer_names (MODEL_ATMOS, iq, tracer_name)
- if (trim(tracer_name) == 'pbl_clock') then
+ if (trim(tracer_name) == 'pbl_clock' .or. trim(tracer_name) == 'tro_pbl_clock') 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
@@ -1237,7 +1417,6 @@ subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
enddo
enddo
else if (trim(tracer_name) == 'itcz_clock' ) then
- lat_thresh = 15.*pi/180.
do k=1,npz
do j=jsc,jec
do i=isc,iec
@@ -1268,9 +1447,9 @@ subroutine atmosphere_state_update (Time, IPD_Data, Atm_block)
call timing_on('FV_DIAG')
call fv_diag(Atm(mygrid:mygrid), zvir, fv_time, Atm(mygrid)%flagstruct%print_freq)
- if (Atm(mygrid)%coarse_graining%write_coarse_diagnostics) then
- call fv_coarse_diag(Atm(mygrid:mygrid), fv_time)
- endif
+ if (Atm(mygrid)%coarse_graining%write_coarse_diagnostics) then
+ call fv_coarse_diag(Atm(mygrid:mygrid), fv_time, zvir)
+ endif
first_diag = .false.
call timing_off('FV_DIAG')
@@ -1380,7 +1559,7 @@ subroutine adiabatic_init(zvir,nudge_dz)
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)%domain, Atm(mygrid)%inline_mp, 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, &
@@ -1394,7 +1573,7 @@ subroutine adiabatic_init(zvir,nudge_dz)
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)%domain, Atm(mygrid)%inline_mp, 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) &
@@ -1466,7 +1645,7 @@ subroutine adiabatic_init(zvir,nudge_dz)
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)%domain, Atm(mygrid)%inline_mp, 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, &
@@ -1480,7 +1659,7 @@ subroutine adiabatic_init(zvir,nudge_dz)
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)%domain, Atm(mygrid)%inline_mp, 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) &
@@ -1545,8 +1724,9 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
real(kind=kind_phys), parameter:: qmin = 1.0e-10
real(kind=kind_phys):: pk0inv, ptop, pktop
real(kind=kind_phys) :: rTv, dm, qgrs_rad
- integer :: nb, blen, npz, i, j, k, ix, k1, dnats, nq_adv
+ integer :: nb, blen, npz, i, j, k, ix, k1, dnats, nq_adv, isd, ied, jsd, jed
+ real, pointer :: omega_for_physics(:,:,:)
!!! NOTES: lmh 6nov15
!!! - "Layer" means "layer mean", ie. the average value in a layer
!!! - "Level" means "level interface", ie the point values at the top or bottom of a layer
@@ -1559,13 +1739,19 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
dnats = Atm(mygrid)%flagstruct%dnats
nq_adv = nq - dnats
+ if (.not. Atm(mygrid)%flagstruct%hydrostatic .and. .not. Atm(mygrid)%flagstruct%pass_full_omega_to_physics_in_non_hydrostatic_mode) then
+ omega_for_physics => Atm(mygrid)%local_omga
+ else
+ omega_for_physics => Atm(mygrid)%omga
+ endif
+
!---------------------------------------------------------------------
! use most up to date atmospheric properties when running serially
!---------------------------------------------------------------------
!$OMP parallel do default (none) &
!$OMP shared (Atm_block, Atm, IPD_Data, npz, nq, ncnst, sphum, liq_wat, &
!$OMP ice_wat, rainwat, snowwat, graupel, pk0inv, ptop, &
-!$OMP pktop, zvir, mygrid, dnats, nq_adv) &
+!$OMP pktop, zvir, mygrid, dnats, nq_adv, omega_for_physics) &
!$OMP private (dm, nb, blen, i, j, ix, k1, rTv, qgrs_rad)
do nb = 1,Atm_block%nblks
@@ -1589,12 +1775,6 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
enddo
endif
- do ix = 1, blen
- i = Atm_block%index(nb)%ii(ix)
- j = Atm_block%index(nb)%jj(ix)
- IPD_Data(nb)%Statein%sst(ix) = _DBL_(_RL_(Atm(mygrid)%ts(i,j)))
- enddo
-
do k = 1, npz
do ix = 1, blen
i = Atm_block%index(nb)%ii(ix)
@@ -1606,8 +1786,9 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
IPD_Data(nb)%Statein%tgrs(ix,k) = _DBL_(_RL_(Atm(mygrid)%pt(i,j,k1)))
IPD_Data(nb)%Statein%ugrs(ix,k) = _DBL_(_RL_(Atm(mygrid)%ua(i,j,k1)))
IPD_Data(nb)%Statein%vgrs(ix,k) = _DBL_(_RL_(Atm(mygrid)%va(i,j,k1)))
- IPD_Data(nb)%Statein%vvl(ix,k) = _DBL_(_RL_(Atm(mygrid)%omga(i,j,k1)))
+ IPD_Data(nb)%Statein%vvl(ix,k) = _DBL_(_RL_(omega_for_physics(i,j,k1)))
IPD_Data(nb)%Statein%prsl(ix,k) = _DBL_(_RL_(Atm(mygrid)%delp(i,j,k1))) ! Total mass
+ if (Atm(mygrid)%flagstruct%do_diss_est)IPD_Data(nb)%Statein%diss_est(ix,k) = _DBL_(_RL_(Atm(mygrid)%diss_est(i,j,k1)))
if (.not.Atm(mygrid)%flagstruct%hydrostatic .and. (.not.Atm(mygrid)%flagstruct%use_hydro_pressure)) &
IPD_Data(nb)%Statein%phii(ix,k+1) = IPD_Data(nb)%Statein%phii(ix,k) - _DBL_(_RL_(Atm(mygrid)%delz(i,j,k1)*grav))
@@ -1705,6 +1886,8 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
enddo
enddo
endif
+ IPD_Data(nb)%Statein%dycore_hydrostatic = Atm(mygrid)%flagstruct%hydrostatic
+ IPD_Data(nb)%Statein%nwat = Atm(mygrid)%flagstruct%nwat
enddo
end subroutine atmos_phys_driver_statein
@@ -1806,4 +1989,19 @@ subroutine atmos_phys_qdt_diag(q, phys_diag, nq, dt, begin)
end subroutine atmos_phys_qdt_diag
+ subroutine atmosphere_coarse_graining_parameters(coarse_domain, write_coarse_restart_files, write_only_coarse_intermediate_restarts)
+ type(domain2d), intent(out) :: coarse_domain
+ logical, intent(out) :: write_coarse_restart_files, write_only_coarse_intermediate_restarts
+
+ coarse_domain = Atm(mygrid)%coarse_graining%domain
+ write_coarse_restart_files = Atm(mygrid)%coarse_graining%write_coarse_restart_files
+ write_only_coarse_intermediate_restarts = Atm(mygrid)%coarse_graining%write_only_coarse_intermediate_restarts
+ end subroutine atmosphere_coarse_graining_parameters
+
+ subroutine atmosphere_coarsening_strategy(coarsening_strategy)
+ character(len=64), intent(out) :: coarsening_strategy
+
+ coarsening_strategy = Atm(mygrid)%coarse_graining%strategy
+ end subroutine atmosphere_coarsening_strategy
+
end module atmosphere_mod
diff --git a/driver/solo/atmosphere.F90 b/driver/solo/atmosphere.F90
new file mode 100644
index 000000000..9ff66e494
--- /dev/null
+++ b/driver/solo/atmosphere.F90
@@ -0,0 +1,608 @@
+!***********************************************************************
+!* 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 atmosphere_mod
+
+!-----------------------------------------------------------------------
+!
+! interface for FV dynamical core with Held-Suarez forcing
+!
+!-----------------------------------------------------------------------
+
+
+use constants_mod, only: grav, kappa, cp_air, pi, rdgas, rvgas, SECONDS_PER_DAY
+use fms_mod, only: file_exist, open_namelist_file, &
+ error_mesg, FATAL, &
+ check_nml_error, stdlog, stdout, &
+ write_version_number, &
+ close_file, set_domain, nullify_domain, mpp_pe, mpp_root_pe, &
+ mpp_error, FATAL, NOTE
+use mpp_mod, only: input_nml_file
+use time_manager_mod, only: time_type, get_time, set_time, operator(+)
+use mpp_domains_mod, only: domain2d
+use mpp_io_mod, only: mpp_close
+use mpp_mod, only: input_nml_file
+!------------------
+! FV specific codes:
+!------------------
+use fv_arrays_mod, only: fv_atmos_type
+use fv_control_mod, only: fv_control_init, fv_end, ngrids
+use fv_phys_mod, only: fv_phys, fv_nudge, fv_phys_init
+use fv_diagnostics_mod, only: fv_diag_init, fv_diag, fv_time, eqv_pot
+use fv_timing_mod, only: timing_on, timing_off
+use fv_restart_mod, only: fv_restart
+use fv_dynamics_mod, only: fv_dynamics
+use fv_nesting_mod, only: twoway_nesting
+use gfdl_cld_mp_mod, only: gfdl_cld_mp_init, gfdl_cld_mp_end
+use gfdl_mp_mod, only: gfdl_mp_init, gfdl_mp_end
+use cld_eff_rad_mod, only: cld_eff_rad_init
+use fv_nwp_nudge_mod, only: fv_nwp_nudge_init, fv_nwp_nudge_end, do_adiabatic_init
+use field_manager_mod, only: MODEL_ATMOS
+use tracer_manager_mod, only: get_tracer_index
+!-----------------------------------------------------------------------
+
+implicit none
+private
+
+public atmosphere_init, atmosphere, atmosphere_end, atmosphere_domain
+
+!-----------------------------------------------------------------------
+!---- private data ----
+
+type (time_type) :: Time_step_atmos
+real :: dt_atmos
+integer :: sec
+integer days, seconds
+
+logical :: cold_start = .false. ! read in initial condition
+integer :: mytile = 1
+integer :: p_split = 1
+real, allocatable:: lprec(:,:), fprec(:,:), f_land(:,:)
+
+type(fv_atmos_type), allocatable, target :: Atm(:)
+
+logical, allocatable :: grids_on_this_pe(:)
+integer :: this_grid !not used yet
+integer :: axes(4)
+integer:: isd, ied, jsd, jed, ngc
+!-----------------------------------------------------------------------
+
+! version number of this module
+! Include variable "version" to be written to log file.
+#include
+
+contains
+
+!#######################################################################
+
+ subroutine atmosphere_init ( Time_init, Time, Time_step )
+
+ type (time_type), intent(in) :: Time_step
+ type (time_type), intent(in) :: Time_init
+ type (time_type), intent(in) :: Time
+
+ ! local:
+ integer isc, iec, jsc, jec
+ real:: zvir
+ integer :: n, theta_d
+
+ integer :: nlunit = 9999
+ character (len = 64) :: fn_nml = 'input.nml'
+
+ call timing_on('ATMOS_INIT')
+ !----- write version and namelist to log file -----
+
+ call write_version_number ( 'SOLO/ATMOSPHERE_MOD', version )
+
+ !---- compute physics/atmos time step in seconds ----
+
+ Time_step_atmos = Time_step
+ call get_time (Time_step_atmos, sec)
+ dt_atmos = real(sec)
+
+ !----- initialize FV dynamical core -----
+ cold_start = (.not.file_exist('INPUT/fv_core.res.nc') .and. .not.file_exist('INPUT/fv_core.res.tile1.nc'))
+
+ call fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) ! allocates Atm components
+
+ do n=1,ngrids
+ if (grids_on_this_pe(n)) mytile = n
+ enddo
+
+ call timing_on('fv_restart')
+ call fv_restart(Atm(1)%domain, Atm, dt_atmos, seconds, days, cold_start, &
+ Atm(1)%flagstruct%grid_type, mytile)
+ call timing_off('fv_restart')
+
+ fv_time = time
+
+ do n=1,ngrids
+
+ isc = Atm(n)%bd%isc
+ iec = Atm(n)%bd%iec
+ jsc = Atm(n)%bd%jsc
+ jec = Atm(n)%bd%jec
+ isd = Atm(n)%bd%isd
+ ied = Atm(n)%bd%ied
+ jsd = Atm(n)%bd%jsd
+ jed = Atm(n)%bd%jed
+
+
+ if ( grids_on_this_pe(n)) then
+
+ Atm(N)%flagstruct%moist_phys = .false. ! need this for fv_diag calendar
+ call fv_diag_init(Atm(n:n), axes, Time, Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%flagstruct%p_ref)
+
+ endif
+
+ ! if ( Atm(n)%flagstruct%adiabatic .or. Atm(n)%flagstruct%do_Held_Suarez ) then
+ zvir = 0.
+ if ( Atm(n)%flagstruct%adiabatic ) then
+ Atm(n)%flagstruct%moist_phys = .false.
+ else
+ zvir = rvgas/rdgas - 1.
+ Atm(n)%flagstruct%moist_phys = .true.
+ if ( grids_on_this_pe(n) ) then
+ call fv_phys_init(isc,iec,jsc,jec,Atm(n)%npz,Atm(n)%flagstruct%nwat, Atm(n)%ts, Atm(n)%pt(isc:iec,jsc:jec,:), &
+ Time, axes, Atm(n)%gridstruct%agrid(isc:iec,jsc:jec,2))
+! if ( Atm(n)%flagstruct%nwat==6) call gfdl_cld_mp_init(mpp_pe(), &
+! mpp_root_pe(), input_nml_file, stdlog())
+! if ( Atm(n)%flagstruct%nwat==6) call cld_eff_rad_init(input_nml_file)
+ endif
+ endif
+ if (.not. Atm(n)%flagstruct%adiabatic) call gfdl_mp_init (input_nml_file, stdlog())
+
+
+
+ if ( grids_on_this_pe(n) ) then
+
+ if ( Atm(n)%flagstruct%nudge ) &
+ call fv_nwp_nudge_init( Time, axes, Atm(n)%npz, zvir, Atm(n)%ak, Atm(n)%bk, Atm(n)%ts, &
+ Atm(n)%phis, Atm(n)%gridstruct, Atm(n)%ks, Atm(n)%npx, Atm(n)%neststruct, Atm(n)%bd)
+
+ if ( Atm(n)%flagstruct%make_nh ) then
+ Atm(n)%w(:,:,:) = 0.
+ endif
+
+ if ( Atm(n)%flagstruct%na_init>0 ) then
+ call adiabatic_init(zvir,n)
+ endif
+
+ theta_d = get_tracer_index (MODEL_ATMOS, 'theta_d')
+ if ( theta_d > 0 ) then
+ call eqv_pot(Atm(n)%q(isc:iec,jsc:jec,:,theta_d), Atm(n)%pt, Atm(n)%delp, &
+ Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd,jsd,1,1), isc, iec, jsc, jec, Atm(n)%ng, &
+ Atm(n)%npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys)
+ endif
+
+ endif
+
+ enddo
+
+ call timing_off('ATMOS_INIT')
+ end subroutine atmosphere_init
+
+ subroutine adiabatic_init(zvir, n)
+ real, allocatable, dimension(:,:,:):: u0, v0, t0, dp0
+ real, intent(in):: zvir
+ integer, intent(in) :: n
+ real, parameter:: wt = 1.5 ! 2.
+ real:: xt, esl
+ integer:: isc, iec, jsc, jec, npz
+ integer:: m, i,j,k
+
+ character(len=80) :: errstr
+
+ xt = 1./(1.+wt)
+ if ( Atm(n)%flagstruct%moist_phys ) then
+ esl = zvir
+ else
+ esl = 0.
+ endif
+
+ write(errstr,'(A, I4, A)') 'Performing adiabatic init', Atm(n)%flagstruct%na_init, ' times'
+ call mpp_error(NOTE, errstr)
+
+ npz = Atm(n)%npz
+
+ isc = Atm(n)%bd%isc
+ iec = Atm(n)%bd%iec
+ jsc = Atm(n)%bd%jsc
+ jec = Atm(n)%bd%jec
+
+ ngc = Atm(n)%ng
+ isd = isc - ngc
+ ied = iec + ngc
+ jsd = jsc - ngc
+ jed = jec + ngc
+
+ call timing_on('adiabatic_init')
+ do_adiabatic_init = .true.
+
+ allocate ( u0(isc:iec, jsc:jec+1, npz) )
+ allocate ( v0(isc:iec+1,jsc:jec, npz) )
+ allocate ( t0(isc:iec,jsc:jec, npz) )
+ allocate (dp0(isc:iec,jsc:jec, npz) )
+ call p_adi(npz, Atm(n)%ng, isc, iec, jsc, jec, Atm(n)%ptop, &
+ Atm(n)%delp, Atm(n)%ps, Atm(n)%pe, &
+ Atm(n)%peln, Atm(n)%pk, Atm(n)%pkz, Atm(n)%flagstruct%hydrostatic)
+
+!$omp parallel do default(shared)
+ do k=1,npz
+ do j=jsc,jec+1
+ do i=isc,iec
+ u0(i,j,k) = Atm(n)%u(i,j,k)
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec+1
+ v0(i,j,k) = Atm(n)%v(i,j,k)
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec
+! t0(i,j,k) = Atm(n)%pt(i,j,k)*(1.+esl*Atm(n)%q(i,j,k,1))*(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
+ t0(i,j,k) = Atm(n)%pt(i,j,k)
+ dp0(i,j,k) = Atm(n)%delp(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ do m=1,Atm(n)%flagstruct%na_init
+! 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, &
+ Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, Atm(n)%flagstruct%n_split, &
+ Atm(n)%flagstruct%q_split, 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)
+! 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, &
+ Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, Atm(n)%flagstruct%n_split, &
+ Atm(n)%flagstruct%q_split, 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)
+! Nudging back to IC
+!$omp parallel do default(shared)
+ do k=1,npz
+ do j=jsc,jec+1
+ do i=isc,iec
+ Atm(n)%u(i,j,k) = xt*(Atm(n)%u(i,j,k) + wt*u0(i,j,k))
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec+1
+ Atm(n)%v(i,j,k) = xt*(Atm(n)%v(i,j,k) + wt*v0(i,j,k))
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec
+ Atm(n)%delp(i,j,k) = xt*(Atm(n)%delp(i,j,k) + wt*dp0(i,j,k))
+ enddo
+ enddo
+ enddo
+
+ call p_adi(npz, Atm(n)%ng, isc, iec, jsc, jec, Atm(n)%ptop, &
+ Atm(n)%delp, Atm(n)%ps, Atm(n)%pe, &
+ Atm(n)%peln, Atm(n)%pk, Atm(n)%pkz, Atm(n)%flagstruct%hydrostatic)
+!$omp parallel do default(shared)
+ do k=1,npz
+ do j=jsc,jec
+ do i=isc,iec
+! Atm(n)%pt(i,j,k) = xt*(Atm(n)%pt(i,j,k)+wt*t0(i,j,k)/((1.+esl*Atm(n)%q(i,j,k,1))*(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))))
+ Atm(n)%pt(i,j,k) = xt*(Atm(n)%pt(i,j,k)+wt*t0(i,j,k))
+ enddo
+ enddo
+ enddo
+
+! 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, &
+ Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, Atm(n)%flagstruct%n_split, &
+ Atm(n)%flagstruct%q_split, 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)
+! 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, &
+ Atm(n)%ptop, Atm(n)%ks, Atm(n)%ncnst, Atm(n)%flagstruct%n_split, &
+ Atm(n)%flagstruct%q_split, 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)
+! Nudging back to IC
+!$omp parallel do default(shared)
+ do k=1,npz
+ do j=jsc,jec+1
+ do i=isc,iec
+ Atm(n)%u(i,j,k) = xt*(Atm(n)%u(i,j,k) + wt*u0(i,j,k))
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec+1
+ Atm(n)%v(i,j,k) = xt*(Atm(n)%v(i,j,k) + wt*v0(i,j,k))
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec
+ Atm(n)%delp(i,j,k) = xt*(Atm(n)%delp(i,j,k) + wt*dp0(i,j,k))
+ enddo
+ enddo
+ enddo
+
+ call p_adi(npz, Atm(n)%ng, isc, iec, jsc, jec, Atm(n)%ptop, &
+ Atm(n)%delp, Atm(n)%ps, Atm(n)%pe, &
+ Atm(n)%peln, Atm(n)%pk, Atm(n)%pkz, Atm(n)%flagstruct%hydrostatic)
+
+!$omp parallel do default(shared)
+ do k=1,npz
+ do j=jsc,jec
+ do i=isc,iec
+! Atm(n)%pt(i,j,k) = xt*(Atm(n)%pt(i,j,k)+wt*t0(i,j,k)/((1.+esl*Atm(n)%q(i,j,k,1))*(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))))
+ Atm(n)%pt(i,j,k) = xt*(Atm(n)%pt(i,j,k)+wt*t0(i,j,k))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate ( u0 )
+ deallocate ( v0 )
+ deallocate ( t0 )
+ deallocate (dp0 )
+
+ do_adiabatic_init = .false.
+ call timing_off('adiabatic_init')
+
+ end subroutine adiabatic_init
+
+!#######################################################################
+
+ subroutine atmosphere (Time)
+ type(time_type), intent(in) :: Time
+
+ real:: zvir
+ real:: time_total
+ integer :: n, sphum, p, nc
+ integer :: psc ! p_split counter
+
+
+ call timing_on('ATMOSPHERE')
+ fv_time = Time + Time_step_atmos
+ call get_time (fv_time, seconds, days)
+
+ time_total = days*SECONDS_PER_DAY + seconds
+
+ do psc=1,abs(p_split)
+
+ do n=1,ngrids
+
+ if (.not. grids_on_this_pe(n)) then
+ cycle
+ endif
+
+ call set_domain(Atm(n)%domain) ! needed for diagnostic output done in fv_dynamics
+
+ if ( Atm(n)%flagstruct%nudge_ic ) &
+ call fv_nudge(Atm(n)%npz, Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, Atm(n)%ng, &
+ Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, Atm(n)%delp, Atm(n)%pt, dt_atmos/real(abs(p_split)), Atm(n)%flagstruct%hydrostatic )
+
+ !---- call fv dynamics -----
+! if ( Atm(n)%flagstruct%adiabatic .or. Atm(n)%flagstruct%do_Held_Suarez ) then
+ if ( Atm(n)%flagstruct%adiabatic ) then
+ zvir = 0. ! no virtual effect
+ else
+ zvir = rvgas/rdgas - 1.
+ 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)%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 timing_off('fv_dynamics')
+ end do
+
+ if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then
+ call timing_on('TWOWAY_UPDATE')
+ call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir, fv_time, mytile)
+ call timing_off('TWOWAY_UPDATE')
+ endif
+
+ end do !p_split
+
+ do n=1,ngrids
+
+ if (.not. grids_on_this_pe(n)) then
+ cycle
+ endif
+
+ if(Atm(n)%npz /=1 .and. .not. Atm(n)%flagstruct%adiabatic)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 timing_off('FV_PHYS')
+ endif
+
+ call nullify_domain()
+ end do
+
+ if (ngrids > 1 .and. p_split > 0) then
+ call timing_on('TWOWAY_UPDATE')
+ call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir, fv_time, mytile)
+ call timing_off('TWOWAY_UPDATE')
+ endif
+
+
+ !---- diagnostics for FV dynamics -----
+
+ do n=1,ngrids
+
+ if (.not. grids_on_this_pe(n)) then
+ cycle
+ endif
+
+ !For correct diagnostics (may need to be changed for moist Held-Suarez)
+ if ( Atm(n)%flagstruct%adiabatic .or. Atm(n)%flagstruct%do_Held_Suarez ) then
+ zvir = 0. ! no virtual effect
+ else
+ zvir = rvgas/rdgas - 1.
+ endif
+
+ call nullify_domain()
+ call timing_on('FV_DIAG')
+ call fv_diag(Atm(n:n), zvir, fv_time, Atm(n)%flagstruct%print_freq)
+
+ call timing_off('FV_DIAG')
+ end do
+
+ call timing_off('ATMOSPHERE')
+ end subroutine atmosphere
+
+
+ subroutine atmosphere_end
+
+ integer n
+
+ call get_time (fv_time, seconds, days)
+
+ do n=1,ngrids
+ if ( Atm(n)%flagstruct%moist_phys .and. Atm(n)%flagstruct%nwat==6 .and. grids_on_this_pe(N)) call gfdl_mp_end
+ !if ( Atm(n)%flagstruct%moist_phys .and. Atm(n)%flagstruct%nwat==6 .and. grids_on_this_pe(N)) call gfdl_cld_mp_end
+ enddo
+
+ call fv_end(Atm, mytile)
+ deallocate(Atm)
+
+ end subroutine atmosphere_end
+
+ subroutine atmosphere_domain ( fv_domain )
+ type(domain2d), intent(out) :: fv_domain
+
+! returns the domain2d variable associated with the coupling grid
+! note: coupling is done using the mass/temperature grid with no halos
+
+ fv_domain = Atm(mytile)%domain
+
+ end subroutine atmosphere_domain
+
+ subroutine p_adi(km, ng, ifirst, ilast, jfirst, jlast, ptop, &
+ delp, ps, pe, peln, pk, pkz, hydrostatic)
+
+! Given (ptop, delp) computes (ps, pk, pe, peln, pkz)
+! Input:
+ integer, intent(in):: km, ng
+ integer, intent(in):: ifirst, ilast ! Longitude strip
+ integer, intent(in):: jfirst, jlast ! Latitude strip
+ logical, intent(in):: hydrostatic
+ real, intent(in):: ptop
+ real, intent(in):: delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km)
+! Output:
+ real, intent(out) :: ps(ifirst-ng:ilast+ng, jfirst-ng:jlast+ng)
+ real, intent(out) :: pk(ifirst:ilast, jfirst:jlast, km+1)
+ real, intent(out) :: pe(ifirst-1:ilast+1,km+1,jfirst-1:jlast+1) ! Ghosted Edge pressure
+ real, intent(out) :: peln(ifirst:ilast, km+1, jfirst:jlast) ! Edge pressure
+ real, intent(out) :: pkz(ifirst:ilast, jfirst:jlast, km)
+! Local
+ real pek
+ integer i, j, k
+
+ pek = ptop ** kappa
+
+!$OMP parallel do default(none) shared(ifirst,ilast,jfirst,jlast,km,ptop,pek,pe,pk, &
+!$OMP ps,delp,peln,hydrostatic,pkz)
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+ pe(i,1,j) = ptop
+ pk(i,j,1) = pek
+ enddo
+
+ do k=2,km+1
+ do i=ifirst,ilast
+ pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
+ peln(i,k,j) = log(pe(i,k,j))
+ pk(i,j,k) = exp( kappa*peln(i,k,j) )
+ enddo
+ enddo
+
+ do i=ifirst,ilast
+ ps(i,j) = pe(i,km+1,j)
+ enddo
+
+ if ( hydrostatic ) then
+ do k=1,km
+ do i=ifirst,ilast
+ pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
+ enddo
+ enddo
+ endif
+ enddo
+
+ end subroutine p_adi
+end module atmosphere_mod
diff --git a/driver/solo/fv_phys.F90 b/driver/solo/fv_phys.F90
new file mode 100644
index 000000000..9107bf1c0
--- /dev/null
+++ b/driver/solo/fv_phys.F90
@@ -0,0 +1,2625 @@
+!***********************************************************************
+!* 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_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 time_manager_mod, only: time_type, get_time
+use gfdl_cld_mp_mod, only: gfdl_cld_mp_driver, qsmith, wet_bulb
+use hswf_mod, only: Held_Suarez_Tend
+use fv_sg_mod, only: fv_subgrid_z
+use fv_update_phys_mod, only: fv_update_phys
+use fv_timing_mod, only: timing_on, timing_off
+use monin_obukhov_mod, only: mon_obkv
+use tracer_manager_mod, only: get_tracer_index, adjust_mass
+use field_manager_mod, only: MODEL_ATMOS
+use fms_mod, only: error_mesg, FATAL, file_exist, open_namelist_file, &
+ check_nml_error, mpp_pe, mpp_root_pe, close_file, &
+ write_version_number, stdlog, mpp_error
+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 diag_manager_mod, only: register_diag_field, register_static_field, send_data
+use qs_tables_mod, only: qs_wat_init, qs_wat
+
+implicit none
+
+ logical:: nudge_initialized = .false.
+ logical:: sim_phys_initialized = .false.
+ logical:: g0_sum_initialized = .false.
+ logical:: qs_table_is_initialized = .false.
+ real, allocatable, dimension(:,:) :: l_area
+ real, allocatable, dimension(:,:) :: table_w(:), des_w(:)
+ logical:: master
+ real, allocatable:: u0(:,:,:), v0(:,:,:), t0(:,:,:), dp(:,:,:), u_star(:,:)
+ real, allocatable:: ts0(:,:)
+ real:: global_area = -1.
+
+public :: fv_phys, fv_nudge
+
+!---- version number -----
+ character(len=8) :: mod_name = 'sim_phys'
+
+ integer:: sphum, liq_wat, rainwat, snowwat, graupel, ice_wat, cld_amt
+! For nudging the IC to a steady state:
+ real :: tau_winds = 25.
+ real :: tau_temp = -1.
+ real :: tau_press = -1.
+
+ real, parameter:: e0 = 610.71 ! saturation vapor pressure at T0
+ real, parameter:: tice = 273.16
+! real, parameter:: c_liq = 4.1855e+3 ! GFS
+ real, parameter:: c_liq = 4218.0 ! IFS
+ real, parameter:: cp_vap = cp_vapor ! 1846.
+! For consistency, cv_vap derived FMS constants:
+ real, parameter:: cv_vap = cp_vap - rvgas ! 1384.5
+ real, parameter:: cv_air = cp_air - rdgas
+#ifdef SIM_NGGPS
+ real, parameter:: dc_vap = 0.
+#else
+ real, parameter:: dc_vap = cp_vap - c_liq ! = -2344. isobaric heating/cooling
+#endif
+ real, parameter:: Lv0 = hlv - dc_vap*tice
+! L = hlv + (Cp_vapor-C_liq)*(T-T_ice)
+ real:: deg2rad = pi/180.
+ real:: zvir
+ real:: area_ref = 6.25E8
+ real:: solar_constant = 1367.
+! Namelist for Sim_Phys
+
+ logical:: do_K_warm_rain = .false. !Enable Kessler
+ logical:: do_strat_HS_forcing = .true. !modified held-suarez
+ logical:: do_LS_cond = .false. !A Simple LS condensation scheme
+ logical:: do_GFDL_sim_phys = .false. !Enable GFDL simple physics
+ logical:: do_surf_drag = .false. ! a simple surface drag (bottom friction) scheme
+ real :: tau_surf_drag = 1. ! time-scale for the surface drag
+ logical:: do_reed_sim_phys = .false.
+ logical:: do_terminator = .false.
+ logical:: term_fill_negative = .false.
+ integer:: print_freq = 6 ! hours
+ integer:: seconds, days
+ logical :: print_diag
+ integer :: istep = 0
+
+ !GFDL Simplified Physics (mostly Frierson)
+ logical:: diurnal_cycle = .false.
+ logical:: mixed_layer = .false.
+ logical:: gray_rad = .false.
+ logical:: strat_rad = .false.
+ logical:: do_abl = .false.
+ logical:: do_mon_obkv = .true.
+ real:: heating_rate = 0.5 ! deg K per day, stratosphere, for gray-radiation
+ real:: cooling_rate = 0. ! deg K per day (note sign convention)
+ logical:: uniform_sst = .true.
+ real:: sst0 = 302.15 ! K
+ real:: sst_restore_timescale = 5. !days
+ integer :: sst_type = 0 ! choice of SST profile
+ real:: shift_n = 12.
+ logical:: do_t_strat = .false.
+ real:: p_strat = 50.E2
+ real:: t_strat = 200.
+ real:: tau_strat = 10. ! days
+ real:: mo_t_fac = 1.
+ real:: tau_difz = 600. !prescribed surface roughness (?) if do_mon_obkv not set
+ logical:: prog_low_cloud = .true.
+ real:: low_cf0 = 0.3 ! global mean *low* cloud fraction
+ logical:: zero_winds = .false. ! use this only for the doubly periodic domain
+ real:: tau_zero = 1. ! time-scale to "zero" domain-averaged winds (days)
+ logical:: do_mo_fixed_cd = .false. ! NJ, fixed drag option
+ real:: mo_cd = 1.5e-3 ! NJ, fixed drag coefficient
+ real:: mo_u_mean = 0. ! NJ, mean wind for enthalpy fluxes
+ real:: abl_s_fac = 0.1
+ real:: ml_c0 = 6.285E7 ! Ocean heat capabicity 4190*depth*e3, depth = 15.
+ real:: sw_abs = 0. ! fraction of the solar absorbed/reflected by the atm
+
+
+ !Kessler parameters
+ logical:: K_sedi_transport = .false.
+ logical:: do_K_sedi_w = .false.
+ logical:: do_K_sedi_heat = .false.
+ integer:: K_cycle = 0 ! K_warm-Rain cycles
+
+ !Reed physics parameters
+ logical:: do_reed_cond = .false. !Do reed condensation in addition to surface fluxes
+ logical:: reed_cond_only = .false. !Do NOT do reed surface fluxes, only condensation scheme
+ logical:: reed_alt_mxg = .false. !Use silly alternate mixing scheme to fix MPAS's problems
+ integer:: reed_test = 0 ! Constant SST
+
+ !Diagnostics
+ integer :: id_vr_k, id_rain, id_rain_k, id_pblh
+ integer :: id_dqdt, id_dTdt, id_dudt, id_dvdt
+ integer :: id_qflux, id_hflux
+ real, allocatable:: prec_total(:,:)
+ real :: missing_value = -1.e10
+
+ logical :: first_call = .true.
+
+namelist /sim_phys_nml/do_strat_HS_forcing, &
+ print_freq, tau_winds, &
+ tau_temp, tau_press, sst_restore_timescale, &
+ do_K_warm_rain, do_GFDL_sim_phys,&
+ do_reed_sim_phys, do_LS_cond, do_surf_drag, &
+ tau_surf_drag, do_terminator
+
+namelist /GFDL_sim_phys_nml/ diurnal_cycle, mixed_layer, gray_rad, strat_rad, do_abl, do_mon_obkv, &
+ heating_rate, cooling_rate, uniform_sst, sst0, sst_type, shift_n, do_t_strat, p_strat, t_strat, tau_strat, &
+ mo_t_fac, tau_difz, prog_low_cloud, low_cf0, zero_winds, tau_zero, do_mo_fixed_cd, mo_cd, mo_u_mean, &
+ abl_s_fac, ml_c0, sw_abs
+
+namelist /Kessler_sim_phys_nml/ K_sedi_transport, do_K_sedi_w, do_K_sedi_heat, K_cycle
+
+namelist /reed_sim_phys_nml/ do_reed_cond, reed_cond_only,&
+ reed_alt_mxg, reed_test
+
+contains
+
+ 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, &
+ do_Held_Suarez, gridstruct, flagstruct, &
+ neststruct, nwat, bd, domain, & !S-J: Need to update fv_phys call
+ Time, phys_diag, nudge_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)
+
+ real , INTENT(INOUT) :: u(is-ng:ie+ ng,js-ng:je+1+ng,npz)
+ real , INTENT(INOUT) :: v(is-ng:ie+1+ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: w(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: pt(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: delp(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: q(is-ng:ie+ ng,js-ng:je+ ng,npz, nq)
+ real , INTENT(INOUT) :: pe(is-1:ie+1 ,1:npz+1,js-1:je+1)
+ real , INTENT(INOUT) :: peln(is :ie ,1:npz+1,js :je )
+ real , INTENT(INOUT) :: pkz(is :ie ,js :je ,1:npz)
+ real , INTENT(INOUT) :: pk (is :ie ,js :je ,npz+1)
+ real , INTENT(INOUT) :: ua(is-ng:ie+ng,js-ng:je+ng,npz)
+ real , INTENT(INOUT) :: va(is-ng:ie+ng,js-ng:je+ng,npz)
+ real , INTENT(INOUT) :: ps(is-ng:ie+ng,js-ng:je+ng)
+
+ real , INTENT(IN ) :: phis(is-ng:ie+ng,js-ng:je+ng)
+ real , INTENT(IN ) :: grid(is-ng:ie+ng,js-ng:je+ng, 2)
+ real , INTENT(IN ) :: ak(npz+1), bk(npz+1)
+ integer, INTENT(IN ) :: ks
+
+ real , INTENT(IN ) :: pdt
+ logical, INTENT(IN ) :: rayf, do_Held_Suarez
+ real, INTENT(inout):: u_srf(is:ie,js:je)
+ real, INTENT(inout):: v_srf(is:ie,js:je)
+ 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(fv_grid_type) :: gridstruct
+ type(fv_flags_type) :: flagstruct
+ type(fv_nest_type) :: neststruct
+ type(fv_grid_bounds_type), intent(IN) :: bd
+ type(domain2d), intent(INOUT) :: domain
+
+ type (time_type), intent(in) :: Time
+ real, INTENT(IN), optional:: time_total
+ logical, intent(in) :: hydrostatic
+ real, intent(inout) :: delz(is:,js:,1:)
+! Local:
+ real, parameter:: sigb = 0.7
+ logical:: no_tendency = .true.
+ integer, parameter:: nmax = 2
+ real, allocatable:: u_dt(:,:,:), v_dt(:,:,:), t_dt(:,:,:), q_dt(:,:,:,:)
+ 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 :: qdiag(1,1,1)
+ logical moist_phys
+ integer isd, ied, jsd, jed
+ integer i, j, k, m, n, int
+ integer theta_d, Cl, Cl2
+ logical used
+
+ call get_time (time, seconds, days)
+
+ if (print_freq < 0) then
+ istep = istep + 1
+ print_diag = (mod(istep,-print_freq) == 0)
+ else
+ if ( mod(seconds, print_freq*3600)==0 ) then
+ print_diag = .true.
+ else
+ print_diag = .false.
+ endif
+ endif
+
+ master = is_master()
+! if (.not. sim_phys_initialized) call fv_phys_init(is, ie, js, je, nwat, ts, time, axes, &
+! gridstruct%agrid(:,:,2))
+ sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
+ liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
+ ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
+ rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
+ snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
+ graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
+ cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt')
+
+ rkv = pdt / (tau_surf_drag*24.*3600.)
+
+ isd = is-ng; ied = ie + ng
+ jsd = js-ng; jed = je + ng
+
+ allocate ( u_dt(isd:ied,jsd:jed,npz) )
+ allocate ( v_dt(isd:ied,jsd:jed,npz) )
+ allocate ( t_dt(is:ie,js:je,npz) )
+ allocate ( q_dt(is:ie,js:je,npz,nq) )
+
+! Place the memory in the optimal shared mem space!
+!$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,is,ie,js,je,nq,u_dt,v_dt,t_dt,q_dt)
+ do k=1, npz
+ do j=jsd, jed
+ do i=isd, ied
+ u_dt(i,j,k) = 0.
+ v_dt(i,j,k) = 0.
+ enddo
+ enddo
+
+ do j=js, je
+ do i=is, ie
+ t_dt(i,j,k) = 0.
+ enddo
+ enddo
+ do n=1,nq
+ do j=js, je
+ do i=is, ie
+ q_dt(i,j,k,n) = 0.
+ enddo
+ enddo
+ 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.
+ endif
+
+ if ( do_LS_cond ) then
+
+ moist_phys = .true.
+ zvir = rvgas/rdgas - 1.
+ theta_d = get_tracer_index (MODEL_ATMOS, 'theta_d')
+!$omp parallel do default(shared) private(pm, adj, den, lcp, dq, dqsdt, delm)
+ do j=js,je
+ do i=is, ie
+ rain(i,j) = 0.
+ enddo
+ do n=1, nmax
+ if ( n == nmax ) then
+ adj = 1.
+ else
+ adj = 0.5
+ endif
+ do k=1,npz
+ if ( hydrostatic ) then
+ do i=is, ie
+ pm(i,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
+ den(i) = pm(i,k)/(rdgas*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum)))
+! MOIST_NGGPS
+! lcp(i) = (Lv0+dc_vap*pt(i,j,k))/cp_air
+ lcp(i) = (Lv0+dc_vap*pt(i,j,k))/((1.-q(i,j,k,sphum)-q(i,j,k,liq_wat))*cp_air + &
+ q(i,j,k,sphum)*cp_vap + q(i,j,k,liq_wat)*c_liq)
+ enddo
+ else
+ do i=is, ie
+ den(i) = -delp(i,j,k)/(grav*delz(i,j,k))
+! MOIST_NGGPS
+! lcp(i) = (Lv0+dc_vap*pt(i,j,k))/cv_air
+ lcp(i) = (Lv0+dc_vap*pt(i,j,k))/((1.-q(i,j,k,sphum)-q(i,j,k,liq_wat))*cv_air + &
+ q(i,j,k,sphum)*cv_vap + q(i,j,k,liq_wat)*c_liq)
+ enddo
+ endif
+ do i=is,ie
+ dq = q(i,j,k,sphum) - qs_wat(pt(i,j,k),den(i),dqsdt)
+ dq = adj*dq/(1.+lcp(i)*dqsdt)
+ if ( dq > 0. ) then ! remove super-saturation over water
+ pt(i,j,k) = pt(i,j,k) + dq*lcp(i)
+ q(i,j,k, sphum) = q(i,j,k, sphum) - dq
+! the following line Detrains to liquid water
+ q(i,j,k,liq_wat) = q(i,j,k,liq_wat) + dq
+ rain(i,j) = rain(i,j) + dq*delp(i,j,k)/(pdt*grav) ! mm/sec
+ endif
+ enddo
+ enddo
+ enddo ! n-loop
+
+ do k=2,npz+1
+ do i=is,ie
+ pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
+ peln(i,k,j) = log( pe(i,k,j) )
+ pk(i,j,k) = exp( kappa*peln(i,k,j) )
+ enddo
+ enddo
+ do i=is,ie
+ ps(i,j) = pe(i,npz+1,j)
+ enddo
+ if ( hydrostatic ) then
+ do k=1,npz
+ do i=is,ie
+ pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
+ enddo
+ enddo
+ endif
+ enddo ! j-loop
+
+ if (id_rain > 0) then
+ rain(:,:) = rain (:,:) / pdt * 86400.
+ used=send_data(id_rain, rain, time)
+ endif
+ endif
+
+ if ( do_K_warm_rain ) then
+ liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
+ rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
+ moist_phys = .true.
+ zvir = rvgas/rdgas - 1.
+
+ if ( K_cycle .eq. 0 ) then
+ K_cycle = max(1, nint(pdt/30.)) ! 30 sec base time step
+ if( master ) write(*,*) 'Kessler warm-rain-phys cycles', trim(gn), ' =', K_cycle
+ endif
+ if (do_terminator) then
+ Cl = get_tracer_index (MODEL_ATMOS, 'Cl')
+ Cl2 = get_tracer_index (MODEL_ATMOS, 'Cl2')
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ q(i,j,k,Cl) = q(i,j,k,Cl)*delp(i,j,k)
+ enddo
+ enddo
+ enddo
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ q(i,j,k,Cl2) = q(i,j,k,Cl2)*delp(i,j,k)
+ enddo
+ enddo
+ enddo
+ 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)
+
+ if( K_sedi_transport ) no_tendency = .false.
+ if (do_terminator) then
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ q(i,j,k,Cl) = q(i,j,k,Cl)/delp(i,j,k)
+ enddo
+ enddo
+ enddo
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ q(i,j,k,Cl2) = q(i,j,k,Cl2)/delp(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ if ( id_rain_k>0 ) then
+ prec_total(:,:) = prec_total(:,:) + rain(:,:)
+ used = send_data(id_rain_k, prec_total, time)
+ if (print_diag) then
+ prec = g_sum(prec_total, is, ie, js, je, gridstruct%area(is:ie,js:je), 1)
+ if(master) write(*,*) ' Accumulated rain (m)', trim(gn), ' =', prec
+ endif
+ !call prt_maxmin(' W', w, is, ie, js, je, ng, npz, 1.)
+ endif
+ if ( id_rain>0 ) then
+ rain(:,:) = rain (:,:) / pdt * 86400. ! kg/dA => mm over timestep, convert to mm/d
+ used = send_data(id_rain, rain, time)
+ if (print_diag) call prt_maxmin(' Kessler rain rate (mm/day): ', rain, &
+ is,ie,js,je,0,1,1.)
+ endif
+ endif
+
+
+ if ( do_GFDL_sim_phys ) then
+ moist_phys = .true.
+ call timing_on('GFDL_SIM_PHYS')
+ call GFDL_sim_phys(npx, npy, npz, is, ie, js, je, ng, nq, nwat, pk, pkz, &
+ u_dt, v_dt, t_dt, q_dt, u, v, w, ua, va, pt, delz, q, &
+ pe, delp, peln, ts, oro, hydrostatic, pdt, grid, ak, bk, & !ts --> sst
+ p_ref, Time, time_total, flagstruct%grid_type, gridstruct)
+ call timing_off('GFDL_SIM_PHYS')
+ no_tendency = .false.
+ endif
+
+ if ( do_reed_sim_phys ) then
+ moist_phys = .true.
+ zvir = rvgas/rdgas - 1.
+ rgrav = 1./grav
+!$omp parallel do default(shared) private(den,u2,v2,t2,q2,dp2,pm,rdelp,du2, dv2, dt2, dq2)
+ do j=js,je
+! Input to Reed_phys are hydrostatic and probably don't understand total mass either
+ do k=1,npz
+ do i=is,ie
+ dp2(i,k) = delp(i,j,k)
+ rdelp(i,k) = 1./dp2(i,k)
+ u2(i,k) = ua(i,j,k)
+ v2(i,k) = va(i,j,k)
+ t2(i,k) = pt(i,j,k)
+ q2(i,k) = max(0., q(i,j,k,sphum))
+ pm(i,k) = dp2(i,k)/(peln(i,k+1,j)-peln(i,k,j))
+ enddo
+ enddo
+ do i=is,ie
+ zint(i,k) = phis(i,j)*rgrav
+ enddo
+ if (hydrostatic) then
+ do k=npz,1,-1
+ do i=is,ie
+ zint(i,k) = zint(i,k+1) + rdgas*rgrav*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum)) * &
+ (peln(i,k+1,j)-peln(i,k,j))
+ enddo
+ enddo
+ else
+ do k=npz,1,-1
+ do i=is,ie
+ zint(i,k) = zint(i,k+1) - delz(i,j,k)
+ enddo
+ enddo
+ endif
+ do i=is,ie
+ rain2(i) = 0.
+ enddo
+
+ call reed_sim_physics( ie-is+1, npz, pdt, gridstruct%agrid(is:ie,j,2), t2, &
+ q2, u2, v2, pm, pe(is:ie,1:npz+1,j), dp2, rdelp, &
+ pe(is:ie,npz+1,j), zint, reed_test, do_reed_cond, reed_cond_only, &
+ reed_alt_mxg, rain2, du2, dv2, dt2, dq2 )
+ do k=1,npz
+ do i=is,ie
+ u_dt(i,j,k) = u_dt(i,j,k) + du2(i,k)
+ v_dt(i,j,k) = v_dt(i,j,k) + dv2(i,k)
+ t_dt(i,j,k) = t_dt(i,j,k) + dt2(i,k)
+ q_dt(i,j,k,sphum) = q_dt(i,j,k,sphum) + dq2(i,k)
+ enddo
+ enddo
+ if (do_reed_cond) then
+ do i=is,ie
+ rain(i,j) = rain2(i) * 8.64e7 ! m/s => mm/d
+ enddo
+ endif
+ enddo
+ if ( do_reed_cond .and. id_rain_k>0 ) then
+ prec_total(:,:) = prec_total(:,:) + rain(:,:) * pdt/ 86400. ! mm over timestep
+ used = send_data(id_rain_k, prec_total, time)
+ if (print_diag) then
+ prec = g_sum(prec_total, is, ie, js, je, gridstruct%area(is:ie,js:je), 1)
+ if(master) write(*,*) ' Accumulated rain (m)', trim(gn), ' =', prec
+ endif
+ !call prt_maxmin(' W', w, is, ie, js, je, ng, npz, 1.)
+ endif
+ if (do_reed_cond .and. id_rain > 0) then
+ used = send_data(id_rain, rain, time)
+ if (print_diag) call prt_maxmin(' Reed rain rate (mm/d): ', rain, &
+ is,ie,js,je,0,1,1.)
+ endif
+ no_tendency = .false.
+ endif
+
+ if( do_Held_Suarez ) then
+ moist_phys = .false.
+ call Held_Suarez_Tend(npx, npy, npz, is, ie, js, je, ng, nq, &
+ u, v, pt, q, pe, delp, peln, pkz, pdt, &
+ ua, va, u_dt, v_dt, t_dt, q_dt, grid, &
+ delz, phis, hydrostatic, ak, bk, ks, &
+ do_strat_HS_forcing, .false., master, Time, time_total)
+ no_tendency = .false.
+ elseif ( do_surf_drag ) then
+! Bottom friction:
+!$omp parallel do default(shared) private(sigl,tmp)
+
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+! pm(i,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
+ sigl = delp(i,j,k) / ((peln(i,k+1,j)-peln(i,k,j))*pe(i,npz+1,j))
+ sigl = (sigl-sigb)/(1.-sigb) * rkv
+ if (sigl > 0.) then
+ tmp = sigl / ((1.+sigl)*pdt)
+ u_dt(i,j,k) = u_dt(i,j,k) - ua(i,j,k)*tmp
+ v_dt(i,j,k) = v_dt(i,j,k) - va(i,j,k)*tmp
+ if ( hydrostatic ) then
+ pt(i,j,k) = pt(i,j,k) + pdt*tmp*(ua(i,j,k)**2+va(i,j,k)**2)/cp_air
+ else
+ pt(i,j,k) = pt(i,j,k) + pdt*tmp*(ua(i,j,k)**2+va(i,j,k)**2)/cv_air
+ endif
+ endif
+ enddo !i-loop
+ enddo !j-loop
+ enddo !k-loop
+ no_tendency = .false.
+ endif
+
+ if (do_terminator) then
+ call DCMIP2016_terminator_advance(is,ie,js,je,isd,ied,jsd,jed,npz, &
+ q, delp, flagstruct%ncnst, &
+ gridstruct%agrid(isd,jsd,1),gridstruct%agrid(isd,jsd,2), pdt)
+ endif
+
+
+ if (id_dudt > 0) then
+ used=send_data(id_dudt, u_dt(is:ie,js:je,npz), time)
+ endif
+ if (id_dvdt > 0) then
+ used=send_data(id_dvdt, v_dt(is:ie,js:je,npz), time)
+ endif
+ if (id_dtdt > 0) then
+ used=send_data(id_dtdt, t_dt(:,:,:), time)
+ endif
+ if (id_dqdt > 0) then
+ used=send_data(id_dqdt, q_dt(:,:,:,sphum), time)
+ endif
+
+
+ if ( .not. no_tendency ) then
+ call timing_on('UPDATE_PHYS')
+ call fv_update_phys (pdt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, &
+ u, v, w, delp, pt, q, qdiag, ua, va, ps, pe, peln, pk, pkz, &
+ ak, bk, phis, u_srf, v_srf, ts, &
+ delz, hydrostatic, u_dt, v_dt, t_dt, &
+ moist_phys, Time, .false., gridstruct, &
+ gridstruct%agrid(:,:,1), gridstruct%agrid(:,:,2), &
+ npx, npy, npz, flagstruct, neststruct, bd, domain, ptop, &
+ phys_diag, nudge_diag, q_dt=q_dt)
+
+ call timing_off('UPDATE_PHYS')
+ endif
+ deallocate ( u_dt )
+ deallocate ( v_dt )
+ deallocate ( t_dt )
+ deallocate ( q_dt )
+
+ first_call = .false.
+
+ end subroutine fv_phys
+
+
+ subroutine GFDL_sim_phys(npx, npy, npz, is, ie, js, je, ng, nq, nwat, pk, pkz, &
+ u_dt, v_dt, t_dt, q_dt, u, v, w, ua, va, &
+ pt, delz, q, pe, delp, peln, sst, oro, hydrostatic, &
+ pdt, agrid, ak, bk, p_ref, &
+ Time, time_total, grid_type, gridstruct)
+!-----------------------
+! A simple moist physics
+!-----------------------
+
+
+ integer, INTENT(IN) :: npx, npy, npz
+ integer, INTENT(IN) :: is, ie, js, je, ng, nq, nwat, grid_type
+ real , INTENT(IN) :: pdt
+ real , INTENT(IN) :: agrid(is-ng:ie+ng,js-ng:je+ng, 2)
+ real , INTENT(IN) :: ak(npz+1), bk(npz+1)
+ real, INTENT(IN):: p_ref
+ real, INTENT(IN):: oro(is:ie,js:je) ! land fraction
+ logical, INTENT(IN):: hydrostatic
+
+ type(time_type), intent(in) :: Time
+ real, INTENT(IN), optional:: time_total
+
+ real , INTENT(INOUT) :: u(is-ng:ie+ ng,js-ng:je+1+ng,npz)
+ real , INTENT(INOUT) :: v(is-ng:ie+1+ng,js-ng:je+ ng,npz)
+ real, INTENT(INOUT):: pk (is:ie,js:je,npz+1)
+ real, INTENT(INOUT):: pkz(is:ie,js:je,npz)
+ real, INTENT(INOUT):: pt(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: delp(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: q(is-ng:ie+ng,js-ng:je+ng,npz, nq)
+ real, INTENT(INOUT):: pe(is-1:ie+1 ,1:npz+1,js-1:je+1)
+ real, INTENT(INOUT):: peln(is :ie ,1:npz+1,js :je )
+ real, INTENT(INOUT):: delz(is :ie ,js :je ,npz)
+ real, intent(inout):: w(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: sst(is:ie,js:je)
+
+ type(fv_grid_type) :: gridstruct
+
+! Tendencies:
+ real, INTENT(INOUT):: u_dt(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: v_dt(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: t_dt(is:ie,js:je,npz)
+ real, INTENT(INOUT):: q_dt(is:ie,js:je,npz,nq)
+ real, INTENT(IN):: ua(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(IN):: va(is-ng:ie+ng,js-ng:je+ng,npz)
+! Local
+ real, dimension(is:ie,js:je):: flux_t, flux_q, flux_u, flux_v, delm, drag_t, drag_q
+ logical:: phys_hydrostatic = .true.
+ real, parameter:: f1 = 2./3.
+ real, parameter:: f2 = 1./3.
+ real, dimension(is:ie,js:je,npz):: u3, v3, t3, p3, dz, zfull
+ real, dimension(is:ie,js:je,npz+1):: zhalf
+ real, dimension(is:ie,js:je,npz,nq):: q3
+ real, dimension(is:ie,js:je):: rain, snow, ice, graup, land, mu
+ real, dimension(is:ie,js:je):: ps, qs, rho, clouds
+ real, dimension(is:ie,js:je):: olr, lwu, lwd, sw_surf, wet_t, net_rad
+! Flux diag:
+ real, dimension(is:ie,js:je):: rflux, qflux
+ real, dimension(is:ie,npz):: den
+ real, dimension(is:ie,npz):: t_dt_rad
+ real, dimension(npz):: utmp, vtmp
+ real:: sday, rrg, tvm, olrm, swab, sstm, clds, hflux1, hflux2, hflux3, precip
+ real:: tmp, cooling, heating
+ real:: fac_sm, rate_w, rate_u, rate_v, rate_t, rate_q
+ real:: prec
+ integer i,j,k, km, iq, k_mp
+ integer isd, ied, jsd, jed
+ integer seconds, days
+ logical used
+
+! if (.not. sim_phys_initialized) call fv_phys_init(nwat)
+
+ call get_time (time, seconds, days)
+
+ km = npz
+ isd = is-ng; ied = ie + ng
+ jsd = js-ng; jed = je + ng
+
+ zvir = rvgas/rdgas - 1.
+! Factor for Small-Earth Approx.
+ fac_sm = radius / 6371.0e3
+ rrg = rdgas / grav
+ sday = 24.*3600.*fac_sm !not sure this works right
+
+ qflux = 0.
+ rflux = 0.
+
+
+
+! Compute zfull, zhalf
+ do j=js,je
+ do i=is,ie
+ zhalf(i,j,npz+1) = 0.
+ ps(i,j) = pe(i,km+1,j)
+ enddo
+ enddo
+
+ if ( hydrostatic ) then
+ do k=km,1,-1
+ do j=js,je
+ do i=is,ie
+ tvm = rrg*pt(i,j,k)*(1.+zvir*q(i,j,k,1))
+ dz(i,j,k) = -tvm*(peln(i,k+1,j)-peln(i,k,j))
+ p3(i,j,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
+ zfull(i,j,k) = zhalf(i,j,k+1) + tvm*(1.-pe(i,k,j)/p3(i,j,k))
+ zhalf(i,j,k) = zhalf(i,j,k+1) - dz(i,j,k)
+ enddo
+ enddo
+ enddo
+ else
+ do k=km,1,-1
+ do j=js,je
+ do i=is,ie
+ dz(i,j,k) = delz(i,j,k)
+ p3(i,j,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
+ zhalf(i,j,k) = zhalf(i,j,k+1) - dz(i,j,k)
+ zfull(i,j,k) = zhalf(i,j,k+1) - 0.5*dz(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ do k=1, km
+ do j=js,je
+ do i=is,ie
+ u3(i,j,k) = ua(i,j,k) + pdt*u_dt(i,j,k)
+ v3(i,j,k) = va(i,j,k) + pdt*v_dt(i,j,k)
+ t3(i,j,k) = pt(i,j,k) + pdt*t_dt(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ do j=js,je
+ do i=is,ie
+ delm(i,j) = delp(i,j,km)/grav
+ rho(i,j) = -delm(i,j)/dz(i,j,km)
+ enddo
+ enddo
+
+!----------
+! Setup SST:
+!----------
+
+! Need to save sst in a restart file if mixed_layer = .T.
+ if ( .not. mixed_layer ) then
+!!$ if ( uniform_sst ) then
+!!$ sst(:,:) = sst0
+!!$ else
+!!$ if (sst_type == 1) then !SST in equib with lower atmosphere
+!!$ do j=js,je
+!!$ do i=is,ie
+!!$ !ts0(i,j) = pt(i,j,km)
+!!$ sst(i,j) = ts0(i,j)
+!!$ enddo
+!!$ enddo
+!!$ else
+!!$ do j=js,je
+!!$ do i=is,ie
+!!$ ts0(i,j) = 270.5 + 32.*exp( -((agrid(i,j,2)-shift_n*deg2rad)/(pi/3.))**2 )
+!!$ enddo
+!!$ enddo
+!!$ endif
+!!$ endif
+ do j=js,je
+ do i=is,ie
+ sst(i,j) = ts0(i,j)
+ enddo
+ enddo
+ endif
+
+
+ do iq=1,nq
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ q3(i,j,k,iq) = q(i,j,k,iq) + pdt*q_dt(i,j,k,iq)
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+!----------------------------
+! Apply net radiative cooling
+!----------------------------
+ if ( gray_rad ) then
+ if ( prog_low_cloud ) then
+ call get_low_clouds( is,ie, js,je, km, q3(is,js,1,liq_wat), q3(is,js,1,ice_wat), &
+ q3(is,js,1,cld_amt), clouds )
+ else
+ clouds(:,:) = low_cf0
+ endif
+
+ do j=js,je
+ do k=1, km
+ do i=is,ie
+ den(i,k) = -delp(i,j,k)/(grav*dz(i,j,k))
+ enddo
+ enddo
+ call gray_radiation(seconds, is, ie, km, agrid(is:ie,j,1), agrid(is,j,2), clouds(is,j), &
+ sst(is,j), t3(is:ie,j,1:km), ps(is,j), pe(is:ie,1:km+1,j), &
+ dz(is:ie,j,1:km), den, t_dt_rad, &
+ olr(is,j), lwu(is,j), lwd(is,j), sw_surf(is,j))
+ do k=1, km
+ do i=is,ie
+ t_dt(i,j,k) = t_dt(i,j,k) + t_dt_rad(i,k)
+ enddo
+ enddo
+ enddo
+ if ( print_diag ) then
+ if ( gray_rad ) then
+ olrm = g0_sum(olr, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ swab = g0_sum(sw_surf, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+
+ endif
+
+ if ( prog_low_cloud ) &
+ clds = g0_sum(clouds, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+
+ if( master ) then
+ if ( gray_rad ) then
+ write(*,*) 'Domain mean OLR', trim(gn), ' =', olrm
+ write(*,*) 'Domain mean SWA', trim(gn), ' =', swab
+ endif
+ if ( prog_low_cloud ) write(*,*) 'Domain mean low clouds fraction', trim(gn), ' =', clds
+ endif
+ endif
+
+ else
+
+! Prescribed (non-interating) heating/cooling rate:
+ rate_t = 1. / (tau_strat*86400. + pdt )
+! cooling = cooling_rate/sday
+
+
+ if ( cooling_rate > 1.e-5 ) then
+ do k=1, km
+ do j=js, je
+ do i=is, ie
+ cooling = cooling_rate*(f1+f2*cos(agrid(i,j,2)))/sday
+ if ( p3(i,j,k) >= 100.E2 ) then
+ t_dt(i,j,k) = t_dt(i,j,k) - cooling*min(1.0, (p3(i,j,k)-100.E2)/200.E2)
+ elseif ( do_t_strat ) then
+ if ( p3(i,j,k) < p_strat) then
+ t_dt(i,j,k) = t_dt(i,j,k) + (t_strat - t3(i,j,k))*rate_t
+ endif
+ endif
+ enddo
+ enddo
+ enddo ! k-loop
+ endif
+
+ endif
+
+
+ if ( strat_rad ) then
+! Solar heating above 100 mb:
+ heating = heating_rate / 86400.
+ do k=1, km
+ do j=js,je
+ do i=is,ie
+ if ( p3(i,j,k) < 100.E2 ) then
+ t_dt(i,j,k) = t_dt(i,j,k) + heating*(100.E2-p3(i,j,k))/100.E2
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+
+ do k=1, km
+ do j=js,je
+ do i=is,ie
+ t3(i,j,k) = pt(i,j,k) + pdt*t_dt(i,j,k)
+ enddo
+ enddo
+ enddo
+
+
+
+!---------------
+! Surface fluxes
+!---------------
+
+if( do_mon_obkv ) then
+
+ call qsmith(ie-is+1, je-js+1, 1, sst, ps, q3(is:ie,js:je,km,sphum), qs)
+ call qsmith(ie-is+1, je-js+1, 1, sst, ps, qs, qs) ! Iterate once
+
+! Need to save ustar in a restart file (sim_phys)
+! Because u_star is prognostic but not saved
+! simple physics will not reproduce across restarts.
+ if ( .not. allocated(u_star) ) then
+ allocate ( u_star(is:ie,js:je) )
+! u_star(:,:) = 1.E25 ! large enough to cause blowup if used
+ u_star(:,:) = 1.E-3
+ endif
+
+ call timing_on('mon_obkv')
+ call mon_obkv(zvir, ps, t3(is:ie,js:je, km), zfull(is:ie,js:je,km), &
+ rho, p3(is:ie,js:je,km), u3(is:ie,js:je,km), v3(is:ie,js:je,km), mo_u_mean, do_mo_fixed_cd, mo_cd, sst, &
+ qs, q3(is:ie,js:je,km,sphum), drag_t, drag_q, flux_t, flux_q, flux_u, flux_v, u_star, &
+ delm, pdt, mu, mo_t_fac, master)
+ call timing_off('mon_obkv')
+!---------------------------------------------------
+! delp/grav = delm = kg/m**2
+! watts = J/s = N*m/s = kg * m**2 / s**3
+! CP = J/kg/deg
+! flux_t = w/m**2 = J / (s*m**2)
+!---------------------------------------------------
+ do j=js,je
+ do i=is,ie
+ rate_u = flux_u(i,j)/delm(i,j)
+ u3(i,j,km) = u3(i,j,km) + pdt*rate_u
+ u_dt(i,j,km) = u_dt(i,j,km) + rate_u
+ rate_v = flux_v(i,j)/delm(i,j)
+ v3(i,j,km) = v3(i,j,km) + pdt*rate_v
+ v_dt(i,j,km) = v_dt(i,j,km) + rate_v
+ rate_t = flux_t(i,j)/(cp_air*delm(i,j))
+ t_dt(i,j,km) = t_dt(i,j,km) + rate_t
+ t3(i,j,km) = t3(i,j,km) + rate_t*pdt
+ rate_q = flux_q(i,j)/delm(i,j)
+ q_dt(i,j,km,sphum) = q_dt(i,j,km,sphum) + rate_q
+ q3(i,j,km,sphum) = q3(i,j,km,sphum) + rate_q*pdt
+ enddo
+ enddo
+endif
+
+!!$if (id_flux_t > 0) then
+!!$ used=send_data(id_flux_t, flux_t(:,:), Time)
+!!$endif
+!!$if (id_flux_q > 0) then
+!!$ used=send_data(id_flux_q, 2.5e6*flux_q(:,:), Time)
+!!$
+!!$endif
+!!$
+!!$if (id_drag_t > 0) then
+!!$ used=send_data(id_drag_t, drag_t(:,:), Time)
+!!$endif
+!!$if (id_drag_q > 0) then
+!!$ used=send_data(id_drag_q, drag_q(:,:), Time)
+!!$
+!!$endif
+
+if ( zero_winds ) then
+
+ if (grid_type /= 4) then
+ call mpp_error(FATAL, "fv_phys::GFDL_SIM_PHYS: zero_winds only works with doubly-periodic domain (grid_type = 4).")
+ endif
+
+! Zero out (doubly periodic) domain averaged winds with time-scale tau_zero:
+! This loop can not be openMP-ed
+ do k=1, km
+ utmp(k) = g0_sum(u3(is,js,k), is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ vtmp(k) = g0_sum(v3(is,js,k), is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+#ifdef PRINT_W
+ if ( master ) then
+ if( sqrt(utmp(k)**2+vtmp(k)**2) > 1. ) then
+ write(*,*) k, 'Domain avg winds', trim(gn), '=', utmp, vtmp
+ endif
+ endif
+#endif
+ enddo
+
+ rate_w = min(1., 1./(tau_zero*86400.))
+!$omp parallel do default(shared)
+ do k=1, km
+ do j=js,je
+ do i=is,ie
+ u_dt(i,j,k) = u_dt(i,j,k) - utmp(k) * rate_w
+ v_dt(i,j,k) = v_dt(i,j,k) - vtmp(k) * rate_w
+ enddo
+ enddo
+ enddo
+
+endif
+
+ if ( do_abl ) then
+! ABL: vertical diffusion:
+ if (.not. do_mon_obkv ) then
+ do j=js,je
+ do i=is,ie
+ mu(i,j) = -sqrt(gridstruct%area(i,j)/area_ref)*dz(i,j,km)/tau_difz
+ enddo
+ enddo
+ endif
+
+ call pbl_diff(hydrostatic, pdt, is, ie, js, je, ng, km, nq, u3, v3, t3, &
+ w, q3, delp, p3, pe, sst, mu, dz, u_dt, v_dt, t_dt, q_dt, &
+ gridstruct%area, print_diag, Time )
+ endif
+
+
+ if ( mixed_layer ) then
+ do j=js, je
+ do i=is, ie
+#ifdef RAIN_FLUX
+ !rain, etc. never defined
+ precip = (rain(i,j)+snow(i,j)+ice(i,j)+graup(i,j)) / 86400.
+#ifdef NO_WET_T
+ if ( precip > 0. ) then
+ tmp = -delp(i,j,km)/(grav*dz(i,j,km))
+ wet_t(i,j) = wet_bulb(q3(i,j,km,1), t3(i,j,km), tmp)
+ else
+ wet_t(i,j) = t3(i,j,km)
+ endif
+ rflux(i,j) = c_liq*precip*(sst(i,j)-wet_t(i,j))
+#else
+ rflux(i,j) = c_liq*precip*(sst(i,j)-t3(i,j,km))
+#endif
+#else
+ rflux(i,j) = 0.0
+#endif
+ qflux(i,j) = hlv*flux_q(i,j)
+ enddo
+ enddo
+
+ if ( gray_rad ) then
+ do j=js, je
+ do i=is, ie
+ sst(i,j) = sst(i,j)+pdt*(sw_surf(i,j) + lwd(i,j) - rflux(i,j) &
+ - flux_t(i,j) - qflux(i,j) - lwu(i,j))/ml_c0
+ enddo
+ enddo
+ if ( print_diag ) then
+ net_rad = sw_surf + lwd - lwu
+ hflux1 = g0_sum(net_rad, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ net_rad = net_rad - rflux - flux_t - qflux
+ hflux2 = g0_sum(net_rad, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ if(master) write(*,*) 'Net_flux', trim(gn), '=',hflux2, 'net_rad', trim(gn), '=', hflux1
+ endif
+ else
+! Unit flux_q, moisture flux (kg/sm^2)
+ do j=js, je
+ do i=is, ie
+ sst(i,j) = sst(i,j) - pdt*(rflux(i,j) + flux_t(i,j) + qflux(i,j))/ml_c0
+ enddo
+ enddo
+ endif
+ if ( sst_restore_timescale > 1.e-7 ) then
+ rate_t = pdt / (sst_restore_timescale*86400.)
+ do j=js, je
+ do i=is, ie
+ sst(i,j) = (sst(i,j)+rate_t*ts0(i,j)) / (1.+rate_t)
+ enddo
+ enddo
+ endif
+
+ if ( print_diag ) then
+ do j=js, je
+ do i=is, ie
+ wet_t(i,j) = t3(i,j,km) - wet_t(i,j)
+ enddo
+ enddo
+ call prt_maxmin('WETB_DT:', wet_t, is, ie, js, je, 0, 1, 1.0)
+ call prt_maxmin('Mixed-layer SST:', sst, is, ie, js, je, 0, 1, 1.0)
+ sstm = g0_sum(sst, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ if(master) write(*,*) 'Domain mean SST', trim(gn), '=', sstm
+! Fluxes:
+ hflux1 = g0_sum(rflux, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ hflux2 = g0_sum(qflux, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ hflux3 = g0_sum(flux_t, is, ie, js, je, 0, gridstruct%area(is:ie,js:je), 1)
+ if(master) write(*,*) 'RainF', trim(gn), '=',hflux1, 'LatentF', trim(gn), '=', hflux2, 'SenHF', trim(gn), '=', hflux3
+ call prt_maxmin('Rain_F', rflux, is, ie, js, je, 0, 1, 1.0)
+ call prt_maxmin('LatH_F', qflux, is, ie, js, je, 0, 1, 1.0)
+ call prt_maxmin('SenH_F', flux_t, is, ie, js, je, 0, 1, 1.0)
+ endif
+
+ endif
+
+ if (id_qflux > 0) used=send_data(id_qflux, qflux, time)
+ if (id_hflux > 0) used=send_data(id_hflux, flux_t, time)
+
+
+ end subroutine GFDL_sim_phys
+
+
+ subroutine pbl_diff(hydrostatic, dt, is, ie, js, je, ng, km, nq, ua, va, &
+ ta, w, q, delp, pm, pe, ts, mu, dz, udt, vdt, tdt, qdt, &
+ area, print_diag, Time )
+ logical, intent(in):: hydrostatic
+ integer, intent(in):: is, ie, js, je, ng, km, nq
+ real, intent(in):: dt
+ real, intent(in), dimension(is:ie,js:je):: ts, mu
+ real, intent(in), dimension(is:ie,js:je,km):: dz, pm
+ real, intent(in):: pe(is-1:ie+1 ,1:km+1,js-1:je+1)
+ real, intent(inout), dimension(is:ie,js:je,km):: ua, va, ta, tdt
+ real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: w, udt, vdt, delp
+ real, intent(inout), dimension(is:ie,js:je,km,nq):: q, qdt
+ logical, intent(in):: print_diag
+ real, intent(in) :: area(is-ng:ie+ng,js-ng:je+ng)
+ type(time_type), intent(in) :: Time
+! Local:
+ real, dimension(is:ie,js:je):: pblh
+ real, dimension(is:ie,km+1):: gh
+ real, dimension(is:ie,km):: nu, a, f, r, q2, den
+ real, dimension(is:ie,km):: gz, hd, te
+ real, dimension(is:ie):: kz
+ real, parameter:: mu_min = 1.E-5 ! ~ molecular viscosity
+ real, parameter:: ustar2 = 1.E-4
+ integer:: n, i, j, k
+ real:: cv, rcv, rdt, tmp, tvm, tv_surf, surf_h, rin
+ logical:: used
+
+ cv = cp_air - rdgas
+ rcv = 1./cv
+ rdt = 1./dt
+
+! Put opnmp loop here
+ do 1000 j=js, je
+
+ do i=is, ie
+ gh(i,km+1) = 0.
+ pblh(i,j) = 0.
+ enddo
+ do k=km, 1, -1
+ do i=is, ie
+ gh(i,k) = gh(i,k+1) - dz(i,j,k)
+ enddo
+ enddo
+
+! Locate PBL top (m)
+ do 125 i=is, ie
+ tv_surf = ts(i,j)*(1.+zvir*q(i,j,km,sphum))
+ do k=km, km/4,-1
+ tvm = ta(i,j,k)*(1.+zvir*q(i,j,k,sphum)-q(i,j,k,liq_wat)- &
+ q(i,j,k,ice_wat)-q(i,j,k,snowwat)-q(i,j,k,rainwat)-q(i,j,k,graupel))
+ tvm = tvm*(pe(i,km+1,j)/pm(i,j,k))**kappa
+ rin = grav*(gh(i,k+1)-0.5*dz(i,j,k))*(tvm-tv_surf) / ( 0.5*(tv_surf+tvm)* &
+ (ua(i,j,k)**2+va(i,j,k)**2+ustar2) )
+ if ( rin > 1. ) then
+ pblh(i,j) = gh(i,k+1)
+ goto 125
+ endif
+ enddo
+125 continue
+
+ do k=km, 1, -1
+ do i=is, ie
+ if ( gh(i,k)>6.E3 .or. (pblh(i,j) < -0.5*dz(i,j,km)) ) then
+ nu(i,k) = mu_min
+ else
+ kz(i) = 0.5*mu(i,j)*gh(i,km)
+ surf_h = abl_s_fac*pblh(i,j)
+ if ( gh(i,k) <= surf_h) then
+ kz(i) = mu(i,j)*gh(i,k)
+ nu(i,k) = kz(i)
+ elseif (gh(i,k) <= pblh(i,j)) then
+! Use Dargan's form:
+ nu(i,k) = kz(i)*gh(i,k)/surf_h*(1.-(gh(i,k)-surf_h)/(pblh(i,j)-surf_h))**2
+ else
+ nu(i,k) = mu_min
+ endif
+ endif
+ enddo
+ enddo
+
+ do k=1,km-1
+ do i=is, ie
+ a(i,k) = -nu(i,k) / ( 0.5*(dz(i,j,k)+dz(i,j,k+1)) )
+ enddo
+ enddo
+ do i=is, ie
+ a(i,km) = 0.
+ enddo
+
+ if ( .not. hydrostatic ) then
+ do k=1, km
+ do i=is,ie
+ gz(i,k) = grav*(gh(i,k+1) - 0.5*dz(i,j,k))
+ tmp = gz(i,k) + 0.5*(ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2)
+ tvm = ta(i,j,k)*(1.+zvir*q(i,j,k,sphum))
+ hd(i,k) = cp_air*tvm + tmp
+ te(i,k) = cv*tvm + tmp
+ enddo
+ enddo
+ endif
+
+! u-diffusion
+ do k=1,km
+ do i=is, ie
+ den(i,k) = delp(i,j,k)/dz(i,j,k)
+ q2(i,k) = ua(i,j,k)*den(i,k)
+ f(i,k) = -dz(i,j,k)*rdt
+ r(i,k) = -f(i,k)*q2(i,k)
+ enddo
+ enddo
+ call trid_dif2(a, f, r, q2, is, ie, km)
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = q2(i,k) / den(i,k)
+ udt(i,j,k) = udt(i,j,k) + rdt*(q2(i,k) - ua(i,j,k))
+ ua(i,j,k) = q2(i,k)
+ enddo
+ enddo
+!---
+! v-diffusion
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = va(i,j,k)*den(i,k)
+ r(i,k) = -f(i,k)*q2(i,k)
+ enddo
+ enddo
+ call trid_dif2(a, f, r, q2, is, ie, km)
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = q2(i,k) / den(i,k)
+ vdt(i,j,k) = vdt(i,j,k) + rdt*(q2(i,k) - va(i,j,k))
+ va(i,j,k) = q2(i,k)
+ enddo
+ enddo
+!---
+ if ( .not. hydrostatic ) then
+! w-diffusion
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = w(i,j,k) * den(i,k)
+ r(i,k) = -f(i,k)*q2(i,k)
+ enddo
+ enddo
+ call trid_dif2(a, f, r, q2, is, ie, km)
+ do k=1,km
+ do i=is, ie
+ w(i,j,k) = q2(i,k) / den(i,k)
+ enddo
+ enddo
+ endif
+!--- micro-physics
+ do n=1, nq
+! if ( (n.ne.rainwat) .and. (n.ne.snowwat) .and. (n.ne.graupel) .and. (n.ne.cld_amt) ) then
+ if ( n.ne.cld_amt ) then
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = q(i,j,k,n)*den(i,k)
+ r(i,k) = -f(i,k)*q2(i,k)
+ enddo
+ enddo
+ call trid_dif2(a, f, r, q2, is, ie, km)
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = q2(i,k) / den(i,k)
+ qdt(i,j,k,n) = qdt(i,j,k,n) + rdt*(q2(i,k) - q(i,j,k,n))
+ q(i,j,k,n) = q2(i,k)
+ enddo
+ enddo
+ endif
+ enddo
+
+! Diffusion of dry static energy
+ if ( .not. hydrostatic ) then
+ do k=1,km
+ do i=is, ie
+ q2(i,k) = hd(i,k)*den(i,k)
+ r(i,k) = -f(i,k)*q2(i,k)
+ enddo
+ enddo
+ call trid_dif2(a, f, r, q2, is, ie, km)
+ do k=1,km
+ do i=is, ie
+ te(i,k) = te(i,k) + q2(i,k)/den(i,k) - hd(i,k)
+ q2(i,k) = rcv*(te(i,k)-gz(i,k)-0.5*(ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2)) &
+ / (1.+zvir*q(i,j,k,sphum))
+ tdt(i,j,k) = tdt(i,j,k) + rdt*(q2(i,k) - ta(i,j,k))
+ ta(i,j,k) = q2(i,k)
+ enddo
+ enddo
+ endif
+
+1000 continue
+
+ if ( print_diag ) then
+ tmp = g0_sum(pblh, is, ie, js, je, 0, area(is:ie,js:je), 1)
+ if (master) write(*,*) 'Mean PBL H (km)', trim(gn), '=', tmp*0.001
+ call prt_maxmin('PBLH(km)', pblh, is, ie, js, je, 0, 1, 0.001)
+! call prt_maxmin('K_ABL (m^2/s)', mu, is, ie, js, je, 0, 1, 1.)
+ endif
+
+ if (id_pblh > 0) used=send_data(id_pblh, pblh, time)
+
+ end subroutine pbl_diff
+
+ subroutine trid_dif2(a, v, r, q, i1, i2, km)
+ integer, intent(in):: i1, i2
+ integer, intent(in):: km ! vertical dimension
+ real, intent(in), dimension(i1:i2,km):: a, v, r
+ real, intent(out),dimension(i1:i2,km):: q
+! Local:
+ real:: gam(i1:i2,km)
+ real:: bet(i1:i2)
+ integer:: i, k
+
+! Zero diffusive fluxes at top and bottom:
+! top: k=1
+ do i=i1,i2
+ bet(i) = -(v(i,1) + a(i,1))
+ q(i,1) = r(i,1) / bet(i)
+ enddo
+
+ do k=2,km
+ do i=i1,i2
+ gam(i,k) = a(i,k-1) / bet(i)
+ bet(i) = -( a(i,k-1)+v(i,k)+a(i,k) + a(i,k-1)*gam(i,k))
+! a(i,km) = 0
+ q(i,k) = ( r(i,k) - a(i,k-1)*q(i,k-1) ) / bet(i)
+ enddo
+ 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
+
+ end subroutine trid_dif2
+
+
+ subroutine fv_nudge( npz, is, ie, js, je, ng, u, v, w, delz, delp, pt, dt, hydrostatic)
+!
+! Nudge the prognostic varaibles toward the IC
+! This is only useful for generating balanced steady state IC
+
+ real , INTENT(IN ) :: dt
+ integer, INTENT(IN ) :: npz, is, ie, js, je, ng
+ logical, INTENT(IN ) :: hydrostatic
+ real , INTENT(INOUT) :: u(is-ng:ie+ ng,js-ng:je+1+ng,npz)
+ real , INTENT(INOUT) :: v(is-ng:ie+1+ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: w(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: delp(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: delz(is: ie ,js: je ,npz)
+ real , INTENT(INOUT) :: pt(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real c_w, c_p, c_t
+ integer i, j, k
+
+ if ( .not. nudge_initialized ) then
+
+ if( tau_winds > 0. ) then
+ allocate ( u0(is:ie, js:je+1,npz) )
+ allocate ( v0(is:ie+1,js:je ,npz) )
+ do k=1,npz
+ do j=js,je+1
+ do i=is,ie
+ u0(i,j,k) = u(i,j,k)
+ enddo
+ enddo
+ do j=js,je
+ do i=is,ie+1
+ v0(i,j,k) = v(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ if( tau_press > 0. ) then
+ allocate ( dp(is:ie,js:je,npz) )
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ dp(i,j,k) = delp(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ if( tau_temp > 0. ) then
+ allocate ( t0(is:ie,js:je,npz) )
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ t0(i,j,k) = pt(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ nudge_initialized = .true.
+ if ( is_master() ) write(*,*) 'Nudging of IC initialized.'
+ return
+ endif
+
+! Nudge winds to initial condition:
+
+ do k=1,npz
+ if( tau_winds > 0. ) then
+ c_w = dt/tau_winds
+ do j=js,je+1
+ do i=is,ie
+ u(i,j,k) = (u(i,j,k)+c_w*u0(i,j,k)) / (1.+c_w)
+ enddo
+ enddo
+ do j=js,je
+ do i=is,ie+1
+ v(i,j,k) = (v(i,j,k)+c_w*v0(i,j,k)) / (1.+c_w)
+ enddo
+ enddo
+ if ( .not.hydrostatic ) then
+ do j=js,je
+ do i=is,ie+1
+ w(i,j,k) = w(i,j,k) / (1.+c_w)
+ enddo
+ enddo
+ endif
+ endif
+ if ( tau_temp > 0. ) then
+ c_t = dt/tau_temp
+ do j=js,je
+ do i=is,ie
+ pt(i,j,k) = (pt(i,j,k)+c_t*t0(i,j,k)) / (1.+c_t)
+ enddo
+ enddo
+ if ( .not.hydrostatic ) then
+! delz
+ endif
+ endif
+
+ if ( tau_press > 0. ) then
+ c_p = dt/tau_press
+ do j=js,je
+ do i=is,ie
+ delp(i,j,k) = (delp(i,j,k)+c_p*dp(i,j,k)) / (1.+c_p)
+ enddo
+ enddo
+ endif
+ enddo
+
+ end subroutine fv_nudge
+
+ subroutine gray_radiation(sec, is, ie, km, lon, lat, clouds, ts, temp, ps, phalf, &
+ delz, rho, t_dt, olr, lwu, lwd, sw_surf)
+
+! Gray-Radiation algorithms based on Frierson, Held, and Zurita-Gotor, 2006 JAS
+! Note: delz is negative
+! Coded by S.-J. Lin, June 20, 2012
+ integer, intent(in):: sec
+ integer, intent(in):: is, ie, km
+ real, dimension(is:ie):: ts
+ real, intent(in), dimension(is:ie):: lon, lat
+ real, intent(in), dimension(is:ie,km):: temp, phalf, delz, rho
+ real, intent(in), dimension(is:ie):: ps, clouds
+ real, intent(out), dimension(is:ie,km):: t_dt
+ real, intent(out), dimension(is:ie):: olr, lwu, lwd, sw_surf
+! local:
+ real, dimension(is:ie,km+1):: ur, dr
+ real, dimension(is:ie,km+1):: tau, lw
+ real, dimension(is:ie,km):: delt, b
+ real, dimension(is:ie):: tau0
+ real, parameter:: t0e = 8. ! Dargan value= 6.
+ real, parameter:: t0p = 1.5
+ real, parameter:: fl = 0.1
+ real, parameter:: sbc = 5.6734E-8
+ real, parameter:: cp = 1004.64
+ real:: albd = 0.
+ real:: sig, sw_rad, solar_ang
+ integer:: i, k
+
+ do i=is, ie
+ tau0(i) = t0e + (t0p-t0e) * sin(lat(i))**2
+ enddo
+! Annual & global mean solar_abs ~ 0.25 * 1367 * ( 1-0.3) ~ 240
+! Earth cross section/total_area = 0.25; 0.3 = Net cloud reflection and atm abs
+
+ if ( diurnal_cycle ) then
+ sw_rad = solar_constant*(1. - sw_abs)
+ do i=is, ie
+ solar_ang = 2*pi*real(sec)/86400. + lon(i)
+ sw_surf(i) = sw_rad*(1.-clouds(i))*cos(lat(i))*max(0.,cos(solar_ang))
+ sw_surf(i) = sw_surf(i)*(1.-albd)
+ enddo
+ else
+ sw_rad = (1./pi) * solar_constant*(1. - sw_abs)
+ do i=is, ie
+ sw_surf(i) = sw_rad*(1.-clouds(i))*max(0.,cos(lat(i)-shift_n*deg2rad))*(1.-albd)
+ enddo
+ endif
+
+ do k=1, km+1
+ do i=is, ie
+#ifndef STRAT_OFF
+! Dargan version:
+ sig = phalf(i,k)/ps(i)
+ tau(i,k) = tau0(i)*( sig*fl + (1.-fl)*sig**4 )
+#else
+! SJL: less cooling for the stratosphere
+ tau(i,k) = tau0(i) * (phalf(i,k)/ps(i))**4
+#endif
+ enddo
+ enddo
+ do k=1, km
+ do i=is, ie
+ delt(i,k) = tau(i,k+1) - tau(i,k)
+ b(i,k) = sbc*temp(i,k)**4
+ enddo
+ enddo
+
+! top down integration:
+ do i=is, ie
+ dr(i,1) = 0.
+ enddo
+ do k=1, km
+ do i=is, ie
+ dr(i,k+1) = (dr(i,k)+delt(i,k)*(b(i,k)-0.5*dr(i,k)))/(1.+0.5*delt(i,k))
+ enddo
+ enddo
+! Bottom up
+ do i=is, ie
+ ur(i,km+1) = sbc*ts(i)**4
+ lwu(i) = ur(i,km+1)
+ enddo
+ do k=km, 1, -1
+ do i=is, ie
+ ur(i,k) = (ur(i,k+1)+delt(i,k)*(b(i,k)-0.5*ur(i,k+1)))/(1.+0.5*delt(i,k))
+ enddo
+ enddo
+
+! Compute net long wave cooling rate:
+ do k=1, km+1
+ do i=is, ie
+ lw(i,k) = ur(i,k) - dr(i,k)
+ enddo
+ enddo
+ do k=1, km
+ do i=is, ie
+ t_dt(i,k) = (lw(i,k) - lw(i,k+1))/(cp*rho(i,k)*delz(i,k))
+ enddo
+ enddo
+
+ do i=is, ie
+ olr(i) = ur(i,1)
+ lwd(i) = dr(i,km+1)
+ enddo
+
+ end subroutine gray_radiation
+
+
+
+ subroutine get_low_clouds( is,ie, js,je, km, ql, qi, qa, clouds )
+ integer, intent(in):: is,ie, js,je, km
+ real, intent(in), dimension(is:ie,js:je,km):: ql, qi, qa
+ real, intent(out), dimension(is:ie,js:je):: clouds
+ integer:: i, j, k
+
+ do j=js, je
+ do i=is, ie
+ clouds(i,j) = 0.
+ do k=km/2,km
+ if ( (ql(i,j,k)>1.E-5 .or. qi(i,j,k)>2.e-4) .and. qa(i,j,k)>1.E-3 ) then
+! Maximum overlap
+ clouds(i,j) = max(clouds(i,j), qa(i,j,k))
+ endif
+ enddo
+ clouds(i,j) = min( 1., clouds(i,j) )
+ enddo
+ enddo
+
+ end subroutine get_low_clouds
+
+ subroutine fv_phys_init(is, ie, js, je, km, nwat, ts, pt, time, axes, lat)
+ integer, intent(IN) :: is, ie, js, je, km
+ integer, intent(IN) :: nwat
+ real, INTENT(inout):: ts(is:ie,js:je)
+ real, INTENT(in):: pt(is:ie,js:je,km)
+ real, INTENT(IN) :: lat(is:ie,js:je)
+ integer, intent(in) :: axes(4)
+ type(time_type), intent(in) :: time
+ integer :: unit, ierr, io, i, j
+ real:: total_area
+
+ master = is_master()
+
+! ----- read and write namelist -----
+ if ( file_exist('input.nml')) then
+ unit = open_namelist_file ('input.nml')
+ read (unit, nml=sim_phys_nml, iostat=io, end=10)
+ ierr = check_nml_error(io,'sim_phys_nml')
+
+ if (do_K_warm_rain) then
+ read (unit, nml=Kessler_sim_phys_nml, iostat=io, end=10)
+ ierr = check_nml_error(io,'Kessler_sim_phys_nml')
+ endif
+
+ if (do_GFDL_sim_phys) then
+ read (unit, nml=GFDL_sim_phys_nml, iostat=io, end=10)
+ ierr = check_nml_error(io,'GFDL_sim_phys_nml')
+ endif
+
+ if (do_reed_sim_phys) then
+ read (unit, nml=reed_sim_phys_nml, iostat=io, end=10)
+ ierr = check_nml_error(io,'reed_sim_phys_nml')
+ endif
+
+ 10 call close_file (unit)
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A NOTE REGARDING FV_PHYS DIAGNOSTIC FIELDS !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Please note that these fields are registered !
+! as part of the 'sim_phys' module, **NOT** !
+! as part of the 'dynamics' module. If you !
+! add these fields to your diag_table be SURE !
+! to use 'sim_phys' as your module (first !
+! column) name!! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ id_rain = register_diag_field (mod_name, 'rain', axes(1:2), time, &
+ 'rain_sim_phys', 'mm/day', missing_value=missing_value )
+ id_rain_k = register_diag_field (mod_name, 'rain_k', axes(1:2), time, &
+ 'accumuated rain', 'mm/day', missing_value=missing_value )
+ if (do_K_warm_rain) then
+ id_vr_k = register_diag_field (mod_name, 'vr_k', axes(1:3), time, &
+ 'Terminal fall V_Kessler', 'm/s', missing_value=missing_value )
+ endif
+ if (do_abl) then
+ id_pblh = register_diag_field(mod_name, 'pblh', axes(1:2), time, &
+ 'PBL Height', 'm', missing_value=missing_value)
+ endif
+
+ if (id_rain_k > 0) then
+ allocate ( prec_total(is:ie,js:je) )
+ prec_total(:,:) = 0.
+ endif
+
+ if (do_GFDL_sim_phys) then
+ id_qflux = register_diag_field(mod_name, 'qflux', axes(1:3), time, &
+ 'Physics latent heat flux', 'J/m**2/s', missing_value=missing_value)
+ id_hflux = register_diag_field(mod_name, 'hflux', axes(1:3), time, &
+ 'Physics sensible heat flux', 'J/m**2/s', missing_value=missing_value)
+ endif
+
+ id_dudt = register_diag_field( mod_name, 'dudt', axes(1:3), time, &
+ '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)
+ 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, &
+ 'Physics Q tendency', 'kg/kg/s', missing_value=missing_value)
+
+! Initialize mixed layer ocean model
+ if( .not. allocated ( ts0) ) allocate ( ts0(is:ie,js:je) )
+
+ if ( uniform_sst ) then
+ ts0(:,:) = sst0
+ else
+ if (sst_type == 1) then !SST in equib with lower atmosphere
+ do j=js,je
+ do i=is,ie
+ ts0(i,j) = pt(i,j,km)
+ enddo
+ enddo
+ else
+ do j=js,je
+ do i=is,ie
+ ts0(i,j) = 270.5 + 32.*exp( -((lat(i,j)-shift_n*deg2rad)/(pi/3.))**2 )
+ enddo
+ enddo
+ endif
+ endif
+ do j=js,je
+ do i=is,ie
+ ts(i,j) = ts0(i,j)
+ enddo
+ enddo
+
+
+
+ call prt_maxmin('TS initialized:', ts, is, ie, js, je, 0, 1, 1.0)
+ call qs_wat_init
+
+ if ( master ) then
+ total_area = 4.*pi*radius**2
+ write(*,*) 'Total surface area', trim(gn), ' =', total_area
+ endif
+
+ sim_phys_initialized = .true.
+
+ end subroutine fv_phys_init
+
+
+ real function g0_sum(p, ifirst, ilast, jfirst, jlast, ngc, area, mode)
+ use mpp_mod, only: mpp_sum
+ real, save :: global_area
+
+! Fast version of globalsum
+ integer, intent(IN) :: ifirst, ilast
+ integer, intent(IN) :: jfirst, jlast, ngc
+ integer, intent(IN) :: mode ! if ==1 divided by area
+ real, intent(IN) :: p(ifirst:ilast,jfirst:jlast) ! field to be summed
+ real, intent(IN) :: area(ifirst-ngc:ilast+ngc,jfirst-ngc:jlast+ngc)
+ integer :: i,j
+ real gsum
+
+!-------------------------
+! Quick local sum algorithm
+!-------------------------
+ if ( .not. g0_sum_initialized ) then
+ allocate (l_area(ifirst:ilast,jfirst:jlast))
+ global_area = 0.
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+ global_area = global_area + area(i,j)
+ l_area(i,j) = area(i,j)
+ enddo
+ enddo
+ call mpp_sum(global_area)
+! if ( mpp_pe().eq.mpp_root_pe() ) write(*,*) 'Global Area=',global_area
+ g0_sum_initialized = .true.
+ end if
+
+ gsum = 0.
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+ gsum = gsum + p(i,j)*l_area(i,j)
+ enddo
+ enddo
+ call mpp_sum(gsum)
+
+ if ( mode==1 ) then
+ g0_sum = gsum / global_area
+ else
+ g0_sum = gsum
+ endif
+
+! Make it reproducible by truncating to 32-bit precision:
+ g0_sum = real(g0_sum, 4)
+
+ 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)
+ 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
+ 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
+ real, INTENT(INOUT):: pk(is:ie, js:je, km+1)
+ real, INTENT(INOUT) :: pe(is-1:ie+1,1:km+1,js-1:je+1)
+ real, INTENT(INOUT) :: peln(is:ie,1:km+1,js:je)
+ real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng):: ps
+ real, intent(out), dimension(is:ie,js:je):: rain
+! Local:
+ real, parameter:: qv_min = 1.e-7
+ real, parameter:: qc_min = 1.e-8
+ real, allocatable:: vr_k(:,:,:)
+ real, dimension(km):: t1, q0, q1, q2, q3, zm, drym, dm, dz, fac1, fac2
+ real, dimension(km):: vr, qa, qb, qc, m1, u1, v1, w1, dgz, cvn, cvm
+ real, dimension(km):: rho
+ real, dimension(km+1):: ze
+ real:: sdt, qcon, rgrav
+ integer i,j,k,n
+ logical used
+
+ allocate ( vr_k(is:ie,js:je,km) )
+
+ sdt = dt/real(K_cycle)
+ rgrav = 1./grav
+
+!$omp parallel do default(shared) private(ze,zm,rho,fac1,fac2,qcon,dz,vr,dgz,cvm,cvn,m1,u1,v1,w1,q0,qa,qb,qc,t1,dm,q1,q2,q3,drym)
+ do j=js, je
+
+ do i=is, ie
+ rain(i,j) = 0.
+ enddo
+ do i=is, ie
+ if (hydrostatic) then
+ do k=1,km
+ dz(k) = rdgas*rgrav*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum)) * &
+ (peln(i,k+1,j)-peln(i,k,j))
+ enddo
+ else
+ do k=1,km
+ dz(k) = -delz(i,j,k)
+ enddo
+ endif
+ do k=1,km
+! Moist air mass:
+ dm(k) = dp(i,j,k) !Pa = kg * (g/dA)
+! Tracer mass:
+ qa(k) = q(i,j,k,sphum) !kg/kg
+ qb(k) = q(i,j,k,liq_wat)
+ qc(k) = q(i,j,k,rainwat)
+ q1(k) = qa(k) * dm(k) !kg * (g/dA)
+ q2(k) = qb(k) * dm(k)
+ q3(k) = qc(k) * dm(k)
+!-------------------------------------------
+ qcon = q2(k) + q3(k)
+ if ( qcon > 0. ) then
+! Fix negative condensates if for some reason it existed:
+ if ( q2(k) < 0. ) then
+ q2(k) = 0.
+ q3(k) = qcon
+ elseif ( q3(k) < 0. ) then
+ q3(k) = 0.
+ q2(k) = qcon
+ endif
+ endif
+!-------------------------------------------
+! Dry air mass per unit area
+ drym(k) = dm(k) - (q1(k)+q2(k)+q3(k)) ! kg * ( g/dA)
+ !dz(k) = -delz(i,j,k) !invalid for hydrostatic; not used unless EXP_MP enabled
+! Dry air density
+! Convert to dry mixing ratios:
+ qa(k) = q1(k) / drym(k) ! kg/kg
+ qb(k) = q2(k) / drym(k)
+ qc(k) = q3(k) / drym(k)
+! Make the fields large enough to prevent problems in the k-scheme:
+ q1(k) = max(qa(k), qv_min)
+ q2(k) = max(qb(k), qc_min)
+ q3(k) = max(qc(k), qc_min)
+! Differences (to be added back to conserve mass)
+ qa(k) = q1(k) - qa(k) ! kg/kg
+ qb(k) = q2(k) - qb(k)
+ qc(k) = q3(k) - qc(k)
+!----
+ t1(k) = pt(i,j,k)
+ u1(k) = u(i,j,k)
+ v1(k) = v(i,j,k)
+ w1(k) = w(i,j,k)
+ enddo
+
+ do n=1,K_cycle
+! Calling the K scheme, sub-cycling if time step is too large for sedimentation/evap
+ do k=1,km
+! For condensate transport
+ qcon = q2(k) + q3(k)
+ q0(k) = q1(k) + qcon ! total water kg/kg (dry)
+ if ( qcon > 0. ) then
+! Fix negative condensates if for some reason it existed:
+ if ( q2(k) < 0. ) then
+ q2(k) = 0.
+ q3(k) = qcon
+ elseif ( q3(k) < 0. ) then
+ q3(k) = 0.
+ q2(k) = qcon
+ endif
+ endif
+ enddo
+ call kessler_imp( t1, q1, q2, q3, vr, drym, sdt, dz, km )
+
+! 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)
+ do k=2,km
+ m1(k) = m1(k-1) + drym(k)*(q0(k)-(q1(k)+q2(k)+q3(k)))
+ enddo
+! rain(i,j) = rain(i,j) + max(0., m1(km)) / (grav*sdt)
+ rain(i,j) = rain(i,j) + max(0., m1(km)) / grav ! kg / dA
+
+ if ( K_sedi_transport ) then
+! Momentum transport
+ if ( do_K_sedi_w ) then
+! Momentum conservation: (note vr is downward)
+!!! w1(1) = (dm(1)*w1(1)+m1(1)*vr(1))/(dm(1)-m1(1))
+ do k=2, km
+ w1(k) = (dm(k)*w1(k) - m1(k-1)*vr(k-1) + m1(k)*vr(k)) / &
+ (dm(k)+m1(k-1)-m1(k))
+ enddo
+ endif
+ do k=2,km
+! dm is the total moist mass before terminal fall
+ fac1(k) = m1(k-1) / (dm(k)+m1(k-1))
+ fac2(k) = 1. - fac1(k)
+ u1(k) = fac1(k)*u1(k-1) + fac2(k)*u1(k)
+ v1(k) = fac1(k)*v1(k-1) + fac2(k)*v1(k)
+!!! w1(k) = fac1(k)*w1(k-1) + fac2(k)*w1(k)
+ enddo
+ endif
+
+ if ( do_K_sedi_heat ) then
+! Heat transport
+ do k=1, km
+ dgz(k) = -0.5*grav*delz(i,j,k) ! > 0
+ cvn(k) = cv_air + q1(k)*cv_vap + (q2(k)+q3(k))*c_liq
+ enddo
+! cvm(1) = cvn(1) + c_liq*m1(1)/drym(1)
+! t1(1) = (drym(1)*cvm(1)*t1(1) + m1(1)*dgz(1) ) / (drym(1)*cvn(1) + m1(1)*c_liq)
+ do k=2, km
+ cvm(k) = cvn(k) - c_liq*(m1(k-1)-m1(k))/drym(k)
+ t1(k) = ( drym(k)*cvm(k)*t1(k) + m1(k-1)*c_liq*t1(k-1) + dgz(k)*(m1(k-1)+m1(k)) ) &
+ / ( drym(k)*cvn(k) + m1(k)*c_liq )
+ enddo
+ endif
+ enddo ! K_cycle
+
+ if ( id_vr_k>0 ) then
+ do k=1, km
+ vr_k(i,j,k) = vr(k)
+ enddo
+ endif
+
+ do k=1,km
+ u_dt(i,j,k) = u_dt(i,j,k) + (u1(k)-u(i,j,k))/dt
+ v_dt(i,j,k) = v_dt(i,j,k) + (v1(k)-v(i,j,k))/dt
+ u(i,j,k) = u1(k)
+ v(i,j,k) = v1(k)
+ w(i,j,k) = w1(k)
+ pt(i,j,k) = t1(k)
+ ! Convert back to moist mixing ratios
+ q1(k) = (q1(k)+qa(k)) * drym(k)
+ q2(k) = (q2(k)+qb(k)) * drym(k)
+ q3(k) = (q3(k)+qc(k)) * drym(k)
+ ! Update total air mass:
+ dp(i,j,k) = drym(k) + q1(k)+q2(k)+q3(k)
+ ! Update tracers:
+ q(i,j,k, sphum) = q1(k) / dp(i,j,k)
+ q(i,j,k,liq_wat) = q2(k) / dp(i,j,k)
+ q(i,j,k,rainwat) = q3(k) / dp(i,j,k)
+ enddo
+ enddo ! i-loop
+
+ ! Adjust pressure fields:
+ do k=2,km+1
+ do i=is,ie
+ pe(i,k,j) = pe(i,k-1,j) + dp(i,j,k-1)
+ peln(i,k,j) = log( pe(i,k,j) )
+ pk(i,j,k) = exp( kappa*peln(i,k,j) )
+ enddo
+ enddo
+ do i=is,ie
+ ps(i,j) = pe(i,km+1,j)
+ enddo
+
+ enddo ! j-loop
+
+ if ( id_vr_k>0 ) then
+ used = send_data(id_vr_k, vr_k, time)
+ call prt_maxmin('VR_K', vr_k, is, ie, js, je, 0, km, 1.)
+ endif
+ deallocate (vr_k)
+
+ end subroutine K_warm_rain
+
+ !This is an upgraded version of kessler MP with modern
+ ! 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 )
+! T - TEMPERATURE (K)
+! QV - WATER VAPOR MIXING RATIO (GM/GM)
+! qc - CLOUD WATER MIXING RATIO (GM/GM)
+! QR - RAIN WATER MIXING RATIO (GM/GM)
+! R - DRY AIR DENSITY (GM/M^3)
+! dt - TIME STEP (S)
+! Z - HEIGHTS OF THERMODYNAMIC LEVELS IN THE GRID COLUMN (M)
+! NZ - NUMBER OF THERMODYNAMIC LEVELS IN THE COLUMN
+! VARIABLES IN THE GRID COLUMN ARE ORDERED FROM THE SURFACE TO THE TOP.
+! k=1 is the top layer
+! Dry mixing ratios?
+! OUTPUT VARIABLES:
+ integer, intent(in):: nz
+ real, intent(in):: dt
+ 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
+! Local:
+ real, parameter:: qr_min = 1.e-8
+ real, parameter:: vr_min = 1.e-3
+ real, dimension(nz):: r, pc, rho, rqr
+ REAL ERN, QRPROD, PROD, QVS, dqsdt, hlvm, dq
+ INTEGER K
+
+! Need to compute rho(nz) first:
+ do k=nz,1,-1
+ rho(k) = drym(k)/(grav*dz(k))
+ pc(k) = 3.8e2 / (rho(k)*rdgas*T(k))
+ r(k) = 0.001*rho(k)
+ rqr(k) = r(k)*max(qr(k), qr_min)
+ vr(k) = 36.34 * sqrt(rho(nz)/rho(k)) * exp( 0.1364*log(rqr(k)) )
+ vr(k) = max(vr_min, vr(k))
+ enddo
+
+ qr(1) = dz(1)*qr(1) / (dz(1)+dt*vr(1))
+ do k=2, 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
+
+ end subroutine kessler_imp
+
+ real function g_sum(p, ifirst, ilast, jfirst, jlast, area, mode)
+!-------------------------
+! Quick local sum algorithm
+!-------------------------
+ use mpp_mod, only: mpp_sum
+ integer, intent(IN) :: ifirst, ilast
+ integer, intent(IN) :: jfirst, jlast
+ integer, intent(IN) :: mode ! if ==1 divided by area
+ real, intent(IN) :: p(ifirst:ilast,jfirst:jlast) ! field to be summed
+ real, intent(IN) :: area(ifirst:ilast,jfirst:jlast)
+ integer :: i,j
+ real gsum
+
+ if( global_area < 0. ) then
+ global_area = 0.
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+ global_area = global_area + area(i,j)
+ enddo
+ enddo
+ call mpp_sum(global_area)
+ end if
+
+ gsum = 0.
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+ gsum = gsum + p(i,j)*area(i,j)
+ enddo
+ enddo
+ call mpp_sum(gsum)
+
+ if ( mode==1 ) then
+ g_sum = gsum / global_area
+ else
+ g_sum = gsum
+ endif
+
+ end function g_sum
+
+ subroutine reed_sim_physics (pcols, pver, dtime, lat, t, q, u, v, pmid, pint, pdel, rpdel, ps, zint, test, &
+ do_reed_cond, reed_cond_only, reed_alt_mxg, precl, dudt, dvdt, dtdt, dqdt)
+
+!-----------------------------------------------------------------------
+!
+! Purpose: Simple Physics Package
+!
+! Author: K. A. Reed (University of Michigan, kareed@umich.edu)
+! version 5
+! July/8/2012
+!
+! Change log:
+! v2: removal of some NCAR CAM-specific 'use' associations
+! v3: corrected precl(i) computation, the precipitation rate is now computed via a vertical integral, the previous single-level computation in v2 was a bug
+! v3: corrected dtdt(i,1) computation, the term '-(i,1)' was missing the temperature variable: '-t(i,1)'
+! v4: modified and enhanced parameter list to make the routine truly standalone, the number of columns and vertical levels have been added: pcols, pver
+! v4: 'ncol' has been removed, 'pcols' is used instead
+! v5: the sea surface temperature (SST) field Tsurf is now an array, the SST now depends on the latitude
+! v5: addition of the latitude array 'lat' and the flag 'test' in the parameter list
+! if test = 0: constant SST is used, correct setting for the tropical cyclone test case 5-1
+! if test = 1: newly added latitude-dependent SST is used, correct setting for the moist baroclinic wave test with simple-physics (test 4-3)
+!
+! Description: Includes large-scale precipitation, surface fluxes and
+! boundary-leyer mixing. The processes are time-split
+! in that order. A partially implicit formulation is
+! used to foster numerical stability.
+! The routine assumes that the model levels are ordered
+! in a top-down approach, e.g. level 1 denotes the uppermost
+! full model level.
+!
+! This routine is based on an implementation which was
+! developed for the NCAR Community Atmosphere Model (CAM).
+! Adjustments for other models will be necessary.
+!
+! The routine provides both updates of the state variables
+! u, v, T, q (these are local copies of u,v,T,q within this physics
+! routine) and also collects their time tendencies.
+! The latter might be used to couple the physics and dynamics
+! in a process-split way. For a time-split coupling, the final
+! state should be given to the dynamical core for the next time step.
+! Test: 0 = Reed and Jablonowski (2011) tropical cyclone test case (test 5-1)
+! 1 = Moist baroclinic instability test (test 4-3)
+! 2 = Moist baroclinic instability test (test 4-2) with NO surface fluxes
+!
+!
+! Reference: Reed, K. A. and C. Jablonowski (2012), Idealized tropical cyclone
+! simulations of intermediate complexity: A test case for AGCMs,
+! J. Adv. Model. Earth Syst., Vol. 4, M04001, doi:10.1029/2011MS000099
+!-----------------------------------------------------------------------
+ ! use physics_types , only: physics_dme_adjust ! This is for CESM/CAM
+ ! use cam_diagnostics, only: diag_phys_writeout ! This is for CESM/CAM
+
+ implicit none
+
+ integer, parameter :: r8 = selected_real_kind(12)
+
+!
+! Input arguments - MODEL DEPENDENT
+!
+ integer, intent(in) :: pcols ! Set number of atmospheric columns
+ integer, intent(in) :: pver ! Set number of model levels
+ real, intent(in) :: dtime ! Set model physics timestep
+ real, intent(in) :: lat(pcols) ! Latitude
+ integer, intent(in) :: test ! Test number
+ logical, intent(IN) :: do_reed_cond, reed_cond_only, reed_alt_mxg
+
+!
+! Input/Output arguments
+!
+! pcols is the maximum number of vertical columns per 'chunk' of atmosphere
+!
+ real, intent(inout) :: t(pcols,pver) ! Temperature at full-model level (K)
+ real, intent(inout) :: q(pcols,pver) ! Specific Humidity at full-model level (kg/kg)
+ real, intent(inout) :: u(pcols,pver) ! Zonal wind at full-model level (m/s)
+ real, intent(inout) :: v(pcols,pver) ! Meridional wind at full-model level (m/s)
+ real, intent(in) :: pmid(pcols,pver) ! Pressure is full-model level (Pa)
+ real, intent(in) :: pint(pcols,pver+1) ! Pressure at model interfaces (Pa)
+ real, intent(in) :: pdel(pcols,pver) ! Layer thickness (Pa)
+ real, intent(in) :: rpdel(pcols,pver) ! Reciprocal of layer thickness (1/Pa)
+ real, intent(in) :: ps(pcols) ! Surface Pressue (Pa)
+ real, intent(in) :: zint(pcols,pver+1) ! Height at interfaces
+!
+! Output arguments
+ real, intent(out):: dtdt(pcols,pver) ! Temperature tendency
+ real, intent(out):: dqdt(pcols,pver) ! Specific humidity tendency
+ real, intent(out):: dudt(pcols,pver) ! Zonal wind tendency
+ real, intent(out):: dvdt(pcols,pver) ! Meridional wind tendency
+ real, intent(inout) :: precl(pcols) ! precipitation
+
+!
+!---------------------------Local workspace-----------------------------
+!
+
+! Integers for loops
+
+ integer i,k ! Longitude, level indices
+
+! Physical Constants - Many of these may be model dependent
+
+ real gravit ! Gravity
+ real rair ! Gas constant for dry air
+ real cpair ! Specific heat of dry air
+ real latvap ! Latent heat of vaporization
+ real rh2o ! Gas constant for water vapor
+ real epsilo ! Ratio of gas constant for dry air to that for vapor
+ real zvir ! Constant for virtual temp. calc. =(rh2o/rair) - 1
+ real a ! Reference Earth's Radius (m)
+ real omega_r ! Reference rotation rate of the Earth (s^-1)
+#ifdef USE_REED_CONST
+ real pi ! pi
+#endif
+
+! Simple Physics Specific Constants
+
+!++++++++
+ real Tsurf(pcols) ! Sea Surface Temperature (constant for tropical cyclone)
+!++++++++ Tsurf needs to be dependent on latitude for the
+ ! moist baroclinic wave test 4-3 with simple-physics, adjust
+
+ real SST_tc ! Sea Surface Temperature for tropical cyclone test
+ real T0 ! Control temp for calculation of qsat
+ real rhow ! Density of Liquid Water
+ real p0 ! Constant for calculation of potential temperature
+ real Cd0 ! Constant for calculating Cd from Smith and Vogl 2008
+ real Cd1 ! Constant for calculating Cd from Smith and Vogl 2008
+ real Cm ! Constant for calculating Cd from Smith and Vogl 2008
+ real v20 ! Threshold wind speed for calculating Cd from Smith and Vogl 2008
+ real C ! Drag coefficient for sensible heat and evaporation
+ real sqC ! sqrt(C)
+ real T00 ! Horizontal mean T at surface for moist baro test
+ real u0 ! Zonal wind constant for moist baro test
+ real latw ! halfwidth for for baro test
+ real eta0 ! Center of jets (hybrid) for baro test
+ real etav ! Auxiliary variable for baro test
+ real q0 ! Maximum specific humidity for baro test
+
+! Temporary variables for tendency calculations
+
+ real tmp ! Temporary
+ real qsat ! Saturation vapor pressure
+ real qsats ! Saturation vapor pressure of SST
+
+! Variables for Boundary Layer Calculation
+
+ real wind(pcols) ! Magnitude of Wind
+ real Cd(pcols) ! Drag coefficient for momentum
+ real Km(pcols,pver+1) ! Eddy diffusivity for boundary layer calculations
+ real Ke(pcols,pver+1) ! Eddy diffusivity for boundary layer calculations
+ real rho ! Density at lower/upper interface
+ real za(pcols) ! Heights at midpoints of first model level
+ real dlnpint ! Used for calculation of heights
+ real pbltop ! Top of boundary layer
+ real pbltopz ! Top of boundary layer (m)
+ real pblconst ! Constant for the calculation of the decay of diffusivity
+ real CA(pcols,pver) ! Matrix Coefficents for PBL Scheme
+ real CC(pcols,pver) ! Matrix Coefficents for PBL Scheme
+ real CE(pcols,pver+1) ! Matrix Coefficents for PBL Scheme
+ real CAm(pcols,pver) ! Matrix Coefficents for PBL Scheme
+ real CCm(pcols,pver) ! Matrix Coefficents for PBL Scheme
+ real CEm(pcols,pver+1) ! Matrix Coefficents for PBL Scheme
+ real CFu(pcols,pver+1) ! Matrix Coefficents for PBL Scheme
+ real CFv(pcols,pver+1) ! Matrix Coefficents for PBL Scheme
+ real CFt(pcols,pver+1) ! Matrix Coefficents for PBL Scheme
+ real CFq(pcols,pver+1) ! Matrix Coefficents for PBL Scheme
+
+
+! Variable for Dry Mass Adjustment, this dry air adjustment is necessary to
+! conserve the mass of the dry air
+
+!===============================================================================
+!
+! Physical Constants - MAY BE MODEL DEPENDENT
+!
+!===============================================================================
+ if ( test .eq. 2 ) return
+
+#ifdef USE_REED_CONST
+ gravit = 9.80616_r8 ! Gravity (9.80616 m/s^2)
+ rair = 287.0_r8 ! Gas constant for dry air: 287 J/(kg K)
+ cpair = 1.0045e3_r8 ! Specific heat of dry air: here we use 1004.5 J/(kg K)
+ a = 6371220.0_r8 ! Reference Earth's Radius (m)
+ omega_r = 7.29212d-5 ! Reference rotation rate of the Earth (s^-1)
+ pi = 4._r8*atan(1._r8) ! pi
+#else
+ gravit = GRAV
+ rair = RDGAS !287.04
+ cpair = CP_AIR ! RDGAS*7/2=1004.64
+ a = RADIUS ! 6371.e3
+ omega_r = OMEGA ! 7.292e-5
+#endif
+! Common constants:
+ rh2o = 461.5_r8 ! Gas constant for water vapor: 461.5 J/(kg K)
+ latvap = 2.5e6_r8 ! Latent heat of vaporization (J/kg)
+ epsilo = rair/rh2o ! Ratio of gas constant for dry air to that for vapor
+ zvir = (rh2o/rair) - 1._r8 ! Constant for virtual temp. calc. =(rh2o/rair) - 1 is approx. 0.608
+
+!===============================================================================
+!
+! Local Constants for Simple Physics
+!
+!===============================================================================
+ C = 0.0011_r8 ! From Smith and Vogl 2008
+ sqC = sqrt(0.0011_r8)! From Smith and Vogl 2008
+ SST_tc = 302.15_r8 ! Constant Value for SST for tropical cyclone test
+ T0 = 273.16_r8 ! control temp for calculation of qsat
+ rhow = 1000.0_r8 ! Density of Liquid Water
+ Cd0 = 0.0007_r8 ! Constant for Cd calc. Smith and Vogl 2008
+ Cd1 = 0.000065_r8 ! Constant for Cd calc. Smith and Vogl 2008
+ Cm = 0.002_r8 ! Constant for Cd calc. Smith and Vogl 2008
+ v20 = 20.0_r8 ! Threshold wind speed for calculating Cd from Smith and Vogl 2008
+ p0 = 100000.0_r8 ! Constant for potential temp calculation
+ pbltop = 85000._r8 ! Top of boundary layer
+ pbltopz = 1000._r8 ! Top of boundary layer (m) for 'save me' scheme
+ pblconst = 10000._r8 ! Constant for the calculation of the decay of diffusivity
+ T00 = 288.0_r8 ! Horizontal mean T at surface for moist baro test
+ u0 = 35.0_r8 ! Zonal wind constant for moist baro test
+ latw = 2.0_r8*pi/9.0_r8 ! Halfwidth for for baro test
+ eta0 = 0.252_r8 ! Center of jets (hybrid) for baro test
+ etav = (1._r8-eta0)*0.5_r8*pi ! Auxiliary variable for baro test
+ q0 = 0.021 ! Maximum specific humidity for baro test
+
+!===============================================================================
+!
+! Definition of local arrays
+!
+!===============================================================================
+!
+! Calculate hydrostatic height za of the lowest model level
+!
+ do i=1,pcols
+ dlnpint = log(ps(i)) - log(pint(i,pver)) ! ps(i) is identical to pint(i,pver+1), note: this is the correct sign (corrects typo in JAMES paper)
+ za(i) = rair/gravit*t(i,pver)*(1._r8+zvir*q(i,pver))*0.5_r8*dlnpint
+ end do
+!
+!--------------------------------------------------------------
+! Set Sea Surface Temperature (constant for tropical cyclone)
+! Tsurf needs to be dependent on latitude for the
+! moist baroclinic wave test 4-3 with simple-physics
+!--------------------------------------------------------------
+ if (test .eq. 1) then ! moist baroclinic wave with simple-physics
+ do i=1,pcols
+ Tsurf(i) = (T00 + pi*u0/rair * 1.5_r8 * sin(etav) * (cos(etav))**0.5_r8 * &
+ ((-2._r8*(sin(lat(i)))**6 * ((cos(lat(i)))**2 + 1._r8/3._r8) + 10._r8/63._r8)* &
+ u0 * (cos(etav))**1.5_r8 + &
+ (8._r8/5._r8*(cos(lat(i)))**3 * ((sin(lat(i)))**2 + 2._r8/3._r8) - pi/4._r8)*a*omega_r*0.5_r8 ))/ &
+ (1._r8+zvir*q0*exp(-(lat(i)/latw)**4))
+
+ end do
+ elseif (test .eq. 0) then
+ do i=1,pcols ! constant SST for the tropical cyclone test case
+ Tsurf(i) = SST_tc
+ end do
+ else
+ Tsurf(:) = 1.E25
+ end if
+
+!===============================================================================
+!
+! Set initial physics time tendencies and precipitation field to zero
+!
+!===============================================================================
+ dtdt(:pcols,:pver) = 0._r8 ! initialize temperature tendency with zero
+ dqdt(:pcols,:pver) = 0._r8 ! initialize specific humidity tendency with zero
+ dudt(:pcols,:pver) = 0._r8 ! initialize zonal wind tendency with zero
+ dvdt(:pcols,:pver) = 0._r8 ! initialize meridional wind tendency with zero
+!
+! Calculate Tendencies
+!
+!===============================================================================
+!
+! Large-Scale Condensation and Precipitation Rate
+!
+!===============================================================================
+!
+! Calculate Tendencies
+!
+ if (do_reed_cond) then
+ do k=1,pver
+ do i=1,pcols
+ qsat = epsilo*e0/pmid(i,k)*exp(-latvap/rh2o*((1./t(i,k))-1./T0)) ! saturation specific humidity
+ if (q(i,k) > qsat) then ! saturated?
+ tmp = 1./dtime*(q(i,k)-qsat)/(1.+(latvap/cpair)*(epsilo*latvap*qsat/(rair*t(i,k)**2)))
+ dtdt(i,k) = dtdt(i,k)+latvap/cpair*tmp
+ dqdt(i,k) = dqdt(i,k)-tmp
+ precl(i) = precl(i) + tmp*pdel(i,k)/(gravit*rhow) ! precipitation rate, computed via a vertical integral
+ ! corrected in version 1.3
+ end if
+ end do
+ end do
+ !
+ ! Update moisture and temperature fields from Large-Scale Precipitation Scheme
+ !
+ !!!NOTE: How to update mass????
+ do k=1,pver
+ do i=1,pcols
+ t(i,k) = t(i,k) + dtdt(i,k)*dtime ! update the state variables T and q
+ q(i,k) = q(i,k) + dqdt(i,k)*dtime
+ end do
+ end do
+
+ endif
+
+
+ if (reed_cond_only) return
+!===============================================================================
+!
+! Turbulent mixing coefficients for the PBL mixing of horizontal momentum,
+! sensible heat and latent heat
+!
+! We are using Simplified Ekman theory to compute the diffusion coefficients
+! Kx for the boundary-layer mixing. The Kx values are calculated at each time step
+! and in each column.
+!
+!===============================================================================
+!
+! Compute magnitude of the wind and drag coeffcients for turbulence scheme:
+! they depend on the conditions at the lowest model level and stay constant
+! up to the 850 hPa level. Above this level the coefficients are decreased
+! and tapered to zero. At the 700 hPa level the strength of the K coefficients
+! is about 10% of the maximum strength.
+!
+
+ do i=1,pcols
+ wind(i) = sqrt(u(i,pver)**2+v(i,pver)**2) ! wind magnitude at the lowest level
+ end do
+
+ if (reed_alt_mxg) then
+
+ do i=1,pcols
+ if( wind(i) .lt. v20) then
+ Cd(i) = Cd0+Cd1*wind(i)
+ else
+ Cd(i) = Cm
+ endif
+ end do
+
+ do k=1,pver+1
+ do i=1,pcols
+ if( zint(i,k) .gt. pbltopz) then
+ Km(i,k) = 0.
+ Ke(i,k) = 0.
+ else
+ Km(i,k) = 0.4*sqrt(Cd(i))*wind(i)*zint(i,k)*(1. - zint(i,k)/pbltopz)**2
+ Ke(i,k) = 0.4*sqC *wind(i)*zint(i,k)*(1. - zint(i,k)/pbltopz)**2
+ end if
+ end do
+ end do
+
+ else
+
+ do i=1,pcols
+ Ke(i,pver+1) = C*wind(i)*za(i)
+ if( wind(i) .lt. v20) then
+ Cd(i) = Cd0+Cd1*wind(i)
+ Km(i,pver+1) = Cd(i)*wind(i)*za(i)
+ else
+ Cd(i) = Cm
+ Km(i,pver+1) = Cm*wind(i)*za(i)
+ endif
+ end do
+
+ do k=1,pver
+ do i=1,pcols
+ if( pint(i,k) .ge. pbltop) then
+ Km(i,k) = Km(i,pver+1) ! constant Km below 850 hPa level
+ Ke(i,k) = Ke(i,pver+1) ! constant Ke below 850 hPa level
+ else
+ Km(i,k) = Km(i,pver+1)*exp(-(pbltop-pint(i,k))**2/(pblconst)**2) ! Km tapered to 0
+ Ke(i,k) = Ke(i,pver+1)*exp(-(pbltop-pint(i,k))**2/(pblconst)**2) ! Ke tapered to 0
+ end if
+ end do
+ end do
+
+ endif
+
+!===============================================================================
+! Update the state variables u, v, t, q with the surface fluxes at the
+! lowest model level, this is done with an implicit approach
+! see Reed and Jablonowski (JAMES, 2012)
+!
+! Sea Surface Temperature Tsurf is constant for tropical cyclone test 5-1
+! Tsurf needs to be dependent on latitude for the
+! moist baroclinic wave test 4-3 with simple-physics, adjust
+!===============================================================================
+
+ do i=1,pcols
+! qsats = epsilo*e0/ps(i)*exp(-latvap/rh2o*((1._r8/Tsurf(i))-1._r8/T0)) ! saturation specific humidity at the surface
+ qsats = epsilo*e0/ps(i)*exp((dc_vap*log(Tsurf(i)/tice)+Lv0*(Tsurf(i)-tice)/(Tsurf(i)*tice))/rvgas)
+ dudt(i,pver) = dudt(i,pver) + (u(i,pver) &
+ /(1._r8+Cd(i)*wind(i)*dtime/za(i))-u(i,pver))/dtime
+ dvdt(i,pver) = dvdt(i,pver) + (v(i,pver) &
+ /(1._r8+Cd(i)*wind(i)*dtime/za(i))-v(i,pver))/dtime
+ u(i,pver) = u(i,pver)/(1._r8+Cd(i)*wind(i)*dtime/za(i))
+ v(i,pver) = v(i,pver)/(1._r8+Cd(i)*wind(i)*dtime/za(i))
+ dtdt(i,pver) = dtdt(i,pver) +((t(i,pver)+C*wind(i)*Tsurf(i)*dtime/za(i)) &
+ /(1._r8+C*wind(i)*dtime/za(i))-t(i,pver))/dtime
+ t(i,pver) = (t(i,pver)+C*wind(i)*Tsurf(i)*dtime/za(i)) &
+ /(1._r8+C*wind(i)*dtime/za(i))
+ dqdt(i,pver) = dqdt(i,pver) +((q(i,pver)+C*wind(i)*qsats*dtime/za(i)) &
+ /(1._r8+C*wind(i)*dtime/za(i))-q(i,pver))/dtime
+ q(i,pver) = (q(i,pver)+C*wind(i)*qsats*dtime/za(i))/(1._r8+C*wind(i)*dtime/za(i))
+ end do
+!===============================================================================
+
+!!! return ! SJL to turn OFF PBL
+
+!===============================================================================
+! Boundary layer mixing, see Reed and Jablonowski (JAMES, 2012)
+!===============================================================================
+! Calculate Diagonal Variables for Implicit PBL Scheme
+!
+ do k=1,pver-1
+ do i=1,pcols
+ rho = (pint(i,k+1)/(rair*(t(i,k+1)+t(i,k))/2.0_r8))
+ CAm(i,k) = rpdel(i,k)*dtime*gravit*gravit*Km(i,k+1)*rho*rho &
+ /(pmid(i,k+1)-pmid(i,k))
+ CCm(i,k+1) = rpdel(i,k+1)*dtime*gravit*gravit*Km(i,k+1)*rho*rho &
+ /(pmid(i,k+1)-pmid(i,k))
+ CA(i,k) = rpdel(i,k)*dtime*gravit*gravit*Ke(i,k+1)*rho*rho &
+ /(pmid(i,k+1)-pmid(i,k))
+ CC(i,k+1) = rpdel(i,k+1)*dtime*gravit*gravit*Ke(i,k+1)*rho*rho &
+ /(pmid(i,k+1)-pmid(i,k))
+ end do
+ end do
+ do i=1,pcols
+ CAm(i,pver) = 0._r8
+ CCm(i,1) = 0._r8
+ CEm(i,pver+1) = 0._r8
+ CA(i,pver) = 0._r8
+ CC(i,1) = 0._r8
+ CE(i,pver+1) = 0._r8
+ CFu(i,pver+1) = 0._r8
+ CFv(i,pver+1) = 0._r8
+ CFt(i,pver+1) = 0._r8
+ CFq(i,pver+1) = 0._r8
+ end do
+ do i=1,pcols
+ do k=pver,1,-1
+ CE(i,k) = CC(i,k)/(1._r8+CA(i,k)+CC(i,k)-CA(i,k)*CE(i,k+1))
+ CEm(i,k) = CCm(i,k)/(1._r8+CAm(i,k)+CCm(i,k)-CAm(i,k)*CEm(i,k+1))
+ CFu(i,k) = (u(i,k)+CAm(i,k)*CFu(i,k+1)) &
+ /(1._r8+CAm(i,k)+CCm(i,k)-CAm(i,k)*CEm(i,k+1))
+ CFv(i,k) = (v(i,k)+CAm(i,k)*CFv(i,k+1)) &
+ /(1._r8+CAm(i,k)+CCm(i,k)-CAm(i,k)*CEm(i,k+1))
+ CFt(i,k) = ((p0/pmid(i,k))**(rair/cpair)*t(i,k)+CA(i,k)*CFt(i,k+1)) &
+ /(1._r8+CA(i,k)+CC(i,k)-CA(i,k)*CE(i,k+1))
+ CFq(i,k) = (q(i,k)+CA(i,k)*CFq(i,k+1)) &
+ /(1._r8+CA(i,k)+CC(i,k)-CA(i,k)*CE(i,k+1))
+ end do
+ end do
+
+!
+! Calculate the updated temperature, specific humidity and horizontal wind
+!
+! First we need to calculate the updates at the top model level
+!
+ do i=1,pcols
+ dudt(i,1) = dudt(i,1)+(CFu(i,1)-u(i,1))/dtime
+ dvdt(i,1) = dvdt(i,1)+(CFv(i,1)-v(i,1))/dtime
+ u(i,1) = CFu(i,1)
+ v(i,1) = CFv(i,1)
+ dtdt(i,1) = dtdt(i,1)+(CFt(i,1)*(pmid(i,1)/p0)**(rair/cpair)-t(i,1))/dtime ! corrected in version 1.3
+ t(i,1) = CFt(i,1)*(pmid(i,1)/p0)**(rair/cpair)
+ dqdt(i,1) = dqdt(i,1)+(CFq(i,1)-q(i,1))/dtime
+ q(i,1) = CFq(i,1)
+ end do
+!
+! Loop over the remaining level
+!
+ do i=1,pcols
+ do k=2,pver
+ dudt(i,k) = dudt(i,k)+(CEm(i,k)*u(i,k-1)+CFu(i,k)-u(i,k))/dtime
+ dvdt(i,k) = dvdt(i,k)+(CEm(i,k)*v(i,k-1)+CFv(i,k)-v(i,k))/dtime
+ u(i,k) = CEm(i,k)*u(i,k-1)+CFu(i,k)
+ v(i,k) = CEm(i,k)*v(i,k-1)+CFv(i,k)
+ dtdt(i,k) = dtdt(i,k)+((CE(i,k)*t(i,k-1) &
+ *(p0/pmid(i,k-1))**(rair/cpair)+CFt(i,k)) &
+ *(pmid(i,k)/p0)**(rair/cpair)-t(i,k))/dtime
+ t(i,k) = (CE(i,k)*t(i,k-1)*(p0/pmid(i,k-1))**(rair/cpair)+CFt(i,k)) &
+ *(pmid(i,k)/p0)**(rair/cpair)
+ dqdt(i,k) = dqdt(i,k)+(CE(i,k)*q(i,k-1)+CFq(i,k)-q(i,k))/dtime
+ q(i,k) = CE(i,k)*q(i,k-1)+CFq(i,k)
+ end do
+ end do
+
+ end subroutine reed_sim_physics
+
+ subroutine DCMIP2016_terminator_advance(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
+ km, q, delp, ncnst, lon, lat, pdt)
+
+ !!! Currently assumes DRY mixing ratio??
+
+ integer, intent(in):: km ! vertical dimension
+ integer, intent(in):: i0, i1 ! compute domain dimension in E-W
+ integer, intent(in):: j0, j1 ! compute domain dimension in N-S
+ integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
+ integer, intent(in) :: ncnst
+ real, intent(in), dimension(ifirst:ilast,jfirst:jlast):: lon, lat
+ real, intent(in) :: pdt
+ real, intent(inout):: q(ifirst:ilast,jfirst:jlast,km,ncnst)
+ real, intent(in) :: delp(ifirst:ilast,jfirst:jlast,km)
+! Local var:
+ real:: D, k1, r, ll, sinthc, costhc, qcly, el, cl_f, expdt, rdt, qCl, qCl2, dq
+ integer:: i,j,k
+ integer:: Cl, Cl2
+
+ !NOTE: If you change the reaction rates, then you will have to change it both
+ ! here and in fv_phys
+ real, parameter :: lc = 5.*pi/3.
+ real, parameter :: thc = pi/9.
+ real, parameter :: k2 = 1.
+ real, parameter :: cly0 = 4.e-6
+
+ sinthc = sin(thc)
+ costhc = cos(thc)
+ rdt = 1./pdt
+
+ Cl = get_tracer_index (MODEL_ATMOS, 'Cl')
+ Cl2 = get_tracer_index (MODEL_ATMOS, 'Cl2')
+
+ if (term_fill_negative) then
+ do k=1,km
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+
+ dq = min(q(i,j,k,Cl2),0.)*2.-min(q(i,j,k,Cl),0.)
+ q(i,j,k,Cl) = q(i,j,k,Cl) + dq
+ q(i,j,k,Cl2) = q(i,j,k,Cl2) - dq*0.5
+
+ enddo
+ enddo
+ enddo
+ endif
+
+ do k=1,km
+ do j=jfirst,jlast
+ do i=ifirst,ilast
+
+ qCl = q(i,j,k,Cl)
+ qCl2 = q(i,j,k,Cl2)
+
+ k1 = max(0., sin(lat(i,j))*sinthc + cos(lat(i,j))*costhc*cos(lon(i,j) - lc))
+ r = k1/k2 * 0.25
+ qcly = qCl + 2.*qCl2
+ D = sqrt(r*r + 2.*r*qcly)
+ expdt = exp( -4.*k2*D*pdt)
+
+ if ( abs(D * k2 * pdt) .gt. 1e-16 ) then
+ el = (1. - expdt) /D *rdt
+ else
+ el = 4.*k2
+ endif
+
+ cl_f = -el * (qCl - D + r)*(qCl + D + r) / (1. + expdt + pdt*el*(qCl + r))
+
+ q(i,j,k,Cl) = qCl + cl_f*pdt
+ q(i,j,k,Cl2) = qCl2 - cl_f*0.5*pdt
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine DCMIP2016_terminator_advance
+
+end module fv_phys_mod
diff --git a/driver/solo/hswf.F90 b/driver/solo/hswf.F90
new file mode 100644
index 000000000..1eb213004
--- /dev/null
+++ b/driver/solo/hswf.F90
@@ -0,0 +1,232 @@
+!***********************************************************************
+!* 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 hswf_mod
+
+ use constants_mod, only: grav, rdgas, cp_air, RADIAN, kappa, pi
+ use fv_arrays_mod, only: radius ! scaled for small earth
+
+ use fv_grid_utils_mod, only: g_sum
+ use mpp_domains_mod, only: mpp_update_domains, domain2d
+ use time_manager_mod, only: time_type, get_date, get_time
+ use diag_manager_mod, only: send_data
+ use fv_timing_mod, only: timing_on, timing_off
+
+ implicit none
+!-----------------------------------------------------------------------
+ private
+ public :: Held_Suarez_Tend, age_of_air
+
+contains
+
+!-----------------------------------------------------------------------
+
+ subroutine Held_Suarez_Tend(npx, npy, npz, is, ie, js, je, ng, nq, &
+ u, v, pt, q, pe, delp, peln, pkz, pdt, &
+ ua, va, u_dt, v_dt, t_dt, q_dt, agrid, &
+ delz, phis, hydrostatic, ak, bk, ks, &
+ strat, rayf, master, Time, time_total)
+
+ integer, INTENT(IN ) :: npx, npy, npz
+ integer, INTENT(IN ) :: is, ie, js, je, ng, nq
+ logical, intent(IN) :: hydrostatic
+ real , INTENT(IN ) :: phis(is-ng:ie+ng,js-ng:je+ng)
+ real , INTENT(IN ) :: delz(is:,js:,1:)
+ real , INTENT(IN) :: pkz(is :ie ,js :je ,1:npz)
+
+ real , INTENT(INOUT) :: u(is-ng:ie+ ng,js-ng:je+1+ng,npz)
+ real , INTENT(INOUT) :: v(is-ng:ie+1+ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: pt(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: delp(is-ng:ie+ ng,js-ng:je+ ng,npz)
+ real , INTENT(INOUT) :: q(is-ng:ie+ ng,js-ng:je+ ng,npz, nq)
+ real , INTENT(INOUT) :: pe(is-1:ie+1 ,1:npz+1,js-1:je+1)
+ real , INTENT(INOUT) :: peln(is :ie ,1:npz+1,js :je )
+
+ real , INTENT(INOUT) :: ua(is-ng:ie+ng,js-ng:je+ng,npz)
+ real , INTENT(INOUT) :: va(is-ng:ie+ng,js-ng:je+ng,npz)
+
+! Tendencies:
+ real, INTENT(INOUT):: u_dt(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: v_dt(is-ng:ie+ng,js-ng:je+ng,npz)
+ real, INTENT(INOUT):: t_dt(is:ie,js:je,npz)
+ real, INTENT(INOUT):: q_dt(is:ie,js:je,npz,nq)
+
+
+ real , INTENT(IN ) :: agrid(is-ng:ie+ng,js-ng:je+ng, 2)
+ real , INTENT(IN ) :: ak(npz+1), bk(npz+1)
+ integer, INTENT(IN ) :: ks
+
+ real , INTENT(IN ) :: pdt
+ logical, INTENT(IN ) :: strat, rayf, master
+
+ type(time_type), intent(in) :: Time
+ real, INTENT(IN), optional:: time_total
+
+! Local
+ real, dimension(is:ie,npz):: teq, pl
+ real, dimension(is:ie):: u1, v1
+ integer i,j,k
+ integer seconds, days
+ real ty, tz, akap
+ real p0, t0, sday, rkv, rka, rks, rkt, sigb, rsgb
+ real tmp, solar_ang, solar_rate
+ real ap0k, algpk
+ real tey, tez, fac, pw, sigl
+ real h0, dz
+ real dt_tropic
+ real rmr, rms
+ real relx, tau
+ real t_st, t_ms
+ real rdt, f1
+ real rad_ratio, kf_day
+
+ ty = 60.0
+ tz = 10.0 ! Original value from H-S was 10.
+ akap = 2./7.
+
+ p0 = 100000.
+ t0 = 200.
+ h0 = 7.
+ sday = 24.*3600.
+ rdt = 1. / pdt
+
+!--------------------------
+ rad_ratio = radius / 6371.0e3
+
+ kf_day = sday * rad_ratio
+ rkv = pdt / kf_day
+ rka = pdt / (40.*kf_day)
+ rks = pdt / (4.0*kf_day)
+
+! For strat-mesosphere
+ t_ms = 10.*rad_ratio
+ t_st = 40.*rad_ratio
+
+ tau = (t_st - t_ms) / log(100.)
+ rms = pdt/(t_ms*sday)
+ rmr = 1./(1.+rms)
+
+ sigb = 0.7
+ rsgb = 1./(1.-sigb)
+ ap0k = 1./p0**akap
+ algpk = log(ap0k)
+
+! Temperature forcing...
+!$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,peln,ap0k,ty,agrid,tz,akap, &
+!$OMP strat,h0,t_dt,pt,rms,rmr,rdt,t_ms,tau,pdt,sday,pe, &
+!$OMP sigb,rsgb,pkz,algpk,t0,rka,rks,rkv,u_dt,ua,v_dt,va) &
+!$OMP private(pl, teq, tey, tez, dz, relx, dt_tropic, sigl, f1, rkt,tmp,u1,v1)
+ do j=js,je
+ do k=1,npz
+ do i=is,ie
+ pl(i,k) = delp(i,j,k) / ( peln(i,k+1,j)-peln(i,k,j))
+ enddo
+ enddo
+ do k=npz,1,-1
+ do i=is,ie
+ tey = ap0k*( 315.0 - ty*SIN(agrid(i,j,2))*SIN(agrid(i,j,2)) )
+ tez = tz*( ap0k/akap )*COS(agrid(i,j,2))*COS(agrid(i,j,2))
+ if (strat .and. pl(i,k) <= 1.E2) then
+! Mesosphere: defined as the region above 1 mb
+ dz = h0 * log(pl(i,k+1)/pl(i,k))
+ dt_tropic = -2.25*COS(agrid(i,j,2)) * dz
+ teq(i,k) = teq(i,k+1) + dt_tropic
+ t_dt(i,j,k) = t_dt(i,j,k) + ((pt(i,j,k)+rms*teq(i,k))*rmr - pt(i,j,k))*rdt
+! Stratosphere:
+ elseif (strat .and. pl(i,k)>1.E2 .and. pl(i,k)<=100.E2 ) then
+ dz = h0 * log(pl(i,k+1)/pl(i,k))
+! Lapse rate above tropic stratopause is 2.25 deg/km
+! Relaxation time is t_st days at 100 mb (as H-S) and gradually
+! decreases to t_ms Days at and above the stratopause
+ relx = t_ms + tau*log(0.01*pl(i,k))
+ relx = pdt/(relx*sday)
+ dt_tropic = 2.25*COS(agrid(i,j,2)) * dz
+ teq(i,k) = teq(i,k+1) + dt_tropic
+ t_dt(i,j,k) = t_dt(i,j,k) + relx*(teq(i,k)-pt(i,j,k))/(1.+relx) * rdt
+ else
+! Troposphere: standard Held-Suarez
+ sigl = pl(i,k)/pe(i,npz+1,j)
+ f1 = max(0., (sigl-sigb) * rsgb )
+ teq(i,k) = tey - tez*(log(pkz(i,j,k))+algpk)
+ teq(i,k) = max(t0, teq(i,k)*pkz(i,j,k))
+ rkt = rka + (rks-rka)*f1*(COS(agrid(i,j,2))**4.0)
+ t_dt(i,j,k) = t_dt(i,j,k) + rkt*(teq(i,k)-pt(i,j,k))/(1.+rkt) * rdt
+ ! Bottom friction:
+ sigl = pl(i,k) / pe(i,npz+1,j)
+ sigl = (sigl-sigb)*rsgb * rkv
+ if (sigl > 0.) then
+ tmp = sigl / (1.+sigl) * rdt
+ u1(i) = ua(i,j,k) + u_dt(i,j,k)
+ v1(i) = va(i,j,k) + v_dt(i,j,k)
+ u_dt(i,j,k) = u_dt(i,j,k) - u1(i)*tmp
+ v_dt(i,j,k) = v_dt(i,j,k) - v1(i)*tmp
+ endif
+ endif
+ enddo !i-loop
+ enddo !k-loop
+ enddo !j-loop
+
+#ifdef DO_AGE
+ if( nq/=0 ) &
+ call age_of_air(is, ie, js, je, npz, ng, time_total, pe, q(is-ng,js-ng,1,nq))
+#endif
+
+ end subroutine Held_Suarez_Tend
+
+ subroutine age_of_air(is, ie, js, je, km, ng, time, pe, q)
+
+ integer is, ie, js, je
+ integer km
+ integer ng
+
+! q is the age tracer
+! Need to be converted to mixing ratio (mass of tracer / dry_air-mass)
+! Ignore this inconsistency for now.
+
+ real, intent(inout):: pe(is-1:ie+1, km+1, js-1:je+1)
+ real, intent(in):: time ! accumulated time since init
+ real, intent(inout):: q(is-ng:ie+ng,js-ng:je+ng,km)
+
+! Local
+ integer i, j, k
+ real p_source ! source level (pa)
+ real ascale
+ real tiny
+ parameter ( tiny = 1.e-6 )
+ parameter ( p_source = 75000. )
+ parameter ( ascale = 5.e-6 / 60. )
+
+!$OMP parallel do default(none) shared(is,ie,js,je,km,time,q,pe)
+ do k=1,km
+ do j=js,je
+ do i=is,ie
+ if( time < tiny ) then
+ q(i,j,k) = 0.
+ elseif( pe(i,k,j) >= p_source ) then
+ q(i,j,k) = ascale * time
+ endif
+ enddo
+ enddo ! j-loop
+ enddo ! k-loop
+
+ end subroutine age_of_air
+
+end module hswf_mod
diff --git a/driver/solo/monin_obukhov_drag.F90 b/driver/solo/monin_obukhov_drag.F90
new file mode 100644
index 000000000..f70cb0222
--- /dev/null
+++ b/driver/solo/monin_obukhov_drag.F90
@@ -0,0 +1,668 @@
+!***********************************************************************
+!* 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 monin_obukhov_mod
+
+!==============================================================================
+! Kernel routines
+!==============================================================================
+
+! explicit interface to all kernel routines
+
+ use ocean_rough_mod, only: compute_ocean_roughness
+
+ implicit none
+ private
+
+ public :: Mon_obkv
+
+ integer, parameter :: i8 = selected_int_kind(18)
+ integer(i8) :: ier_tot, ier
+ integer :: i, j, ier_l, n
+
+ real, parameter :: grav = 9.80
+ real, parameter :: vonkarm = 0.4
+ real, parameter :: error = 1.0e-4
+ real, parameter :: zeta_min = 1.0e-6
+ integer, parameter :: max_iter = 20
+ real, parameter :: small = 1.0e-4
+ logical, parameter :: neutral = .false.
+ integer, parameter :: stable_option = 1
+ real, parameter :: rich_crit =10.0
+ real, parameter :: zeta_trans = 0.5
+ real, parameter :: drag_min = 1.0e-5
+ real, parameter :: ustar_min = 1.e-10
+ real, parameter :: rdgas = 287.04
+ real, parameter :: kappa = 2./7.
+ real, parameter :: cp_air = rdgas/kappa
+ real, parameter :: zref = 10.
+ real, parameter :: zref_t = 2.
+
+contains
+
+ subroutine Mon_obkv(zvir, ps, t_atm, z, rho, p_atm, u_atm, v_atm,u_mean, do_fixed_cd, cd, &
+ t_surf0, q_surf0, q_atm, drag_t,drag_q,flux_t, flux_q, flux_u, &
+ flux_v, u_star, delm, dt, mu, t_fac, master)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! pt, virtual potential temperature at lowest model level (kelvin)
+!! pt0, virtual potential temperature at surface (kelvin)
+!! t_atm: temperature at the lowest model layer
+!! z, height above surface of lowest model layer (meter)
+!! rho, air density
+!! p_atm, pressure at lowest model level (Pa)
+!! u_atm, x-dir wind velocity at lowest model level (m/s)
+!! v_atm, y-dir wind velocity at lowest model level (m/s)
+!! t_surf0, SST (kelvin)
+!! th_atm, potential temperature using surface pressure as reference
+!! q_surf0, mixing ratio at surface
+!! q_atm, mixing ratio at lowest model level
+!! flux_t, heat flux (W/m^2)
+!! flux_q, moisture flux (kg/sm^2)
+!! flux_v, momentum flux (N/m^2, kg/ms^2)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! SJL:
+! PS: surface pressure (Pa)
+
+ logical:: master
+ logical, intent(in) :: do_fixed_cd
+ real, intent(in):: zvir, dt
+ real, intent(in):: t_fac ! t_flux enhancer!
+ real, intent(in), dimension(:,:):: ps, t_atm
+ real, intent(in) :: z(:,:), rho(:,:), delm(:,:)
+ real, intent(in) :: p_atm(:,:), u_atm(:,:), v_atm(:,:)
+ real, intent(in) :: u_mean, cd
+ real, intent(in) :: t_surf0(:,:), q_surf0(:,:), q_atm(:,:)
+ real, intent(inout) :: u_star(:,:)
+ real, intent(out) :: flux_t(:,:), flux_q(:,:), flux_u(:,:), flux_v(:,:)
+ real, intent(out) :: mu(:,:)
+
+ logical, dimension(size(ps,1)) :: avail
+ logical :: lavail
+ real, dimension(size(ps,1),size(ps,2)) :: speed, drag_m, rho_drag
+ real, intent(inout), dimension(size(ps,1),size(ps,2)) :: drag_t, drag_q
+ real, dimension(size(ps,1),size(ps,2)) :: b_star, u_surf0, v_surf0
+ real, dimension(size(ps,1),size(ps,2)) :: rough_mom, rough_heat, rough_moist
+!
+! Local:
+ real, dimension(size(ps,1),size(ps,2)) :: pt, pt0, p_fac, deno
+ real, parameter:: p00 = 1.E5
+ integer:: i,j
+
+ p_fac(:,:) = (ps(:,:)/p_atm(:,:)) ** kappa
+ pt(:,:) = t_atm(:,:)*(1.+zvir*q_atm(:,: ))*(p00/p_atm(:,:))**kappa
+ pt0(:,:) = t_surf0(:,:)*(1.+zvir*q_surf0(:,:))*(p00/ ps(:,:))**kappa
+ speed(:,:) = sqrt(u_atm(:,:)**2+v_atm(:,:)**2+u_mean**2)
+
+ lavail = .false.
+ avail = .true.
+
+#ifdef MON_DEBUG
+ if ( master ) write(*,*) 'p_atm=',maxval(p_atm)
+ if ( master ) write(*,*) 'u_atm=',maxval(u_atm)
+ if ( master ) write(*,*) 'v_atm=',maxval(v_atm)
+ if ( master ) write(*,*) 't_surf0=',maxval(t_surf0)
+ if ( master ) write(*,*) 'q_surf0=',maxval(q_surf0)
+ if ( master ) write(*,*) 'q_atm=',maxval(q_atm)
+ if ( master ) write(*,*) 'u_star=',maxval(u_star)
+#endif
+
+! u_star should be an output?
+ call compute_ocean_roughness ( u_star, speed, rough_mom, rough_heat, rough_moist, master )
+
+ n=size(ps,1)
+ do j = 1, size(ps,2)
+ call monin_obukhov_drag_1d(grav, vonkarm, error, zeta_min, max_iter, small, &
+ neutral, stable_option, rich_crit, zeta_trans, drag_min, &
+ n, pt(:,j), pt0(:,j), z(:,j), rough_mom(:,j), &
+ rough_heat(:,j), rough_moist(:,j), speed(:,j), drag_m(:,j), drag_t(:,j), &
+ drag_q(:,j), u_star(:,j), b_star(:,j), lavail, avail, ier_l)
+ end do
+
+! Ocean currents:
+ u_surf0(:,:) = 0.
+ v_surf0(:,:) = 0.
+
+ if (do_fixed_cd) then
+ drag_m(:,:) = cd
+ drag_t(:,:) = cd
+ drag_q(:,:) = cd
+ end if
+
+! momentum flux
+ mu(:,:) = drag_m(:,:)*speed(:,:) ! diffusion coefficient / Z
+ rho_drag(:,:) = rho(:,:)*mu(:,:)
+
+#ifdef IMPLICIT_FLUX
+ flux_u(:,:) = rho_drag(:,:) * (u_surf0(:,:) - u_atm(:,:))
+ flux_v(:,:) = rho_drag(:,:) * (v_surf0(:,:) - v_atm(:,:))
+
+! flux of sensible heat (W/m**2)
+ rho_drag(:,:) = rho(:,:)*speed(:,:)
+ flux_t(:,:) = cp_air*drag_t(:,:)*rho_drag(:,:)*(t_surf0(:,:)-t_atm(:,:)*p_fac(:,:))*t_fac
+! flux of water vapor (Kg/(m**2 s))
+ flux_q(:,:) = drag_q(:,:)*rho_drag(:,:)*(q_surf0(:,:)-q_atm(:,:))
+
+#else
+ deno(:,:) = 1. + dt*rho_drag(:,:)/delm(:,:)
+ flux_u(:,:) = rho_drag(:,:) * (u_surf0(:,:) - u_atm(:,:)) / deno(:,:)
+ flux_v(:,:) = rho_drag(:,:) * (v_surf0(:,:) - v_atm(:,:)) / deno(:,:)
+! flux of sensible heat (W/m**2)
+! flux of sensible heat (W/m**2)
+ rho_drag(:,:) = rho(:,:)*drag_t(:,:)*speed(:,:) * t_fac
+ deno(:,:) = delm(:,:) / ( delm(:,:) + dt*rho_drag(:,:)*p_fac(:,:))
+ flux_t(:,:) = cp_air*rho_drag(:,:)*(t_surf0(:,:)-t_atm(:,:)*p_fac(:,:))*deno(:,:)
+! flux of water vapor (Kg/(m**2 s))
+ rho_drag(:,:) = rho(:,:)*drag_q(:,:)*speed(:,:)
+ deno(:,:) = 1. + dt*rho_drag(:,:)/delm(:,:)
+ flux_q(:,:) = rho_drag(:,:)*(q_surf0(:,:)-q_atm(:,:))/deno(:,:)
+#endif
+
+ end subroutine Mon_obkv
+
+!==============================================================================
+ subroutine monin_obukhov_drag_1d(grav, vonkarm, &
+ & error, zeta_min, max_iter, small, &
+ & neutral, stable_option, rich_crit, zeta_trans, drag_min, &
+ & n, pt, pt0, z, z0, zt, zq, speed, drag_m, drag_t, &
+ & drag_q, u_star, b_star, lavail, avail, ier)
+
+ implicit none
+
+ real , intent(in ) :: grav
+ real , intent(in ) :: vonkarm
+ real , intent(in ) :: error ! = 1.e-04
+ real , intent(in ) :: zeta_min ! = 1.e-06
+ integer, intent(in ) :: max_iter ! = 20
+ real , intent(in ) :: small ! = 1.e-04
+ logical, intent(in ) :: neutral
+ integer, intent(in ) :: stable_option
+ real , intent(in ) :: rich_crit, zeta_trans, drag_min
+ integer, intent(in ) :: n
+ real , intent(in ), dimension(n) :: pt, pt0, z, z0, zt, zq, speed
+ real , intent(inout), dimension(n) :: drag_m, drag_t, drag_q, u_star, b_star
+ logical, intent(in ) :: lavail ! whether to use provided mask or not
+ logical, intent(in ), dimension(n) :: avail ! provided mask
+ integer, intent(out ) :: ier
+
+ real , dimension(n) :: rich, fm, ft, fq, zz
+ logical, dimension(n) :: mask, mask_1, mask_2
+ real , dimension(n) :: delta_b !!, us, bs, qs
+ real :: r_crit, sqrt_drag_min
+ real :: us, bs, qs
+ integer :: i
+
+ r_crit = 0.95*rich_crit ! convergence can get slow if one is
+ ! close to rich_crit
+ sqrt_drag_min = 0.0
+ if(drag_min.ne.0.0) sqrt_drag_min = sqrt(drag_min)
+
+ mask = .true.
+! if(lavail) mask = avail
+
+ where(mask)
+ delta_b = grav*(pt0 - pt)/pt0
+ rich = - z*delta_b/(speed*speed + small)
+ zz = max(z,z0,zt,zq)
+ elsewhere
+ rich = 0.0
+ end where
+
+ if(neutral) then
+
+ do i = 1, n
+ if(mask(i)) then
+ fm(i) = log(zz(i)/z0(i))
+ ft(i) = log(zz(i)/zt(i))
+ fq(i) = log(zz(i)/zq(i))
+ us = vonkarm/fm(i)
+ bs = vonkarm/ft(i)
+ qs = vonkarm/fq(i)
+ drag_m(i) = us*us
+ drag_t(i) = us*bs
+ drag_q(i) = us*qs
+ u_star(i) = us*speed(i)
+ b_star(i) = bs*delta_b(i)
+ end if
+ enddo
+
+ else
+
+ mask_1 = mask .and. rich < r_crit
+ mask_2 = mask .and. rich >= r_crit
+
+ do i = 1, n
+ if(mask_2(i)) then
+ drag_m(i) = drag_min
+ drag_t(i) = drag_min
+ drag_q(i) = drag_min
+ us = sqrt_drag_min
+ bs = sqrt_drag_min
+ u_star(i) = us*speed(i)
+ b_star(i) = bs*delta_b(i)
+ end if
+ enddo
+
+ call monin_obukhov_solve_zeta (error, zeta_min, max_iter, small, &
+ & stable_option, rich_crit, zeta_trans, &
+ & n, rich, zz, z0, zt, zq, fm, ft, fq, mask_1, ier)
+
+ do i = 1, n
+ if(mask_1(i)) then
+ us = max(vonkarm/fm(i), sqrt_drag_min)
+ bs = max(vonkarm/ft(i), sqrt_drag_min)
+ qs = max(vonkarm/fq(i), sqrt_drag_min)
+ drag_m(i) = us*us
+ drag_t(i) = us*bs
+ drag_q(i) = us*qs
+ u_star(i) = us*speed(i)
+ b_star(i) = bs*delta_b(i)
+ endif
+ enddo
+
+ end if
+
+end subroutine monin_obukhov_drag_1d
+!==============================================================================
+ subroutine monin_obukhov_solve_zeta(error, zeta_min, max_iter, small, &
+ & stable_option, rich_crit, zeta_trans, &
+ & n, rich, z, z0, zt, zq, f_m, f_t, f_q, mask, ier)
+
+ implicit none
+
+ real , intent(in ) :: error ! = 1.e-04
+ real , intent(in ) :: zeta_min ! = 1.e-06
+ integer, intent(in ) :: max_iter ! = 20
+ real , intent(in ) :: small ! = 1.e-04
+ integer, intent(in ) :: stable_option
+ real , intent(in ) :: rich_crit, zeta_trans
+ integer, intent(in ) :: n
+ real , intent(in ), dimension(n) :: rich, z, z0, zt, zq
+ logical, intent(in ), dimension(n) :: mask
+ real , intent( out), dimension(n) :: f_m, f_t, f_q
+ integer, intent( out) :: ier
+
+
+ real :: max_cor
+ integer :: iter
+
+ real, dimension(n) :: &
+ d_rich, rich_1, correction, corr, z_z0, z_zt, z_zq, &
+ ln_z_z0, ln_z_zt, ln_z_zq, zeta, &
+ phi_m, phi_m_0, phi_t, phi_t_0, rzeta, &
+ zeta_0, zeta_t, zeta_q, df_m, df_t
+
+ logical, dimension(n) :: mask_1
+
+ ier = 0
+
+ z_z0 = z/z0
+ z_zt = z/zt
+ z_zq = z/zq
+ ln_z_z0 = log(z_z0)
+ ln_z_zt = log(z_zt)
+ ln_z_zq = log(z_zq)
+
+ corr = 0.0
+ mask_1 = mask
+
+ ! initial guess
+
+ zeta = 0.0
+ where(mask_1)
+ zeta = rich*ln_z_z0*ln_z_z0/ln_z_zt
+ end where
+
+ where (mask_1 .and. rich >= 0.0)
+ zeta = zeta/(1.0 - rich/rich_crit)
+ end where
+
+ iter_loop: do iter = 1, max_iter
+
+ where (mask_1 .and. abs(zeta).lt.zeta_min)
+ zeta = 0.0
+ f_m = ln_z_z0
+ f_t = ln_z_zt
+ f_q = ln_z_zq
+ mask_1 = .false. ! don't do any more calculations at these pts
+ end where
+
+
+ zeta_0 = 0.0
+ zeta_t = 0.0
+ zeta_q = 0.0
+ where (mask_1)
+ rzeta = 1.0/zeta
+ zeta_0 = zeta/z_z0
+ zeta_t = zeta/z_zt
+ zeta_q = zeta/z_zq
+ end where
+
+ call monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
+ & n, phi_m , zeta , mask_1, ier)
+ call monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
+ & n, phi_m_0, zeta_0, mask_1, ier)
+ call monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
+ & n, phi_t , zeta , mask_1, ier)
+ call monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
+ & n, phi_t_0, zeta_t, mask_1, ier)
+
+ call monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
+ & n, f_m, zeta, zeta_0, ln_z_z0, mask_1, ier)
+ call monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
+ & n, f_t, f_q, zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq, mask_1, ier)
+
+ where (mask_1)
+ df_m = (phi_m - phi_m_0)*rzeta
+ df_t = (phi_t - phi_t_0)*rzeta
+ rich_1 = zeta*f_t/(f_m*f_m)
+ d_rich = rich_1*( rzeta + df_t/f_t - 2.0 *df_m/f_m)
+ correction = (rich - rich_1)/d_rich
+ corr = min(abs(correction),abs(correction/zeta))
+ ! the criterion corr < error seems to work ok, but is a bit arbitrary
+ ! when zeta is small the tolerance is reduced
+ end where
+
+ max_cor= maxval(corr)
+
+ if(max_cor > error) then
+ mask_1 = mask_1 .and. (corr > error)
+ ! change the mask so computation proceeds only on non-converged points
+ where(mask_1)
+ zeta = zeta + correction
+ end where
+ cycle iter_loop
+ else
+ return
+ end if
+
+ end do iter_loop
+
+ ier = 1 ! surface drag iteration did not converge
+
+end subroutine monin_obukhov_solve_zeta
+!==============================================================================
+ subroutine monin_obukhov_derivative_t(stable_option, rich_crit, zeta_trans, &
+ & n, phi_t, zeta, mask, ier)
+
+ ! the differential similarity function for buoyancy and tracers
+ ! Note: seems to be the same as monin_obukhov_derivative_m?
+
+ implicit none
+
+ integer, intent(in ) :: stable_option
+ real , intent(in ) :: rich_crit, zeta_trans
+ integer, intent(in ) :: n
+ real , intent( out), dimension(n) :: phi_t
+ real , intent(in ), dimension(n) :: zeta
+ logical, intent(in ), dimension(n) :: mask
+ integer, intent( out) :: ier
+
+ logical, dimension(n) :: stable, unstable
+ real :: b_stab, lambda
+
+ ier = 0
+ b_stab = 1.0/rich_crit
+
+ stable = mask .and. zeta >= 0.0
+ unstable = mask .and. zeta < 0.0
+
+ where (unstable)
+ phi_t = (1 - 16.0*zeta)**(-0.5)
+ end where
+
+ if(stable_option == 1) then
+
+ where (stable)
+ phi_t = 1.0 + zeta*(5.0 + b_stab*zeta)/(1.0 + zeta)
+ end where
+
+ else if(stable_option == 2) then
+
+ lambda = 1.0 + (5.0 - b_stab)*zeta_trans
+
+ where (stable .and. zeta < zeta_trans)
+ phi_t = 1 + 5.0*zeta
+ end where
+ where (stable .and. zeta >= zeta_trans)
+ phi_t = lambda + b_stab*zeta
+ end where
+
+ endif
+
+end subroutine monin_obukhov_derivative_t
+!=============================================================================
+ subroutine monin_obukhov_derivative_m(stable_option, rich_crit, zeta_trans, &
+ & n, phi_m, zeta, mask, ier)
+
+ ! the differential similarity function for momentum
+
+ implicit none
+
+ integer, intent(in ) :: stable_option
+ real , intent(in ) :: rich_crit, zeta_trans
+ integer, intent(in ) :: n
+ real , intent( out), dimension(n) :: phi_m
+ real , intent(in ), dimension(n) :: zeta
+ logical, intent(in ), dimension(n) :: mask
+ integer, intent(out ) :: ier
+
+ logical, dimension(n) :: stable, unstable
+ real , dimension(n) :: x
+ real :: b_stab, lambda
+
+
+ ier = 0
+ b_stab = 1.0/rich_crit
+
+ stable = mask .and. zeta >= 0.0
+ unstable = mask .and. zeta < 0.0
+
+ where (unstable)
+ x = (1 - 16.0*zeta )**(-0.5)
+ phi_m = sqrt(x) ! phi_m = (1 - 16.0*zeta)**(-0.25)
+ end where
+
+ if(stable_option == 1) then
+
+ where (stable)
+ phi_m = 1.0 + zeta *(5.0 + b_stab*zeta)/(1.0 + zeta)
+ end where
+
+ else if(stable_option == 2) then
+
+ lambda = 1.0 + (5.0 - b_stab)*zeta_trans
+
+ where (stable .and. zeta < zeta_trans)
+ phi_m = 1 + 5.0*zeta
+ end where
+ where (stable .and. zeta >= zeta_trans)
+ phi_m = lambda + b_stab*zeta
+ end where
+
+ endif
+
+end subroutine monin_obukhov_derivative_m
+!==============================================================================
+ subroutine monin_obukhov_integral_m(stable_option, rich_crit, zeta_trans, &
+ & n, psi_m, zeta, zeta_0, ln_z_z0, mask, ier)
+
+ ! the integral similarity function for momentum
+
+ implicit none
+
+ integer, intent(in ) :: stable_option
+ real , intent(in ) :: rich_crit, zeta_trans
+ integer, intent(in ) :: n
+ real , intent( out), dimension(n) :: psi_m
+ real , intent(in) , dimension(n) :: zeta, zeta_0, ln_z_z0
+ logical, intent(in) , dimension(n) :: mask
+ integer, intent(out) :: ier
+
+ real :: b_stab, lambda
+
+ real, dimension(n) :: x, x_0, x1, x1_0, num, denom, y
+ logical, dimension(n) :: stable, unstable, &
+ weakly_stable, strongly_stable
+
+ ier = 0
+
+ b_stab = 1.0/rich_crit
+
+ stable = mask .and. zeta >= 0.0
+ unstable = mask .and. zeta < 0.0
+
+ where(unstable)
+
+ x = sqrt(1 - 16.0*zeta)
+ x_0 = sqrt(1 - 16.0*zeta_0)
+
+ x = sqrt(x)
+ x_0 = sqrt(x_0)
+
+ x1 = 1.0 + x
+ x1_0 = 1.0 + x_0
+
+ num = x1*x1*(1.0 + x*x)
+ denom = x1_0*x1_0*(1.0 + x_0*x_0)
+ y = atan(x) - atan(x_0)
+ psi_m = ln_z_z0 - log(num/denom) + 2*y
+
+ end where
+
+ if( stable_option == 1) then
+
+ where (stable)
+ psi_m = ln_z_z0 + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_0)) &
+ + b_stab*(zeta - zeta_0)
+ end where
+
+ else if (stable_option == 2) then
+
+ lambda = 1.0 + (5.0 - b_stab)*zeta_trans
+
+ weakly_stable = stable .and. zeta <= zeta_trans
+ strongly_stable = stable .and. zeta > zeta_trans
+
+ where (weakly_stable)
+ psi_m = ln_z_z0 + 5.0*(zeta - zeta_0)
+ end where
+
+ where(strongly_stable)
+ x = (lambda - 1.0)*log(zeta/zeta_trans) + b_stab*(zeta - zeta_trans)
+ endwhere
+
+ where (strongly_stable .and. zeta_0 <= zeta_trans)
+ psi_m = ln_z_z0 + x + 5.0*(zeta_trans - zeta_0)
+ end where
+ where (strongly_stable .and. zeta_0 > zeta_trans)
+ psi_m = lambda*ln_z_z0 + b_stab*(zeta - zeta_0)
+ endwhere
+
+ end if
+
+end subroutine monin_obukhov_integral_m
+!==============================================================================
+ subroutine monin_obukhov_integral_tq(stable_option, rich_crit, zeta_trans, &
+ & n, psi_t, psi_q, zeta, zeta_t, zeta_q, &
+ & ln_z_zt, ln_z_zq, mask, ier)
+
+ ! the integral similarity function for moisture and tracers
+
+ implicit none
+
+ integer, intent(in ) :: stable_option
+ real, intent(in ) :: rich_crit, zeta_trans
+ integer, intent(in ) :: n
+ real , intent( out), dimension(n) :: psi_t, psi_q
+ real , intent(in) , dimension(n) :: zeta, zeta_t, zeta_q, ln_z_zt, ln_z_zq
+ logical, intent(in) , dimension(n) :: mask
+ integer, intent( out) :: ier
+
+ real, dimension(n) :: x, x_t, x_q
+ logical, dimension(n) :: stable, unstable, &
+ weakly_stable, strongly_stable
+ real :: b_stab, lambda
+
+ ier = 0
+
+ b_stab = 1.0/rich_crit
+
+stable = mask .and. zeta >= 0.0
+unstable = mask .and. zeta < 0.0
+
+where(unstable)
+
+ x = sqrt(1 - 16.0*zeta)
+ x_t = sqrt(1 - 16.0*zeta_t)
+ x_q = sqrt(1 - 16.0*zeta_q)
+
+ psi_t = ln_z_zt - 2.0*log( (1.0 + x)/(1.0 + x_t) )
+ psi_q = ln_z_zq - 2.0*log( (1.0 + x)/(1.0 + x_q) )
+
+end where
+
+if( stable_option == 1) then
+
+ where (stable)
+
+ psi_t = ln_z_zt + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_t)) &
+ + b_stab*(zeta - zeta_t)
+ psi_q = ln_z_zq + (5.0 - b_stab)*log((1.0 + zeta)/(1.0 + zeta_q)) &
+ + b_stab*(zeta - zeta_q)
+
+ end where
+
+else if (stable_option == 2) then
+
+ lambda = 1.0 + (5.0 - b_stab)*zeta_trans
+
+ weakly_stable = stable .and. zeta <= zeta_trans
+ strongly_stable = stable .and. zeta > zeta_trans
+
+ where (weakly_stable)
+ psi_t = ln_z_zt + 5.0*(zeta - zeta_t)
+ psi_q = ln_z_zq + 5.0*(zeta - zeta_q)
+ end where
+
+ where(strongly_stable)
+ x = (lambda - 1.0)*log(zeta/zeta_trans) + b_stab*(zeta - zeta_trans)
+ endwhere
+
+ where (strongly_stable .and. zeta_t <= zeta_trans)
+ psi_t = ln_z_zt + x + 5.0*(zeta_trans - zeta_t)
+ end where
+ where (strongly_stable .and. zeta_t > zeta_trans)
+ psi_t = lambda*ln_z_zt + b_stab*(zeta - zeta_t)
+ endwhere
+
+ where (strongly_stable .and. zeta_q <= zeta_trans)
+ psi_q = ln_z_zq + x + 5.0*(zeta_trans - zeta_q)
+ end where
+ where (strongly_stable .and. zeta_q > zeta_trans)
+ psi_q = lambda*ln_z_zq + b_stab*(zeta - zeta_q)
+ endwhere
+
+end if
+
+end subroutine monin_obukhov_integral_tq
+
+end module monin_obukhov_mod
diff --git a/driver/solo/ocean_rough.F90 b/driver/solo/ocean_rough.F90
new file mode 100644
index 000000000..514b511a0
--- /dev/null
+++ b/driver/solo/ocean_rough.F90
@@ -0,0 +1,225 @@
+!***********************************************************************
+!* 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 ocean_rough_mod
+
+!-----------------------------------------------------------------------
+
+use fms_mod, only: error_mesg, FATAL, file_exist, open_namelist_file, &
+ check_nml_error, mpp_pe, mpp_root_pe, close_file, &
+ write_version_number, stdlog
+
+implicit none
+private
+
+public :: compute_ocean_roughness, fixed_ocean_roughness
+
+!-----------------------------------------------------------------------
+!----- namelist -----
+
+ real :: roughness_init = 0.00044 ! not used in this version
+ real :: roughness_min = 1.e-6
+ real :: charnock = 0.032
+
+ real :: roughness_mom = 5.8e-5
+ real :: roughness_heat = 5.8e-5 ! was 4.00e-4
+ real :: roughness_moist = 5.8e-5
+! real, parameter :: zcoh1 = 1.4e-5
+! real, parameter :: zcoq1 = 1.3e-4
+ real :: zcoh1 = 0.0 !miz
+ real :: zcoq1 = 0.0 !miz
+ logical :: do_highwind = .false.
+ logical :: do_cap40 = .false.
+ real :: v10m = 32.5 !jhc
+ real :: v10n = 17.5 !jhc
+ logical :: do_init = .true.
+
+ character(len=32) :: rough_scheme = 'fixed' ! possible values:
+ ! 'fixed'
+ ! 'charnock'
+ ! 'beljaars'
+ logical:: read_namelist = .true.
+
+namelist /ocean_rough_nml/ roughness_init, roughness_heat, &
+ roughness_mom, roughness_moist, &
+ roughness_min, &
+ charnock, &
+ rough_scheme, do_highwind, &!miz
+ v10m, v10n, do_cap40, do_init, zcoh1, zcoq1 !sjl
+
+!-----------------------------------------------------------------------
+! ---- constants ----
+
+! ..... high wind speed - rough sea
+ real, parameter :: zcom1 = 1.8e-2 ! Charnock's constant
+! ..... low wind speed - smooth sea
+ real, parameter :: gnu = 1.5e-5
+ real, parameter :: zcom2 = 0.11
+ real, parameter :: zcoh2 = 0.40
+ real, parameter :: zcoq2 = 0.62
+ real, parameter :: grav = 9.80
+ real, parameter :: us10_adj = 0.9 ! reduction factor; added by SJL
+
+contains
+
+!#######################################################################
+
+ subroutine compute_ocean_roughness (u_star, speed, &
+ rough_mom, rough_heat, rough_moist, master )
+
+ real, intent(in) :: speed(:,:)
+ real, intent(inout) :: u_star(:,:)
+ real, intent(out) :: rough_mom(:,:), rough_heat(:,:), rough_moist(:,:)
+ logical:: master
+!-----------------------------------------------------------------------
+! computes ocean roughness for momentum using wind stress
+! and sets roughness for heat/moisture using namelist value
+!-----------------------------------------------------------------------
+
+ real, dimension(size(speed,1),size(speed,2)) :: ustar2, xx1, xx2, w10 !miz
+ real:: zt1
+ integer :: i, j
+ integer :: unit, ierr, io
+
+! ----- read and write namelist -----
+ if ( read_namelist .and. file_exist('input.nml')) then
+ unit = open_namelist_file ('input.nml')
+ if(master) write(*,*)'read input, unit', unit
+ ierr=1; do while (ierr /= 0)
+ read (unit, nml=ocean_rough_nml, iostat=io, end=10)
+ ierr = check_nml_error(io,'ocean_rough_nml')
+ if(master) write(*,*)'ierr =',ierr
+ enddo
+ 10 call close_file (unit)
+ if(master) write(*,*)'do_init=',do_init
+ if(master) write(*,*)'rough_scheme=',rough_scheme
+ read_namelist = .false.
+ endif
+
+
+ if (do_init) then
+
+ call ocean_rough_init(us10_adj*speed, rough_mom, rough_heat, rough_moist)
+! SJL: compute u_star using Eq (2), Moon et al.
+ u_star(:,:) = 0.4*speed(:,:)*us10_adj/log(10./rough_mom(:,:))
+
+ else
+ if (trim(rough_scheme) == 'fixed') then
+! --- set roughness for momentum and heat/moisture ---
+
+ call fixed_ocean_roughness (speed, rough_mom, rough_heat, rough_moist )
+
+
+! --- compute roughness for momentum, heat, moisture ---
+
+ else if (trim(rough_scheme) == 'beljaars' .or. &
+ trim(rough_scheme) == 'charnock') then
+
+ ustar2(:,:) = max(gnu*gnu, u_star(:,:)*u_star(:,:))
+ xx1(:,:) = gnu / sqrt(ustar2(:,:))
+ xx2(:,:) = ustar2(:,:) / grav
+
+ if (trim(rough_scheme) == 'charnock') then
+ rough_mom (:,:) = charnock * xx2(:,:)
+ rough_mom (:,:) = max( rough_mom(:,:), roughness_min )
+ rough_heat (:,:) = rough_mom (:,:)
+ rough_moist(:,:) = rough_mom (:,:)
+ else if (trim(rough_scheme) == 'beljaars') then
+ if (do_highwind) then ! Moon et al. formular
+! --- SJL ---- High Wind correction following Moon et al 2007 ------
+ do j=1,size(speed,2)
+ do i=1,size(speed,1)
+ w10(i,j) = 2.458 + u_star(i,j)*(20.255-0.56*u_star(i,j)) ! Eq(7) Moon et al.
+ if ( w10(i,j) > 12.5 ) then
+ rough_mom(i,j) = 0.001*(0.085*w10(i,j) - 0.58) ! Eq(8b) Moon et al.
+! SJL mods: cap the growth of z0 with w10 up to 40 m/s
+! z0 (w10=40) = 2.82E-3
+ if(do_cap40) rough_mom(i,j) = min( rough_mom(i,j), 2.82E-3)
+ else
+ rough_mom(i,j) = 0.0185/grav*u_star(i,j)**2 ! (8a) Moon et al.
+ endif
+! Ramp up the coefficient:
+ zt1 = min( 1., (w10(i,j)-v10n)/(v10m-v10n) )
+ rough_heat (i,j) = zcoh1*zt1*xx2(i,j) + zcoh2 * xx1(i,j)
+ rough_moist(i,j) = zcoq1*zt1*xx2(i,j) + zcoq2 * xx1(i,j)
+! --- lower limit on roughness? ---
+ rough_mom (i,j) = max( rough_mom (i,j), roughness_min )
+ rough_heat (i,j) = max( rough_heat (i,j), roughness_min )
+ rough_moist(i,j) = max( rough_moist(i,j), roughness_min )
+ enddo
+ enddo
+! SJL -----------------------------------------------------------------------------------
+ else
+ rough_mom (:,:) = zcom1 * xx2(:,:) + zcom2 * xx1(:,:)
+ rough_heat (:,:) = zcoh1 * xx2(:,:) + zcoh2 * xx1(:,:)
+ rough_moist(:,:) = zcoq1 * xx2(:,:) + zcoq2 * xx1(:,:)
+! --- lower limit on roughness? ---
+ rough_mom (:,:) = max( rough_mom (:,:), roughness_min )
+ rough_heat (:,:) = max( rough_heat (:,:), roughness_min )
+ rough_moist(:,:) = max( rough_moist(:,:), roughness_min )
+ endif
+ endif
+ endif
+ endif
+!-----------------------------------------------------------------------
+
+ end subroutine compute_ocean_roughness
+
+!#######################################################################
+
+ subroutine fixed_ocean_roughness ( speed, rough_mom, rough_heat, rough_moist )
+
+ real, intent(in) :: speed(:,:)
+ real, intent(out) :: rough_mom(:,:), rough_heat(:,:), rough_moist(:,:)
+
+ rough_mom = roughness_mom
+ rough_heat = roughness_heat
+ rough_moist = roughness_moist
+ end subroutine fixed_ocean_roughness
+
+!#######################################################################
+
+ subroutine ocean_rough_init(speed, z0, zt, zq)
+
+ real, intent(in) :: speed(:,:) ! 10-m wind speed
+ real, intent(out) :: z0(:,:), zt(:,:), zq(:,:)
+ integer i,j
+ integer :: unit, ierr, io
+
+ do j=1, size(speed,2)
+ do i=1, size(speed,1)
+ if ( speed(i,j) > 12.5 ) then
+ z0(i,j) = 0.001*(0.085*speed(i,j) - 0.58)
+ else
+ z0(i,j) = 0.0185/grav*(0.001*speed(i,j)**2+0.028*speed(i,j))**2
+ endif
+ z0(i,j) = max(z0(i,j), roughness_min) ! prevents blowup if cold start (V=0)
+ zt(i,j) = z0(i,j)
+ zq(i,j) = z0(i,j)
+ enddo
+ enddo
+
+ do_init = .false.
+
+ end subroutine ocean_rough_init
+
+end module ocean_rough_mod
+
diff --git a/driver/solo/qs_tables.F90 b/driver/solo/qs_tables.F90
new file mode 100644
index 000000000..83b7f26fe
--- /dev/null
+++ b/driver/solo/qs_tables.F90
@@ -0,0 +1,135 @@
+!***********************************************************************
+!* 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 qs_tables_mod
+
+use constants_mod, only: rdgas, rvgas, cp_air, cp_vapor, hlv
+
+implicit none
+logical:: qs_table_is_initialized = .false.
+real, allocatable, dimension(:,:) :: table_w(:), des_w(:)
+public :: qs_wat0, qs_wat, qs_wat_init
+
+ real, parameter:: e0 = 610.71 ! saturation vapor pressure at T0
+ real, parameter:: tice = 273.16
+! real, parameter:: c_liq = 4190. ! heat capacity of water at 0C
+ real, parameter:: c_liq = 4218.0 ! heat capacity of water at 0C
+ real, parameter:: cp_vap = cp_vapor ! 1846.
+! For consistency, cv_vap derived FMS constants:
+ real, parameter:: cv_vap = cp_vap - rvgas ! 1384.5
+ real, parameter:: cv_air = cp_air - rdgas
+#ifdef SIM_NGGPS
+ real, parameter:: dc_vap = 0.
+#else
+ real, parameter:: dc_vap = cp_vap - c_liq ! = -2344. isobaric heating/cooling
+#endif
+ real, parameter:: Lv0 = hlv - dc_vap*tice
+! L = hlv + (Cp_vapor-C_liq)*(T-T_ice)
+
+contains
+
+ real function qs_wat0(ta, den)
+! Pure water phase; universal dry/moist formular using air density
+! Input "den" can be either dry or moist air density
+ real, intent(in):: ta, den
+! local:
+ real es, ap1, dem
+ real, parameter:: tmin = tice - 160.
+ integer it
+
+! if (.not. qs_table_is_initialized) call qs_wat_init
+ ap1 = 10.*dim(ta, tmin) + 1. ! lower bound enforced
+ ap1 = min(2621., ap1) ! upper bound enforced
+ it = ap1
+ es = table_w(it) + (ap1-it)*des_w(it)
+ dem = rvgas*ta*den
+ qs_wat0 = es / dem
+
+ end function qs_wat0
+
+ real function qs_wat(ta, den, dqdt)
+! Pure water phase; universal dry/moist formular using air density
+! Input "den" can be either dry or moist air density
+! Full-form:
+! qsat = e0*rdgas/(rvgas*p_in)*exp((dc_vap*log(T_in/tice)+Lv0*(T_in-tice)/(T_in*tice))/rvgas)
+! simple-form:
+! qsat = e0*rdgas/(rvgas*p_in)*exp( hlv/rvgas*(T_in-tice)/(T_in*tice) )
+!
+ real, intent(in):: ta, den
+ real, intent(out):: dqdt
+! local:
+ real es, ap1, dem
+ real, parameter:: tmin = tice - 160.
+ integer it
+
+! if (.not. qs_table_is_initialized) call qs_wat_init
+ ap1 = 10.*dim(ta, tmin) + 1. ! lower bound enforced
+ ap1 = min(2621., ap1) ! upper bound enforced
+ it = ap1
+ es = table_w(it) + (ap1-it)*des_w(it)
+ dem = rvgas*ta*den
+ qs_wat = es / dem
+ it = ap1 - 0.5
+! Finite diff, del_T = 0.1:
+ dqdt = 10.*(des_w(it) + (ap1-it)*(des_w(it+1)-des_w(it))) / dem
+
+ end function qs_wat
+
+ subroutine qs_wat_init
+ integer, parameter:: length=2621
+ integer i
+
+ if( .not. qs_table_is_initialized ) then
+! generate es table (dt = 0.1 deg. c)
+ allocate ( table_w(length) )
+ allocate ( des_w(length) )
+
+ call qs_table_w(length )
+
+ do i=1,length-1
+ des_w(i) = max(0., table_w(i+1) - table_w(i))
+ enddo
+ des_w(length) = des_w(length-1)
+
+ qs_table_is_initialized = .true.
+ endif
+
+ end subroutine qs_wat_init
+
+ subroutine qs_table_w(n)
+ integer, intent(in):: n
+ real, parameter:: del_t=0.1
+ real:: tmin, tem, f0
+ integer i
+
+! constants
+ tmin = tice - 160.
+
+ do i=1,n
+ tem = tmin + del_t*real(i-1)
+! compute es over water
+! Lv0 = hlv - dc_vap*tice
+ table_w(i) = e0*exp((dc_vap*log(tem/tice)+Lv0*(tem-tice)/(tem*tice))/rvgas)
+ enddo
+
+ end subroutine qs_table_w
+
+end module qs_tables_mod
diff --git a/model/a2b_edge.F90 b/model/a2b_edge.F90
index 88c54ac96..1827ef5c4 100644
--- a/model/a2b_edge.F90
+++ b/model/a2b_edge.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module a2b_edge_mod
use fv_grid_utils_mod, only: great_circle_dist
diff --git a/model/boundary.F90 b/model/boundary.F90
index 3d59114ce..8c02048fa 100644
--- a/model/boundary.F90
+++ b/model/boundary.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module boundary_mod
use fv_mp_mod, only: is_master
@@ -29,7 +30,6 @@ module boundary_mod
use mpp_domains_mod, only: AGRID, BGRID_NE, CGRID_NE, DGRID_NE
use mpp_mod, only: mpp_error, FATAL, mpp_sum, mpp_sync, mpp_npes, mpp_broadcast, WARNING, mpp_pe
- use fv_mp_mod, only: mp_bcst
use fv_arrays_mod, only: fv_atmos_type, fv_nest_BC_type_3D, fv_grid_bounds_type
use mpp_mod, only: mpp_send, mpp_recv
use fv_timing_mod, only: timing_on, timing_off
diff --git a/driver/SHiELD/cloud_diagnosis.F90 b/model/cld_eff_rad.F90
similarity index 78%
rename from driver/SHiELD/cloud_diagnosis.F90
rename to model/cld_eff_rad.F90
index 5b284f87e..fc7caee12 100644
--- a/driver/SHiELD/cloud_diagnosis.F90
+++ b/model/cld_eff_rad.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -22,55 +22,36 @@
! cloud radii diagnosis built for gfdl cloud microphysics
! authors: linjiong zhou and shian - jiann lin
! =======================================================================
-module cloud_diagnosis_mod
+module cld_eff_rad_mod
+
+ use gfdl_cld_mp_mod, only: rdgas, grav, pi, zvir, t_ice, ql0_max, &
+ ccn_o, ccn_l, rhow, rhor, rhos, rhog, qi0_max
implicit none
private
- public cloud_diagnosis, cloud_diagnosis_init
-
- real, parameter :: grav = 9.80665 ! gfs: acceleration due to gravity
- real, parameter :: rdgas = 287.05 ! gfs: gas constant for dry air
- real, parameter :: rvgas = 461.50 ! gfs: gas constant for water vapor
- real, parameter :: pi = 3.1415926535897931 ! gfs: ratio of circle circumference to diameter
-
- real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077338443
+ public cld_eff_rad, cld_eff_rad_init
- real :: tice = 273.16 ! set tice = 165. to trun off ice - phase phys (kessler emulator)
-
- real :: ql0_max = 2.0e-3 ! max cloud water value (auto converted to rain)
- real :: qi0_max = 2.0e-4 ! max cloud ice value (by other sources)
real :: qi0_rei = 0.8e-4 ! max cloud ice value (by other sources)
- real :: ccn_o = 100. ! ccn over ocean (cm^ - 3)
- real :: ccn_l = 300. ! ccn over land (cm^ - 3)
-
- ! cloud diagnosis
-
real :: qmin = 1.0e-12 ! minimum mass mixing ratio (kg / kg)
- ! real :: beta = 1.22 ! defined in heymsfield and mcfarquhar, 1996
- real :: beta = 1.
- ! real :: beta = 0.5 ! testing
-
- ! real :: rewmin = 1.0, rewmax = 25.0
- ! real :: reimin = 10.0, reimax = 300.0
- ! real :: rermin = 25.0, rermax = 225.0
- ! real :: resmin = 300, resmax = 1000.0
- ! real :: regmin = 1000.0, regmax = 1.0e5
- ! lz
- ! real :: rewmin = 5.0, rewmax = 10.0
- ! real :: reimin = 10.0, reimax = 150.0
- ! real :: rermin = 0.0, rermax = 10000.0
- ! real :: resmin = 0.0, resmax = 10000.0
- ! real :: regmin = 0.0, regmax = 10000.0
- ! sjl
- !!! real :: reimin = 10.0, reimax = 150.0
+ real :: beta = 1.22 ! defined in heymsfield and mcfarquhar, 1996
+
+#ifdef SJ_CLD_TEST
real :: rewmin = 4.0, rewmax = 10.0
real :: reimin = 4.0, reimax = 250.0
real :: rermin = 5.0, rermax = 2000.0
real :: resmin = 5.0, resmax = 2000.0
real :: regmin = 5.0, regmax = 2000.0
+#else
+ real :: rewmin = 5.0, rewmax = 10.0
+ real :: reimin = 10.0, reimax = 150.0
+ real :: rermin = 0.0, rermax = 10000.0
+ real :: resmin = 0.0, resmax = 10000.0
+ real :: regmin = 0.0, regmax = 10000.0
+#endif
+ ! rewmax = 15.0, rermin = 15.0 ! Kokhanovsky 2004
real :: betaw = 1.0
real :: betai = 1.0
@@ -79,6 +60,7 @@ module cloud_diagnosis_mod
real :: betag = 1.0
logical :: liq_ice_combine = .true.
+ logical :: snow_grauple_combine = .false.
integer :: rewflag = 1
! 1: martin et al., 1994
@@ -91,10 +73,10 @@ module cloud_diagnosis_mod
! 4: kristjansson et al., 2000
! 5: wyser, 1998
- namelist / cloud_diagnosis_nml / &
- ql0_max, qi0_max, qi0_rei, ccn_o, ccn_l, qmin, beta, liq_ice_combine, rewflag, reiflag, &
- rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, resmax, regmin, regmax, &
- betaw, betai, betar, betas, betag
+ namelist / cld_eff_rad_nml / &
+ qi0_rei, qmin, beta, liq_ice_combine, rewflag, reiflag, rewmin, rewmax, reimin, &
+ reimax, rermin, rermax, resmin, resmax, regmin, regmax, betaw, betai, betar, betas, &
+ betag
contains
@@ -102,7 +84,7 @@ module cloud_diagnosis_mod
! radius of cloud species diagnosis
! =======================================================================
-subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg, &
+subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg, &
qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, &
cld, cloud, snowd, cnvw, cnvi, cnvc)
@@ -118,12 +100,12 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
real, intent (in), dimension (is:ie, ks:ke) :: cloud ! cloud fraction
real, intent (in), dimension (is:ie, ks:ke) :: qw, qi, qr, qs, qg ! mass mixing ratio (kg / kg)
- real, intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi ! convective cloud water, cloud ice mass mixing ratio (kg / kg)
+ real, intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi ! convective cloud water / ice mass mixing ratio (kg / kg)
real, intent (in), dimension (is:ie, ks:ke), optional :: cnvc ! convective cloud fraction
- real, intent (out), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg ! units: g / m^2
- real, intent (out), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg ! radii (micron)
- real, intent (out), dimension (is:ie, ks:ke) :: cld ! total cloud fraction
+ real, intent (inout), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg ! units: g / m^2
+ real, intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg ! radii (micron)
+ real, intent (inout), dimension (is:ie, ks:ke) :: cld ! total cloud fraction
! local variables
@@ -142,10 +124,9 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
real :: lambdar, lambdas, lambdag
real :: rei_fac
- real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 ! density (kg / m^3)
- real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 ! intercept parameters (m^ - 4)
- real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 ! parameters in terminal equation in lin et al., 1983
- real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 ! gamma values as a result of different alpha
+ real, parameter :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 ! intercept parameters (m^ - 4) in lin et al. (1983)
+ real, parameter :: alphar = 0.8, alphas = 0.25, alphag = 0.5 ! parameters in terminal equation in lin et al., (1983)
+ real, parameter :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 ! gamma values as a result of different alpha
real, parameter :: rho_0 = 50.e-3
real :: retab (138) = (/ &
@@ -193,10 +174,10 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
if (liq_ice_combine) then
do k = ks, ke
do i = is, ie
-
+#ifdef SJ_CLD_TEST
! frozen condensates:
! cloud ice treated as snow above freezing and graupel exists
- if (t (i, k) > tice) then
+ if (t (i, k) > t_ice) then
qms (i, k) = qmi (i, k) + qms (i, k)
qmi (i, k) = 0.
else
@@ -209,8 +190,16 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
endif
qmg (i, k) = 0. ! treating all graupel as "snow"
endif
+#else
+ qmw (i, k) = qmw (i, k) + qmr (i, k)
+ qmr (i, k) = 0.0
+ qmi (i, k) = qmi (i, k) + qms (i, k) + qmg (i, k)
+ qms (i, k) = 0.0
+ qmg (i, k) = 0.0
+#endif
enddo
enddo
+#ifdef SJ_CLD_TEST
else
! treating snow as ice, graupel as snow
! qmi (:, :) = qmi (:, :) + qms (:, :)
@@ -229,10 +218,19 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
endif
enddo
enddo
+#endif
endif
- ! liquid condensates:
+ if (snow_grauple_combine) then
+ do k = ks, ke
+ do i = is, ie
+ qms (i, k) = qms (i, k) + qmg (i, k)
+ qmg (i, k) = 0.0
+ enddo
+ enddo
+ endif
+ ! liquid condensates:
! sjl: 20180825
#ifdef COMBINE_QR
do k = ks, ke
@@ -265,12 +263,11 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
mask = min (max (lsm (i), 0.0), 2.0)
dpg = abs (delp (i, k)) / grav
- ! sjl:
! rho = p (i, k) / (rdgas * t (i, k) * (1. + zvir * qv)) ! needs qv
rho = p (i, k) / (rdgas * t (i, k))
! use rho = dpg / delz ! needs delz
- tc0 = t (i, k) - tice
+ tc0 = t (i, k) - t_ice
if (rewflag .eq. 1) then
@@ -278,8 +275,12 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
! cloud water (martin et al., 1994)
! -----------------------------------------------------------------------
- ccnw = 0.80 * (- 1.15e-3 * (ccn_o ** 2) + 0.963 * ccn_o + 5.30) * abs (mask - 1.0) + \
- 0.67 * (- 2.10e-4 * (ccn_l ** 2) + 0.568 * ccn_l - 27.9) * (1.0 - abs (mask - 1.0))
+#ifndef MARTIN_CCN
+ ccnw = ccn_o * abs (mask - 1.0) + ccn_l * (1.0 - abs (mask - 1.0))
+#else
+ ccnw = 0.80 * (- 1.15e-3 * (ccn_o ** 2) + 0.963 * ccn_o + 5.30) * abs (mask - 1.0) + &
+ 0.67 * (- 2.10e-4 * (ccn_l ** 2) + 0.568 * ccn_l - 27.9) * (1.0 - abs (mask - 1.0))
+#endif
if (qmw (i, k) .gt. qmin) then
qcw (i, k) = betaw * dpg * qmw (i, k) * 1.0e3
@@ -302,7 +303,7 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
if (qmw (i, k) .gt. qmin) then
qcw (i, k) = betaw * dpg * qmw (i, k) * 1.0e3
- rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) / cld (i, k) * rho) / (4.0 * pi * rhow * ccnw))) * 1.0e4
+ rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / (4.0 * pi * rhow * ccnw))) * 1.0e4
rew (i, k) = max (rewmin, min (rewmax, rew (i, k)))
else
qcw (i, k) = 0.0
@@ -319,8 +320,8 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
if (qmw (i, k) .gt. qmin) then
qcw (i, k) = betaw * 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, - tc0 / 30.0))) * (1.0 - abs (mask - 1.0))
+ rew (i, k) = 14.0 * abs (mask - 1.0) + &
+ (8.0 + (14.0 - 8.0) * min (1.0, max (0.0, - tc0 / 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
@@ -338,20 +339,18 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
if (qmi (i, k) .gt. qmin) then
qci (i, k) = betai * dpg * qmi (i, k) * 1.0e3
- ! sjl
- ! rei_fac = log (1.0e3 * qmi (i, k) * rho)
+#ifdef SJ_CLD_TEST
rei_fac = log (1.0e3 * min (qi0_rei, qmi (i, k)) * rho)
+#else
+ rei_fac = log (1.0e3 * qmi (i, k) * rho)
+#endif
if (tc0 .lt. - 50) then
- ! rei (i, k) = beta / 9.917 * exp ((1. - 0.891) * rei_fac) * 1.0e3
rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3
elseif (tc0 .lt. - 40) then
- ! rei (i, k) = beta / 9.337 * exp ((1. - 0.920) * rei_fac) * 1.0e3
- rei (i, k) = beta / 9.337 * exp (0.08 * rei_fac) * 1.0e3
+ rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3
elseif (tc0 .lt. - 30) then
- ! rei (i, k) = beta / 9.208 * exp ((1. - 0.945) * rei_fac) * 1.0e3
rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3
else
- ! rei (i, k) = beta / 9.387 * exp ((1. - 0.969) * rei_fac) * 1.0e3
rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3
endif
rei (i, k) = max (reimin, min (reimax, rei (i, k)))
@@ -403,6 +402,7 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
if (qmi (i, k) .gt. qmin) then
qci (i, k) = betai * dpg * qmi (i, k) * 1.0e3
+#ifdef SJ_CLD_TEST
! use fu2007 form below - 10 c
if (tc0 > - 10) then
! tc = - 10, rei = 40.6
@@ -412,6 +412,10 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
endif
! rei (i, k) = max (reimin, min (reimax, rei (i, k)))
rei (i, k) = max (reimin, rei (i, k))
+#else
+ rei (i, k) = 47.05 + tc0 * (0.6624 + 0.001741 * tc0)
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+#endif
else
qci (i, k) = 0.0
rei (i, k) = reimin
@@ -446,10 +450,9 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
if (qmi (i, k) .gt. qmin) then
qci (i, k) = betai * dpg * qmi (i, k) * 1.0e3
- bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / rho_0) * exp (1.5 * log (- min (- 1.e-6, tc0)))
+ bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / rho_0) * max (0.0, - tc0) ** 1.5
rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw))
- ! rei (i, k) = max (reimin, min (reimax, rei (i, k)))
- rei (i, k) = max (reimin, rei (i, k))
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
else
qci (i, k) = 0.0
rei (i, k) = reimin
@@ -503,36 +506,24 @@ subroutine cloud_diagnosis (is, ie, ks, ke, lsm, p, delp, t, qw, qi, qr, qs, qg,
enddo
-end subroutine cloud_diagnosis
+end subroutine cld_eff_rad
-subroutine cloud_diagnosis_init (nlunit, input_nml_file, logunit, fn_nml)
+subroutine cld_eff_rad_init (input_nml_file, logunit)
implicit none
- integer, intent (in) :: nlunit
- integer, intent (in) :: logunit
-
- character (len = 64), intent (in) :: fn_nml
character (len = *), intent (in) :: input_nml_file (:)
+ integer, intent (in) :: logunit
- integer :: ios
logical :: exists
-#ifdef INTERNAL_FILE_NML
- read (input_nml_file, nml = cloud_diagnosis_nml, iostat = ios)
-#else
- inquire (file = trim (fn_nml), exist = exists)
- if (.not. exists) then
- write (6, *) 'cloud_diagnosis :: namelist file: ', trim (fn_nml), ' does not exist'
- stop
- else
- open (unit = nlunit, file = fn_nml, readonly, status = 'old', iostat = ios)
- endif
- rewind (nlunit)
- read (nlunit, nml = cloud_diagnosis_nml)
- close (nlunit)
-#endif
+ read (input_nml_file, nml = cld_eff_rad_nml)
+
+ ! write version number and namelist to log file
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "cld_eff_rad_mod"
+ write (logunit, nml = cld_eff_rad_nml)
-end subroutine cloud_diagnosis_init
+end subroutine cld_eff_rad_init
-end module cloud_diagnosis_mod
+end module cld_eff_rad_mod
diff --git a/model/dyn_core.F90 b/model/dyn_core.F90
index bfce3d1d5..1a3c79a88 100644
--- a/model/dyn_core.F90
+++ b/model/dyn_core.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,9 +18,11 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module dyn_core_mod
- use constants_mod, only: rdgas, radius, cp_air, pi
+ use constants_mod, only: rdgas, cp_air, pi
+ use fv_arrays_mod, only: radius ! scaled for small earth
use mpp_mod, only: mpp_pe
use mpp_domains_mod, only: CGRID_NE, DGRID_NE, mpp_get_boundary, mpp_update_domains, &
domain2d
@@ -33,7 +35,7 @@ module dyn_core_mod
use nh_core_mod, only: Riem_Solver3, Riem_Solver_C, update_dz_c, update_dz_d, nh_bc
use tp_core_mod, only: copy_corners
use fv_timing_mod, only: timing_on, timing_off
- use fv_diagnostics_mod, only: prt_maxmin, fv_time, prt_mxm
+ use fv_diagnostics_mod, only: prt_maxmin, fv_time, prt_mxm, is_ideal_case
use fv_diag_column_mod, only: do_diag_debug_dyn, debug_column_dyn
#ifdef ROT3
use fv_update_phys_mod, only: update_dwinds_phys
@@ -87,7 +89,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
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, time_total)
+ init_step, i_pack, end_step, diss_est, time_total)
integer, intent(IN) :: npx
integer, intent(IN) :: npy
integer, intent(IN) :: npz
@@ -111,6 +113,7 @@ 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(in), optional:: time_total ! total time (seconds) since start
!-----------------------------------------------------------------------
@@ -169,6 +172,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
real wk(bd%isd:bd%ied,bd%jsd:bd%jed)
real fz(bd%is: bd%ie+1,bd%js: bd%je+1)
real heat_s(bd%is:bd%ie,bd%js:bd%je)
+! new array for stochastic kinetic energy backscatter (SKEB)
+ real diss_e(bd%is:bd%ie,bd%js:bd%je)
real damp_vt(npz+1)
integer nord_v(npz+1)
!-------------------------------------
@@ -267,6 +272,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
+ call init_ijk_mem(isd,ied, jsd,jed, npz, diss_est, 0.)
endif ! end init_step
! Empty the "flux capacitors"
@@ -330,6 +336,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
call timing_off('COMM_TOTAL')
endif
+#ifndef SW_DYNAMICS
if ( .not. hydrostatic ) then
call timing_on('COMM_TOTAL')
call start_group_halo_update(i_pack(7), w, domain)
@@ -373,14 +380,12 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
call timing_off('COMM_TOTAL')
endif
- endif
-
+ endif
+#endif
#ifdef SW_DYNAMICS
if (test_case>1) then
-#ifdef USE_OLD
- if (test_case==9) call case9_forcing1(phis, time_total)
-#endif
+ if (test_case==9) call case9_forcing1(phis, time_total, isd, ied, jsd, jed)
#endif
if ( it==1 ) then
@@ -559,16 +564,20 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
call start_group_halo_update(i_pack(9), uc, vc, domain, gridtype=CGRID_NE)
call timing_off('COMM_TOTAL')
#ifdef SW_DYNAMICS
-#ifdef USE_OLD
- if (test_case==9) call case9_forcing2(phis)
-#endif
+ if (test_case==9) call case9_forcing2(phis, isd, ied, jsd, jed)
endif !test_case>1
#endif
call timing_on('COMM_TOTAL')
if (flagstruct%inline_q .and. nq>0) call complete_group_halo_update(i_pack(10), domain)
- if (flagstruct%nord > 0) call complete_group_halo_update(i_pack(3), domain)
- call complete_group_halo_update(i_pack(9), domain)
+#ifdef SW_DYNAMICS
+ if (test_case > 1) then
+#endif
+ if (flagstruct%nord > 0) call complete_group_halo_update(i_pack(3), domain)
+ call complete_group_halo_update(i_pack(9), domain)
+#ifdef SW_DYNAMICS
+ endif
+#endif
call timing_off('COMM_TOTAL')
if (gridstruct%nested) then
@@ -649,9 +658,9 @@ 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) &
+!$OMP heat_source,is_ideal_case,diss_est,radius) &
!$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, z_rat)
+!$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, diss_e, z_rat)
do k=1,npz
hord_m = flagstruct%hord_mt
hord_t = flagstruct%hord_tm
@@ -688,7 +697,12 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
! no special damping of potential temperature in sponge layers
if ( k==1 ) then
! Divergence damping:
- nord_k=0; d2_divg = max(0.01, flagstruct%d2_bg, flagstruct%d2_bg_k1)
+ nord_k=0;
+ if (is_ideal_case) then
+ d2_divg = max(flagstruct%d2_bg, flagstruct%d2_bg_k1)
+ else
+ d2_divg = max(0.01, flagstruct%d2_bg, flagstruct%d2_bg_k1)
+ endif
! Vertical velocity:
nord_w=0; damp_w = d2_divg
if ( flagstruct%do_vort_damp ) then
@@ -716,7 +730,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
endif
endif
- if( hydrostatic .and. (.not.flagstruct%use_old_omega) .and. last_step ) then
+ if( (.not.flagstruct%use_old_omega) .and. last_step ) then
! Average horizontal "convergence" to cell center
do j=js,je
do i=is,ie
@@ -725,7 +739,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
enddo
endif
-!--- external mode divergence damping ---
+ !--- external mode divergence damping ---
if ( flagstruct%d_ext > 0. ) &
call a2b_ord2(delp(isd,jsd,k), wk, gridstruct, npx, npy, is, &
ie, js, je, ng, .false.)
@@ -748,12 +762,12 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
#else
q_con(isd:,jsd:,1), z_rat(isd,jsd), &
#endif
- kgb, heat_s, zvir, sphum, nq, q, k, npz, flagstruct%inline_q, dt, &
+ 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)
- if( hydrostatic .and. (.not.flagstruct%use_old_omega) .and. last_step ) then
+ if((.not.flagstruct%use_old_omega) .and. last_step ) then
! Average horizontal "convergence" to cell center
do j=js,je
do i=is,ie
@@ -769,11 +783,12 @@ 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 ) then
+ if ( flagstruct%d_con > 1.0E-5 .OR. flagstruct%do_diss_est ) then
! Average horizontal "convergence" to cell center
do j=js,je
do i=is,ie
heat_source(i,j,k) = heat_source(i,j,k) + heat_s(i,j)
+ diss_est(i,j,k) = diss_est(i,j,k) + diss_e(i,j)
enddo
enddo
endif
@@ -1095,7 +1110,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
#ifdef SW_DYNAMICS
#else
- if ( hydrostatic .and. last_step ) then
+ if ( last_step ) then
if ( flagstruct%use_old_omega ) then
!$OMP parallel do default(none) shared(is,ie,js,je,npz,omga,pe,pem,rdt)
do k=1,npz
@@ -1138,7 +1153,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
enddo
used=send_data(idiag%id_ws, ws, fv_time)
endif
- endif
+ endif
+
#endif
if (gridstruct%nested) then
diff --git a/model/fv_cmp.F90 b/model/fast_sat_adj.F90
similarity index 76%
rename from model/fv_cmp.F90
rename to model/fast_sat_adj.F90
index ddfec99f7..3abda323a 100644
--- a/model/fv_cmp.F90
+++ b/model/fast_sat_adj.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -19,64 +19,33 @@
!* If not, see .
!***********************************************************************
! =======================================================================
-! fast saturation adjustment is part of the gfdl cloud microphysics
+! fast saturation adjustment is part of the gfdl cloud microphysics.
+! it mainly consists of melting / freezing, condensation / evaporation,
+! sublimation / deposition, and autoconversion processes.
! developer: shian - jiann lin, linjiong zhou
! =======================================================================
-module fv_cmp_mod
+module fast_sat_adj_mod
- use constants_mod, only: rvgas, rdgas, grav, hlv, hlf, cp_air
- !use fv_mp_mod, only: is_master
use fv_arrays_mod, only: r_grid
- use gfdl_cloud_microphys_mod, only: ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt
- use gfdl_cloud_microphys_mod, only: icloud_f, sat_adj0, t_sub, cld_min
- use gfdl_cloud_microphys_mod, only: tau_r2g, tau_smlt, tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r
- use gfdl_cloud_microphys_mod, only: rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land
+ use gfdl_mp_mod, only: rvgas, rdgas, grav, hlv, hlf, cp_air, ql_gen, qi_gen, qi0_max, &
+ ql_mlt, ql0_max, qi_lim, qs_mlt, icloud_f, sat_adj0, t_sub, cld_min, tau_r2g, tau_smlt, &
+ tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r, rad_rain, rad_snow, rad_graupel, &
+ dw_ocean, dw_land, cp_vap, cv_air, cv_vap, c_ice, c_liq, dc_vap, dc_ice, t_ice, &
+ t_wfr, e00, rgrav, consv_checker, zvir, do_qa, te_err, prog_ccn, ccn_l, ccn_o, rhow, inflag
implicit none
private
- public fv_sat_adj, qs_init, c_ice, c_liq
+ public fast_sat_adj, qsmith_init
+ public wqs2_vect, qs_table, qs_tablew, qs_table2, wqs1, iqs1, wqs2, iqs2
- ! real, parameter :: cp_air = cp_air ! 1004.6, heat capacity of dry air at constant pressure, come from constants_mod
- real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0, heat capacity of water vapor at constant pressure
- real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume
- real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5, heat capacity of water vapor at constant volume
+ real, parameter :: lv0 = hlv - dc_vap * t_ice
+ real, parameter :: li00 = hlf - dc_ice * t_ice
- ! http: // www.engineeringtoolbox.com / ice - thermal - properties - d_576.html
- ! c_ice = 2050.0 at 0 deg c
- ! c_ice = 1972.0 at - 15 deg c
- ! c_ice = 1818.0 at - 40 deg c
- ! http: // www.engineeringtoolbox.com / water - thermal - properties - d_162.html
- ! c_liq = 4205.0 at 4 deg c
- ! c_liq = 4185.5 at 15 deg c
- ! c_liq = 4178.0 at 30 deg c
-
- real, parameter :: c_ice = 2106.0 ! ifs: heat capacity of ice at 0 deg c
- real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c
- ! real, parameter :: c_ice = 1972.0 ! gfdl: heat capacity of ice at - 15 deg c
- ! real, parameter :: c_liq = 4185.5 ! gfdl: heat capacity of liquid at 15 deg c
-
- real, parameter :: dc_vap = cp_vap - c_liq ! - 2339.5, isobaric heating / cooling
- real, parameter :: dc_ice = c_liq - c_ice ! 2213.5, isobaric heating / colling
-
- real, parameter :: tice = 273.16 ! freezing temperature
- real, parameter :: t_wfr = tice - 40. ! homogeneous freezing temperature
-
- real, parameter :: lv0 = hlv - dc_vap * tice ! 3.13905782e6, evaporation latent heat coefficient at 0 deg k
- real, parameter :: li00 = hlf - dc_ice * tice ! - 2.7105966e5, fussion latend heat coefficient at 0 deg k
-
- ! real (kind = r_grid), parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c
- real (kind = r_grid), parameter :: e00 = 611.21 ! ifs: saturation vapor pressure at 0 deg c
-
- real (kind = r_grid), parameter :: d2ice = dc_vap + dc_ice ! - 126, isobaric heating / cooling
- real (kind = r_grid), parameter :: li2 = lv0 + li00 ! 2.86799816e6, sublimation latent heat coefficient at 0 deg k
-
- real, parameter :: lat2 = (hlv + hlf) ** 2 ! used in bigg mechanism
-
- real :: d0_vap ! the same as dc_vap, except that cp_vap can be cp_vap or cv_vap
- real :: lv00 ! the same as lv0, except that cp_vap can be cp_vap or cv_vap
+ real (kind = r_grid), parameter :: d2ice = cp_vap - c_ice
+ real (kind = r_grid), parameter :: li2 = lv0 + li00
real, allocatable :: table (:), table2 (:), tablew (:), des2 (:), desw (:)
@@ -87,60 +56,63 @@ module fv_cmp_mod
! =======================================================================
! fast saturation adjustments
! this is designed for single - moment 6 - class cloud microphysics schemes
-! handles the heat release due to in situ phase changes
+! handles the heat release due to in situ phase changes.
! =======================================================================
-subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
- te0, qv, ql, qi, qr, qs, qg, hs, dpln, delz, pt, dp, q_con, cappa, &
- area, dtdt, out_dt, last_step, do_qa, qa)
+subroutine fast_sat_adj (mdt, is, ie, js, je, ng, hydrostatic, consv_te, &
+ te, qv, ql, qi, qr, qs, qg, qa, qnl, qni, hs, dpln, delz, pt, delp, &
+ q_con, cappa, gsize, dtdt, out_dt, last_step)
implicit none
- integer, intent (in) :: is, ie, js, je, ng
+ logical, intent (in) :: hydrostatic, consv_te, out_dt, last_step
- logical, intent (in) :: hydrostatic, consv_te, out_dt, last_step, do_qa
+ integer, intent (in) :: is, ie, js, je, ng
- real, intent (in) :: zvir, mdt ! remapping time step
+ real, intent (in) :: mdt
- real, intent (in), dimension (is - ng:ie + ng, js - ng:je + ng) :: dp, hs
+ real, intent (in), dimension (is - ng:ie + ng, js - ng:je + ng) :: delp, hs
real, intent (in), dimension (is:ie, js:je) :: dpln
- real, intent (in), dimension (is:, js:) :: delz
+ real, intent (in), dimension (is:ie, js:je) :: delz
+
+ real (kind = r_grid), intent (in), dimension (is:ie, js:je) :: gsize
- real, intent (inout), dimension (is - ng:ie + ng, js - ng:je + ng) :: pt, qv, ql, qi, qr, qs, qg
+ real, intent (inout), dimension (is - ng:ie + ng, js - ng:je + ng) :: pt, qv, ql, qr
+ real, intent (inout), dimension (is - ng:ie + ng, js - ng:je + ng) :: qi, qs, qg
real, intent (inout), dimension (is - ng:, js - ng:) :: q_con, cappa
real, intent (inout), dimension (is:ie, js:je) :: dtdt
- real, intent (out), dimension (is - ng:ie + ng, js - ng:je + ng) :: qa, te0
+ real, intent (inout), dimension (is - ng:ie + ng, js - ng:je + ng) :: qa, te, qnl, qni
- real (kind = r_grid), intent (in), dimension (is - ng:ie + ng, js - ng:je + ng) :: area
+ real (kind = r_grid), dimension (is:ie, js:je) :: te_beg, te_end, tw_beg, tw_end
real, dimension (is:ie) :: wqsat, dq2dt, qpz, cvm, t0, pt1, qstar
real, dimension (is:ie) :: icp2, lcp2, tcp2, tcp3
real, dimension (is:ie) :: den, q_liq, q_sol, q_cond, src, sink, hvar
- real, dimension (is:ie) :: mc_air, lhl, lhi
+ real, dimension (is:ie) :: mc_air, lhl, lhi, ccn, cin
- real :: qsw, rh
+ real :: d0_vap ! the same as dc_vap, except that cp_vap can be cp_vap or cv_vap
+ real :: lv00 ! the same as lv0, except that cp_vap can be cp_vap or cv_vap
+ real :: qsw, rh, lat2, ccn0
real :: tc, qsi, dqsdt, dq, dq0, pidep, qi_crt, tmp, dtmp
real :: tin, rqi, q_plus, q_minus
real :: sdt, dt_bigg, adj_fac
real :: fac_smlt, fac_r2g, fac_i2s, fac_imlt, fac_l2r, fac_v2l, fac_l2v
- real :: factor, qim, tice0, c_air, c_vap, dw
+ real :: factor, qim, c_air, c_vap, dw
integer :: i, j
- sdt = 0.5 * mdt ! half remapping time step
- dt_bigg = mdt ! bigg mechinism time step
-
- tice0 = tice - 0.01 ! 273.15, standard freezing temperature
+ sdt = 0.5 * mdt
+ dt_bigg = mdt
! -----------------------------------------------------------------------
- ! define conversion scalar / factor
+ ! conversion scalar / factor
! -----------------------------------------------------------------------
fac_i2s = 1. - exp (- mdt / tau_i2s)
- fac_v2l = 1. - exp (- sdt / tau_v2l)
fac_r2g = 1. - exp (- mdt / tau_r2g)
fac_l2r = 1. - exp (- mdt / tau_l2r)
+ fac_v2l = 1. - exp (- sdt / tau_v2l)
fac_l2v = 1. - exp (- sdt / tau_l2v)
fac_l2v = min (sat_adj0, fac_l2v)
@@ -149,7 +121,7 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
fac_smlt = 1. - exp (- mdt / tau_smlt)
! -----------------------------------------------------------------------
- ! define heat capacity of dry air and water vapor based on hydrostatical property
+ ! heat capacity of dry air and water vapor based on hydrostatical property
! -----------------------------------------------------------------------
if (hydrostatic) then
@@ -160,70 +132,105 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
c_vap = cv_vap
endif
d0_vap = c_vap - c_liq
- lv00 = hlv - d0_vap * tice
- ! dc_vap = cp_vap - c_liq ! - 2339.5
- ! d0_vap = cv_vap - c_liq ! - 2801.0
+ lv00 = hlv - d0_vap * t_ice
+
+ lat2 = (hlv + hlf) ** 2
- do j = js, je ! start j loop
+ do j = js, je
+
+ ! -----------------------------------------------------------------------
+ ! compute true temperature
+ ! -----------------------------------------------------------------------
do i = is, ie
q_liq (i) = ql (i, j) + qr (i, j)
q_sol (i) = qi (i, j) + qs (i, j) + qg (i, j)
qpz (i) = q_liq (i) + q_sol (i)
-#ifdef USE_COND
+#ifdef MOIST_CAPPA
pt1 (i) = pt (i, j) / ((1 + zvir * qv (i, j)) * (1 - qpz (i)))
#else
pt1 (i) = pt (i, j) / (1 + zvir * qv (i, j))
#endif
- t0 (i) = pt1 (i) ! true temperature
- qpz (i) = qpz (i) + qv (i, j) ! total_wat conserved in this routine
+ t0 (i) = pt1 (i)
+ qpz (i) = qpz (i) + qv (i, j)
enddo
! -----------------------------------------------------------------------
- ! define air density based on hydrostatical property
+ ! moist air density based on hydrostatical property
! -----------------------------------------------------------------------
if (hydrostatic) then
do i = is, ie
- den (i) = dp (i, j) / (dpln (i, j) * rdgas * pt (i, j))
+ den (i) = delp (i, j) / (dpln (i, j) * rdgas * pt (i, j))
enddo
else
do i = is, ie
- den (i) = - dp (i, j) / (grav * delz (i, j)) ! moist_air density
+ den (i) = - delp (i, j) / (grav * delz (i, j))
enddo
endif
! -----------------------------------------------------------------------
- ! define heat capacity and latend heat coefficient
+ ! calculate cloud condensation nuclei (ccn)
+ ! the following is based on klein eq. 15
+ ! -----------------------------------------------------------------------
+
+ if (prog_ccn) then
+ do i = is, ie
+ ccn (i) = max (10.0, qnl (i, j)) * 1.e6
+ cin (i) = max (10.0, qni (i, j)) * 1.e6
+ ccn (i) = ccn (i) / den (i)
+ enddo
+ else
+ do i = is, ie
+ ccn0 = (ccn_l * min (1., abs (hs (i, j)) / (10. * grav)) + &
+ ccn_o * (1. - min (1., abs (hs (i, j)) / (10. * grav)))) * 1.e6
+ ccn (i) = ccn0 / den (i)
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! moist heat capacity and latend heat coefficient
! -----------------------------------------------------------------------
do i = is, ie
- mc_air (i) = (1. - qpz (i)) * c_air ! constant
+ mc_air (i) = (1. - qpz (i)) * c_air
cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
lhi (i) = li00 + dc_ice * pt1 (i)
icp2 (i) = lhi (i) / cvm (i)
enddo
! -----------------------------------------------------------------------
- ! fix energy conservation
+ ! for energy fixer
! -----------------------------------------------------------------------
if (consv_te) then
if (hydrostatic) then
do i = is, ie
- te0 (i, j) = - c_air * t0 (i)
+ te (i, j) = - c_air * t0 (i)
enddo
else
do i = is, ie
-#ifdef USE_COND
- te0 (i, j) = - cvm (i) * t0 (i)
+#ifdef MOIST_CAPPA
+ te (i, j) = - cvm (i) * t0 (i)
#else
- te0 (i, j) = - c_air * t0 (i)
+ te (i, j) = - c_air * t0 (i)
#endif
enddo
endif
endif
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do i = is, ie
+ te_beg (i, j) = cvm (i) * pt1 (i) + lv00 * qv (i, j) - li00 * q_sol (i)
+ te_beg (i, j) = rgrav * te_beg (i, j) * delp (i, j) * gsize (i, j) ** 2.0
+ tw_beg (i, j) = rgrav * (qv (i, j) + q_liq (i) + q_sol (i)) * delp (i, j) * gsize (i, j) ** 2.0
+ enddo
+ endif
+
! -----------------------------------------------------------------------
! fix negative cloud ice with snow
! -----------------------------------------------------------------------
@@ -240,15 +247,12 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
! -----------------------------------------------------------------------
do i = is, ie
- if (qi (i, j) > 1.e-8 .and. pt1 (i) > tice) then
- sink (i) = min (qi (i, j), fac_imlt * (pt1 (i) - tice) / icp2 (i))
+ if (qi (i, j) > 1.e-8 .and. pt1 (i) > t_ice) then
+ sink (i) = min (qi (i, j), fac_imlt * (pt1 (i) - t_ice) / icp2 (i))
qi (i, j) = qi (i, j) - sink (i)
- ! sjl, may 17, 2017
- ! tmp = min (sink (i), dim (ql_mlt, ql (i, j))) ! max ql amount
- ! ql (i, j) = ql (i, j) + tmp
- ! qr (i, j) = qr (i, j) + sink (i) - tmp
- ! sjl, may 17, 2017
- ql (i, j) = ql (i, j) + sink (i)
+ tmp = min (sink (i), dim (ql_mlt, ql (i, j)))
+ ql (i, j) = ql (i, j) + tmp
+ qr (i, j) = qr (i, j) + sink (i) - tmp
q_liq (i) = q_liq (i) + sink (i)
q_sol (i) = q_sol (i) - sink (i)
cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
@@ -280,8 +284,6 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
endif
enddo
- ! after this point cloud ice & snow are positive definite
-
! -----------------------------------------------------------------------
! fix negative cloud water with rain or rain with available cloud water
! -----------------------------------------------------------------------
@@ -300,10 +302,11 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
! -----------------------------------------------------------------------
! enforce complete freezing of cloud water to cloud ice below - 48 c
+ ! it can be - 50 c, straka, 2009
! -----------------------------------------------------------------------
do i = is, ie
- dtmp = tice - 48. - pt1 (i)
+ dtmp = t_ice - 48. - pt1 (i)
if (ql (i, j) > 0. .and. dtmp > 0.) then
sink (i) = min (ql (i, j), dtmp / icp2 (i))
ql (i, j) = ql (i, j) - sink (i)
@@ -324,7 +327,7 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
lhi (i) = li00 + dc_ice * pt1 (i)
lcp2 (i) = lhl (i) / cvm (i)
icp2 (i) = lhi (i) / cvm (i)
- tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (tice, pt1 (i)) / 48.)
+ tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (t_ice, pt1 (i)) / 48.)
enddo
! -----------------------------------------------------------------------
@@ -336,14 +339,15 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
adj_fac = sat_adj0
do i = is, ie
dq0 = (qv (i, j) - wqsat (i)) / (1. + tcp3 (i) * dq2dt (i))
- if (dq0 > 0.) then ! whole grid - box saturated
+ if (dq0 > 0.) then
src (i) = min (adj_fac * dq0, max (ql_gen - ql (i, j), fac_v2l * dq0))
- else ! evaporation of ql
- ! sjl 20170703 added ql factor to prevent the situation of high ql and rh < 1
- ! factor = - min (1., fac_l2v * sqrt (max (0., ql (i, j)) / 1.e-5) * 10. * (1. - qv (i, j) / wqsat (i)))
+ else
+ ! sjl, 20170703
+ ! factor = - min (1., fac_l2v * sqrt (max (0., ql (i, j)) / 1.e-5) * &
+ ! 10. * (1. - qv (i, j) / wqsat (i)))
! factor = - fac_l2v
! factor = - 1
- factor = - min (1., fac_l2v * 10. * (1. - qv (i, j) / wqsat (i))) ! the rh dependent factor = 1 at 90%
+ factor = - min (1., fac_l2v * 10. * (1. - qv (i, j) / wqsat (i)))
src (i) = - min (ql (i, j), factor * dq0)
endif
qv (i, j) = qv (i, j) - src (i)
@@ -362,13 +366,13 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
lhi (i) = li00 + dc_ice * pt1 (i)
lcp2 (i) = lhl (i) / cvm (i)
icp2 (i) = lhi (i) / cvm (i)
- tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (tice, pt1 (i)) / 48.)
+ tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (t_ice, pt1 (i)) / 48.)
enddo
if (last_step) then
! -----------------------------------------------------------------------
- ! condensation / evaporation between water vapor and cloud water, last time step
+ ! condensation / evaporation between water vapor and cloud water at last time step
! enforce upper (no super_sat) & lower (critical rh) bounds
! final iteration:
! -----------------------------------------------------------------------
@@ -377,13 +381,15 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
do i = is, ie
dq0 = (qv (i, j) - wqsat (i)) / (1. + tcp3 (i) * dq2dt (i))
- if (dq0 > 0.) then ! remove super - saturation, prevent super saturation over water
+ if (dq0 > 0.) then
src (i) = dq0
- else ! evaporation of ql
- ! factor = - min (1., fac_l2v * sqrt (max (0., ql (i, j)) / 1.e-5) * 10. * (1. - qv (i, j) / wqsat (i))) ! the rh dependent factor = 1 at 90%
+ else
+ ! sjl, 20170703
+ ! factor = - min (1., fac_l2v * sqrt (max (0., ql (i, j)) / 1.e-5) * &
+ ! 10. * (1. - qv (i, j) / wqsat (i)))
! factor = - fac_l2v
! factor = - 1
- factor = - min (1., fac_l2v * 10. * (1. - qv (i, j) / wqsat (i))) ! the rh dependent factor = 1 at 90%
+ factor = - min (1., fac_l2v * 10. * (1. - qv (i, j) / wqsat (i)))
src (i) = - min (ql (i, j), factor * dq0)
endif
adj_fac = 1.
@@ -408,11 +414,12 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
endif
! -----------------------------------------------------------------------
- ! homogeneous freezing of cloud water to cloud ice
+ ! homogeneous freezing of cloud water to cloud ice, - 40 c to - 48 c
+ ! it can be - 50 c, straka, 2009
! -----------------------------------------------------------------------
do i = is, ie
- dtmp = t_wfr - pt1 (i) ! [ - 40, - 48]
+ dtmp = t_wfr - pt1 (i)
if (ql (i, j) > 0. .and. dtmp > 0.) then
sink (i) = min (ql (i, j), ql (i, j) * dtmp * 0.125, dtmp / icp2 (i))
ql (i, j) = ql (i, j) - sink (i)
@@ -438,9 +445,9 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
! -----------------------------------------------------------------------
do i = is, ie
- tc = tice0 - pt1 (i)
+ tc = t_ice - pt1 (i)
if (ql (i, j) > 0.0 .and. tc > 0.) then
- sink (i) = 3.3333e-10 * dt_bigg * (exp (0.66 * tc) - 1.) * den (i) * ql (i, j) ** 2
+ sink (i) = 100. / (rhow * ccn (i)) * dt_bigg * (exp (0.66 * tc) - 1.) * ql (i, j) ** 2
sink (i) = min (ql (i, j), tc / icp2 (i), sink (i))
ql (i, j) = ql (i, j) - sink (i)
qi (i, j) = qi (i, j) + sink (i)
@@ -461,13 +468,13 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
enddo
! -----------------------------------------------------------------------
- ! freezing of rain to graupel
+ ! freezing of rain to graupel, complete freezing below - 40 c
! -----------------------------------------------------------------------
do i = is, ie
- dtmp = (tice - 0.1) - pt1 (i)
+ dtmp = (t_ice - 0.1) - pt1 (i)
if (qr (i, j) > 1.e-7 .and. dtmp > 0.) then
- tmp = min (1., (dtmp * 0.025) ** 2) * qr (i, j) ! no limit on freezing below - 40 deg c
+ tmp = min (1., (dtmp * 0.025) ** 2) * qr (i, j)
sink (i) = min (tmp, fac_r2g * dtmp / icp2 (i))
qr (i, j) = qr (i, j) - sink (i)
qg (i, j) = qg (i, j) + sink (i)
@@ -488,18 +495,19 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
enddo
! -----------------------------------------------------------------------
- ! melting of snow to rain or cloud water
+ ! melting of snow to rain or cloud water, complete melting above 10 c
! -----------------------------------------------------------------------
do i = is, ie
- dtmp = pt1 (i) - (tice + 0.1)
+ dtmp = pt1 (i) - (t_ice + 0.1)
if (qs (i, j) > 1.e-7 .and. dtmp > 0.) then
- tmp = min (1., (dtmp * 0.1) ** 2) * qs (i, j) ! no limter on melting above 10 deg c
+ tmp = min (1., (dtmp * 0.1) ** 2) * qs (i, j)
sink (i) = min (tmp, fac_smlt * dtmp / icp2 (i))
- tmp = min (sink (i), dim (qs_mlt, ql (i, j))) ! max ql due to snow melt
+ tmp = min (sink (i), dim (qs_mlt, ql (i, j)))
qs (i, j) = qs (i, j) - sink (i)
ql (i, j) = ql (i, j) + tmp
qr (i, j) = qr (i, j) + sink (i) - tmp
+ ! ljz, 20190716
! qr (i, j) = qr (i, j) + sink (i)
q_liq (i) = q_liq (i) + sink (i)
q_sol (i) = q_sol (i) - sink (i)
@@ -525,8 +533,8 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
! -----------------------------------------------------------------------
do i = is, ie
- lhi (i) = li00 + dc_ice * pt1 (i)
lhl (i) = lv00 + d0_vap * pt1 (i)
+ lhi (i) = li00 + dc_ice * pt1 (i)
lcp2 (i) = lhl (i) / cvm (i)
icp2 (i) = lhi (i) / cvm (i)
tcp2 (i) = lcp2 (i) + icp2 (i)
@@ -538,20 +546,38 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
do i = is, ie
src (i) = 0.
- if (pt1 (i) < t_sub) then ! too cold to be accurate; freeze qv as a fix
+ if (pt1 (i) < t_sub) then
src (i) = dim (qv (i, j), 1.e-6)
- elseif (pt1 (i) < tice0) then
+ elseif (pt1 (i) < t_ice) then
qsi = iqs2 (pt1 (i), den (i), dqsdt)
dq = qv (i, j) - qsi
sink (i) = adj_fac * dq / (1. + tcp2 (i) * dqsdt)
if (qi (i, j) > 1.e-8) then
- pidep = sdt * dq * 349138.78 * exp (0.875 * log (qi (i, j) * den (i))) &
+ if (.not. prog_ccn) then
+ if (inflag .eq. 1) &
+ ! hong et al., 2004
+ cin (i) = 5.38e7 * exp (0.75 * log (qi (i, j) * den (i)))
+ if (inflag .eq. 2) &
+ ! meyers et al., 1992
+ cin (i) = exp (-2.80 + 0.262 * (t_ice - pt1 (i))) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 3) &
+ ! meyers et al., 1992
+ cin (i) = exp (-0.639 + 12.96 * (qv (i, j) / qsi - 1.0)) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 4) &
+ ! cooper, 1986
+ cin (i) = 5.e-3 * exp (0.304 * (t_ice - pt1 (i))) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 5) &
+ ! flecther, 1962
+ cin (i) = 1.e-5 * exp (0.5 * (t_ice - pt1 (i))) * 1000.0 ! convert from L^-1 to m^-3
+ endif
+ pidep = sdt * dq * 4.0 * 11.9 * exp (0.5 * log (qi (i, j) * den (i) * cin (i))) &
/ (qsi * den (i) * lat2 / (0.0243 * rvgas * pt1 (i) ** 2) + 4.42478e4)
else
pidep = 0.
endif
- if (dq > 0.) then ! vapor - > ice
- tmp = tice - pt1 (i)
+ if (dq > 0.) then
+ tmp = t_ice - pt1 (i)
+ ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (i)
qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (i)
src (i) = min (sink (i), max (qi_crt - qi (i, j), pidep), tmp / tcp2 (i))
else
@@ -566,22 +592,6 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
pt1 (i) = pt1 (i) + src (i) * (lhl (i) + lhi (i)) / cvm (i)
enddo
- ! -----------------------------------------------------------------------
- ! virtual temp updated
- ! -----------------------------------------------------------------------
-
- do i = is, ie
-#ifdef USE_COND
- q_con (i, j) = q_liq (i) + q_sol (i)
- tmp = 1. + zvir * qv (i, j)
- pt (i, j) = pt1 (i) * tmp * (1. - q_con (i, j))
- tmp = rdgas * tmp
- cappa (i, j) = tmp / (tmp + cvm (i))
-#else
- pt (i, j) = pt1 (i) * (1. + zvir * qv (i, j))
-#endif
- enddo
-
! -----------------------------------------------------------------------
! fix negative graupel with available cloud ice
! -----------------------------------------------------------------------
@@ -607,6 +617,34 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
endif
enddo
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do i = is, ie
+ te_end (i, j) = cvm (i) * pt1 (i) + lv00 * qv (i, j) - li00 * q_sol (i)
+ te_end (i, j) = rgrav * te_end (i, j) * delp (i, j) * gsize (i, j) ** 2.0
+ tw_end (i, j) = rgrav * (qv (i, j) + q_liq (i) + q_sol (i)) * delp (i, j) * gsize (i, j) ** 2.0
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! update virtual temperature
+ ! -----------------------------------------------------------------------
+
+ do i = is, ie
+#ifdef MOIST_CAPPA
+ q_con (i, j) = q_liq (i) + q_sol (i)
+ tmp = 1. + zvir * qv (i, j)
+ pt (i, j) = pt1 (i) * tmp * (1. - q_con (i, j))
+ tmp = rdgas * tmp
+ cappa (i, j) = tmp / (tmp + cvm (i))
+#else
+ pt (i, j) = pt1 (i) * (1. + zvir * qv (i, j))
+#endif
+ enddo
+
if (out_dt) then
do i = is, ie
dtdt (i, j) = dtdt (i, j) + pt1 (i) - t0 (i)
@@ -614,18 +652,18 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
endif
! -----------------------------------------------------------------------
- ! fix energy conservation
+ ! for energy fixer
! -----------------------------------------------------------------------
if (consv_te) then
do i = is, ie
if (hydrostatic) then
- te0 (i, j) = dp (i, j) * (te0 (i, j) + c_air * pt1 (i))
+ te (i, j) = delp (i, j) * (te (i, j) + c_air * pt1 (i))
else
-#ifdef USE_COND
- te0 (i, j) = dp (i, j) * (te0 (i, j) + cvm (i) * pt1 (i))
+#ifdef MOIST_CAPPA
+ te (i, j) = delp (i, j) * (te (i, j) + cvm (i) * pt1 (i))
#else
- te0 (i, j) = dp (i, j) * (te0 (i, j) + c_air * pt1 (i))
+ te (i, j) = delp (i, j) * (te (i, j) + c_air * pt1 (i))
#endif
endif
enddo
@@ -636,8 +674,8 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
! -----------------------------------------------------------------------
do i = is, ie
- lhi (i) = li00 + dc_ice * pt1 (i)
lhl (i) = lv00 + d0_vap * pt1 (i)
+ lhi (i) = li00 + dc_ice * pt1 (i)
cvm (i) = mc_air (i) + (qv (i, j) + q_liq (i) + q_sol (i)) * c_vap
lcp2 (i) = lhl (i) / cvm (i)
icp2 (i) = lhi (i) / cvm (i)
@@ -682,54 +720,52 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
enddo
! -----------------------------------------------------------------------
- ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity
+ ! use the "liquid - frozen water temperature" (tin) to compute saturated
+ ! specific humidity
! -----------------------------------------------------------------------
do i = is, ie
- tin = pt1 (i) - (lcp2 (i) * q_cond (i) + icp2 (i) * q_sol (i)) ! minimum temperature
- ! tin = pt1 (i) - ((lv00 + d0_vap * pt1 (i)) * q_cond (i) + &
- ! (li00 + dc_ice * pt1 (i)) * q_sol (i)) / (mc_air (i) + qpz (i) * c_vap)
+ tin = pt1 (i) - (lcp2 (i) * q_cond (i) + icp2 (i) * q_sol (i))
! -----------------------------------------------------------------------
- ! determine saturated specific humidity
+ ! compute saturated specific humidity
! -----------------------------------------------------------------------
if (tin <= t_wfr) then
- ! ice phase:
qstar (i) = iqs1 (tin, den (i))
- elseif (tin >= tice) then
- ! liquid phase:
+ elseif (tin >= t_ice) then
qstar (i) = wqs1 (tin, den (i))
else
- ! mixed phase:
qsi = iqs1 (tin, den (i))
qsw = wqs1 (tin, den (i))
if (q_cond (i) > 1.e-6) then
rqi = q_sol (i) / q_cond (i)
else
- ! mostly liquid water clouds at initial cloud development stage
- rqi = ((tice - tin) / (tice - t_wfr))
+ rqi = ((t_ice - tin) / (t_ice - t_wfr))
endif
qstar (i) = rqi * qsi + (1. - rqi) * qsw
endif
- ! higher than 10 m is considered "land" and will have higher subgrid variability
+ ! -----------------------------------------------------------------------
+ ! compute sub - grid variability
+ ! -----------------------------------------------------------------------
+
dw = dw_ocean + (dw_land - dw_ocean) * min (1., abs (hs (i, j)) / (10. * grav))
- ! "scale - aware" subgrid variability: 100 - km as the base
- hvar (i) = min (0.2, max (0.01, dw * sqrt (sqrt (area (i, j)) / 100.e3)))
+ hvar (i) = min (0.2, max (0.01, dw * sqrt (gsize (i, j) / 100.e3)))
! -----------------------------------------------------------------------
! partial cloudiness by pdf:
- ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the
- ! binary cloud scheme; qa = 0.5 if qstar (i) == qpz
+ ! assuming subgrid linear distribution in horizontal;
+ ! this is effectively a smoother for the binary cloud scheme;
+ ! qa = 0.5 if qstar == qpz;
! -----------------------------------------------------------------------
rh = qpz (i) / qstar (i)
! -----------------------------------------------------------------------
! icloud_f = 0: bug - fxied
- ! icloud_f = 1: old fvgfs gfdl) mp implementation
+ ! icloud_f = 1: old fvgfs gfdl_mp implementation
! icloud_f = 2: binary cloud scheme (0 / 1)
! -----------------------------------------------------------------------
@@ -754,12 +790,12 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
if (icloud_f == 0) then
qa (i, j) = (q_plus - qstar (i)) / (dq + dq)
else
- qa (i, j) = (q_plus - qstar (i)) / (2. * dq * (1. - q_cond (i)))
+ qa (i, j) = (q_plus - qstar (i)) / &
+ (2. * dq * (1. - q_cond (i)))
endif
else
qa (i, j) = 0.
endif
- ! impose minimum cloudiness if substantial q_cond (i) exist
if (q_cond (i) > 1.e-6) then
qa (i, j) = max (cld_min, qa (i, j))
endif
@@ -774,9 +810,26 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, &
endif
- enddo ! end j loop
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ if (abs (sum (te_end) - sum (te_beg)) / sum (te_beg) .gt. te_err) then
+ print *, "fast_sat_adj te: ", sum (te_beg) / sum (gsize ** 2.0), &
+ sum (te_end) / sum (gsize ** 2.0), &
+ (sum (te_end) - sum (te_beg)) / sum (te_beg)
+ endif
+ if (abs (sum (tw_end) - sum (tw_beg)) / sum (tw_beg) .gt. te_err) then
+ print *, "fast_sat_adj tw: ", sum (tw_beg) / sum (gsize ** 2.0), &
+ sum (tw_end) / sum (gsize ** 2.0), &
+ (sum (tw_end) - sum (tw_beg)) / sum (tw_beg)
+ endif
+ endif
-end subroutine fv_sat_adj
+end subroutine fast_sat_adj
! =======================================================================
! compute the saturated specific humidity for table ii
@@ -795,7 +848,7 @@ real function wqs1 (ta, den)
integer :: it
- tmin = tice - 160.
+ tmin = t_ice - 160.
ap1 = 10. * dim (ta, tmin) + 1.
ap1 = min (2621., ap1)
it = ap1
@@ -821,7 +874,7 @@ real function iqs1 (ta, den)
integer :: it
- tmin = tice - 160.
+ tmin = t_ice - 160.
ap1 = 10. * dim (ta, tmin) + 1.
ap1 = min (2621., ap1)
it = ap1
@@ -849,7 +902,7 @@ real function wqs2 (ta, den, dqdt)
integer :: it
- tmin = tice - 160.
+ tmin = t_ice - 160.
ap1 = 10. * dim (ta, tmin) + 1.
ap1 = min (2621., ap1)
it = ap1
@@ -883,7 +936,7 @@ subroutine wqs2_vect (is, ie, ta, den, wqsat, dqdt)
integer :: i, it
- tmin = tice - 160.
+ tmin = t_ice - 160.
do i = is, ie
ap1 = 10. * dim (ta (i), tmin) + 1.
@@ -893,7 +946,8 @@ subroutine wqs2_vect (is, ie, ta, den, wqsat, dqdt)
wqsat (i) = es / (rvgas * ta (i) * den (i))
it = ap1 - 0.5
! finite diff, del_t = 0.1:
- dqdt (i) = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta (i) * den (i))
+ dqdt (i) = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / &
+ (rvgas * ta (i) * den (i))
enddo
end subroutine wqs2_vect
@@ -917,7 +971,7 @@ real function iqs2 (ta, den, dqdt)
integer :: it
- tmin = tice - 160.
+ tmin = t_ice - 160.
ap1 = 10. * dim (ta, tmin) + 1.
ap1 = min (2621., ap1)
it = ap1
@@ -934,20 +988,16 @@ end function iqs2
! prepare saturation water vapor pressure tables
! =======================================================================
-subroutine qs_init (kmp)
+subroutine qsmith_init
implicit none
- integer, intent (in) :: kmp
-
integer, parameter :: length = 2621
integer :: i
if (mp_initialized) return
- !if (is_master ()) write (*, *) 'top layer for gfdl_mp = ', kmp
-
! generate es table (dt = 0.1 deg c)
allocate (table (length))
@@ -969,7 +1019,7 @@ subroutine qs_init (kmp)
mp_initialized = .true.
-end subroutine qs_init
+end subroutine qsmith_init
! =======================================================================
! saturation water vapor pressure table i
@@ -989,7 +1039,7 @@ subroutine qs_table (n)
integer :: i
- tmin = tice - 160.
+ tmin = t_ice - 160.
! -----------------------------------------------------------------------
! compute es over ice between - 160 deg c and 0 deg c.
@@ -997,9 +1047,9 @@ subroutine qs_table (n)
do i = 1, 1600
tem = tmin + delt * real (i - 1)
- fac0 = (tem - tice) / (tem * tice)
+ fac0 = (tem - t_ice) / (tem * t_ice)
fac1 = fac0 * li2
- fac2 = (d2ice * log (tem / tice) + fac1) / rvgas
+ fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas
table (i) = e00 * exp (fac2)
enddo
@@ -1009,9 +1059,9 @@ subroutine qs_table (n)
do i = 1, 1221
tem = 253.16 + delt * real (i - 1)
- fac0 = (tem - tice) / (tem * tice)
+ fac0 = (tem - t_ice) / (tem * t_ice)
fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas
+ fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
esh20 = e00 * exp (fac2)
if (i <= 200) then
esupc (i) = esh20
@@ -1026,7 +1076,7 @@ subroutine qs_table (n)
do i = 1, 200
tem = 253.16 + delt * real (i - 1)
- wice = 0.05 * (tice - tem)
+ wice = 0.05 * (t_ice - tem)
wh2o = 0.05 * (tem - 253.16)
table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i)
enddo
@@ -1049,7 +1099,7 @@ subroutine qs_tablew (n)
integer :: i
- tmin = tice - 160.
+ tmin = t_ice - 160.
! -----------------------------------------------------------------------
! compute es over water
@@ -1057,9 +1107,9 @@ subroutine qs_tablew (n)
do i = 1, n
tem = tmin + delt * real (i - 1)
- fac0 = (tem - tice) / (tem * tice)
+ fac0 = (tem - t_ice) / (tem * t_ice)
fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas
+ fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
tablew (i) = e00 * exp (fac2)
enddo
@@ -1081,23 +1131,23 @@ subroutine qs_table2 (n)
integer :: i, i0, i1
- tmin = tice - 160.
+ tmin = t_ice - 160.
do i = 1, n
tem0 = tmin + delt * real (i - 1)
- fac0 = (tem0 - tice) / (tem0 * tice)
+ fac0 = (tem0 - t_ice) / (tem0 * t_ice)
if (i <= 1600) then
! -----------------------------------------------------------------------
! compute es over ice between - 160 deg c and 0 deg c.
! -----------------------------------------------------------------------
fac1 = fac0 * li2
- fac2 = (d2ice * log (tem0 / tice) + fac1) / rvgas
+ fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas
else
! -----------------------------------------------------------------------
! compute es over water between 0 deg c and 102 deg c.
! -----------------------------------------------------------------------
fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem0 / tice) + fac1) / rvgas
+ fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas
endif
table2 (i) = e00 * exp (fac2)
enddo
@@ -1115,4 +1165,4 @@ subroutine qs_table2 (n)
end subroutine qs_table2
-end module fv_cmp_mod
+end module fast_sat_adj_mod
diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90
index 39bd8b15f..81edb3299 100644
--- a/model/fv_arrays.F90
+++ b/model/fv_arrays.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -29,9 +29,12 @@ module fv_arrays_mod
use horiz_interp_type_mod, only: horiz_interp_type
use mpp_mod, only: mpp_broadcast
use platform_mod, only: r8_kind
+ use constants_mod, only: cnst_radius => radius, cnst_omega => omega
public
integer, public, parameter :: R_GRID = r8_kind
+ real(kind=r8_kind), public :: radius = cnst_radius
+ real(kind=r8_kind), public :: omega = cnst_omega
!Several 'auxiliary' structures are introduced here. These are for
! the internal use by certain modules, and although fv_atmos_type
@@ -55,8 +58,6 @@ module fv_arrays_mod
integer :: id_u_dt_sg, id_v_dt_sg, id_t_dt_sg, id_qv_dt_sg
integer :: id_ws, id_te, id_amdt, id_mdt, id_divg, id_aam
logical :: initialized = .false.
- real sphum, liq_wat, ice_wat ! GFDL physics
- real rainwat, snowwat, graupel
real :: efx(max_step), efx_sum, efx_nest(max_step), efx_sum_nest, mtq(max_step), mtq_sum
integer :: steps
@@ -164,8 +165,11 @@ module fv_arrays_mod
integer :: npx_g, npy_g, ntiles_g ! global domain
real(kind=R_GRID) :: global_area
- logical :: g_sum_initialized = .false. !< Not currently used but can be useful
- logical:: sw_corner = .false., se_corner = .false., ne_corner = .false., nw_corner = .false.
+ logical :: g_sum_initialized = .false. !Not currently used but can be useful
+ logical:: sw_corner = .false.
+ logical:: se_corner = .false.
+ logical:: ne_corner = .false.
+ logical:: nw_corner = .false.
real(kind=R_GRID) :: da_min, da_max, da_min_c, da_max_c
@@ -187,7 +191,7 @@ module fv_arrays_mod
!< cubed-sphere will be used. If 4, a doubly-periodic
!< f-plane cartesian grid will be used. If 5, a user-defined
!< orthogonal grid will be used. If -1, the grid is read
- !< from INPUT/grid_spec.nc. Values 2, 3, 5, 6, and 7 are not
+ !< from INPUT/grid_spec.nc. Values 2, 3, 6, and 7 are not
!< supported and will likely not run. The default value is 0.
logical, pointer :: nested !< Whether this is a nested grid. .false. by default.
@@ -224,6 +228,7 @@ module fv_arrays_mod
! !< 5: a user-defined orthogonal grid for stand alone regional model
! -> moved to grid_tools
+
!> Momentum (or KE) options:
integer :: hord_mt = 10 !< Horizontal advection scheme for momentum fluxes. A
!< complete list of kord options is given in the
@@ -381,6 +386,9 @@ module fv_arrays_mod
!< horizontal advection schemes are enabled, but is unnecessary and
!< not recommended when using monotonic advection. The default is .false.
logical :: use_old_omega = .true.
+ logical :: remap_te = .false. !< A developmental option, remap total energy based on abs(kord_tm)
+ !< if kord_tm=0 use GMAO Cubic, otherwise as
+ !< Tv remapping
!> PG off centering:
real :: beta = 0.0 !< Parameter specifying fraction of time-off-centering for backwards
!< evaluation of the pressure gradient force. The default is 0.0, which
@@ -394,7 +402,7 @@ module fv_arrays_mod
!< the values of 'a_imp' and 'beta' should add to 1, so that the time-centering is
!< consistent between the PGF and the nonhydrostatic solver.
!< The proper range is 0 to 0.45.
-#ifdef SW_DYNAMIC
+#ifdef SW_DYNAMICS
integer :: n_sponge = 0 !< Controls the number of layers at the upper boundary on
!< which the 2Dx filter is applied. This does not control the sponge layer.
!< The default value is 0.
@@ -764,6 +772,7 @@ 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
!--------------------------------------------------------------------------------------
@@ -781,6 +790,9 @@ module fv_arrays_mod
!< horizontally-interpolated output from chgres. The default is .false.
!< Additional options are available through external_ic_nml.
logical :: hrrrv3_ic = .false.
+! following are namelist parameters for Stochastic Energy Baskscatter
+! dissipation estimate
+ logical :: do_diss_est = .false. !< compute and save dissipation estimate
logical :: ecmwf_ic = .false. !< If external_ic = .true., reads initial conditions from ECMWF analyses.
!< The default is .false.
logical :: gfs_phil = .false. !< if .T., compute geopotential inside of GFS physics (not used?)
@@ -875,23 +887,22 @@ module fv_arrays_mod
real(kind=R_GRID) :: deglon_start = -30., deglon_stop = 30., & !< boundaries of latlon patch
deglat_start = -30., deglat_stop = 30.
- logical :: regional = .false. !< Default setting for the regional domain.
-
- integer :: bc_update_interval = 3 !< Default setting for interval (hours) between external regional BC data files.
-
- integer :: nrows_blend = 0 !< # of blending rows in the outer integration domain.
- logical :: write_restart_with_bcs = .false. !< Default setting for using DA-updated BC files
- logical :: regional_bcs_from_gsi = .false. !< Default setting for writing restart files with boundary rows
-
-
!>Convenience pointers
integer, pointer :: grid_number
!f1p
logical :: adj_mass_vmr = .false. !TER: This is to reproduce answers for verona patch. This default can be changed
! to .true. in the next city release if desired
- !integer, pointer :: test_case
- !real, pointer :: alpha
+
+ logical :: w_limiter = .true. ! Fix excessive w - momentum conserving --- sjl
+
+ ! options related to regional mode
+ logical :: regional = .false. !< Default setting for the regional domain.
+ integer :: bc_update_interval = 3 !< Default setting for interval (hours) between external regional BC data files.
+ integer :: nrows_blend = 0 !< # of blending rows in the outer integration domain.
+ logical :: write_restart_with_bcs = .false. !< Default setting for using DA-updated BC files
+ logical :: regional_bcs_from_gsi = .false. !< Default setting for writing restart files with boundary rows.
+ logical :: pass_full_omega_to_physics_in_non_hydrostatic_mode = .false. !< Default to passing local omega to physics in non-hydrostatic mode
end type fv_flags_type
@@ -1019,6 +1030,10 @@ module fv_arrays_mod
real, _ALLOCATABLE :: prei(:,:) _NULL
real, _ALLOCATABLE :: pres(:,:) _NULL
real, _ALLOCATABLE :: preg(:,:) _NULL
+ real, _ALLOCATABLE :: cond(:,:) _NULL
+ real, _ALLOCATABLE :: dep(:,:) _NULL
+ real, _ALLOCATABLE :: reevap(:,:) _NULL
+ real, _ALLOCATABLE :: sub(:,:) _NULL
real, _ALLOCATABLE :: qv_dt(:,:,:)
real, _ALLOCATABLE :: ql_dt(:,:,:)
@@ -1059,6 +1074,15 @@ module fv_arrays_mod
end type nudge_diag_type
+ type sg_diag_type
+
+ real, _ALLOCATABLE :: t_dt(:,:,:)
+ real, _ALLOCATABLE :: u_dt(:,:,:)
+ real, _ALLOCATABLE :: v_dt(:,:,:)
+ real, _ALLOCATABLE :: qv_dt(:,:,:)
+
+ end type sg_diag_type
+
type coarse_restart_type
real, _ALLOCATABLE :: u(:,:,:)
@@ -1113,18 +1137,11 @@ module fv_arrays_mod
end type fv_coarse_graining_type
-!>@brief 'allocate_fv_nest_BC_type' is an interface to subroutines
-!! that allocate the 'fv_nest_BC_type' structure that holds the nested-grid BCs.
-!>@details The subroutines can pass the array bounds explicitly or not.
-!! The bounds in Atm%bd are used for the non-explicit case.
interface allocate_fv_nest_BC_type
module procedure allocate_fv_nest_BC_type_3D
module procedure allocate_fv_nest_BC_type_3D_Atm
end interface
-!>@brief 'deallocate_fv_nest_BC_type' is an interface to a subroutine
-!! that deallocates the 'fv_nest_BC_type' structure that holds the nested-grid
-!BCs.
interface deallocate_fv_nest_BC_type
module procedure deallocate_fv_nest_BC_type_3D
end interface
@@ -1216,11 +1233,12 @@ module fv_arrays_mod
real, _ALLOCATABLE :: pkz (:,:,:) _NULL !< finite-volume mean pk
! For phys coupling:
- real, _ALLOCATABLE :: u_srf(:,:) _NULL !< Surface u-wind
- real, _ALLOCATABLE :: v_srf(:,:) _NULL !< Surface v-wind
- real, _ALLOCATABLE :: sgh(:,:) _NULL !< Terrain standard deviation
- real, _ALLOCATABLE :: oro(:,:) _NULL !< land fraction (1: all land; 0: all water)
- real, _ALLOCATABLE :: ts(:,:) _NULL !< skin temperature (sst) from NCEP/GFS (K) -- tile
+ real, _ALLOCATABLE :: u_srf(:,:) _NULL ! Surface u-wind
+ real, _ALLOCATABLE :: v_srf(:,:) _NULL ! Surface v-wind
+ real, _ALLOCATABLE :: sgh(:,:) _NULL ! Terrain standard deviation
+ real, _ALLOCATABLE :: oro(:,:) _NULL ! land fraction (1: all land; 0: all water)
+ real, _ALLOCATABLE :: ts(:,:) _NULL ! skin temperature (sst) from NCEP/GFS (K) -- tile
+ real, _ALLOCATABLE :: ci(:,:) _NULL ! sea-ice fraction from external file
! For stochastic kinetic energy backscatter (SKEB)
real, _ALLOCATABLE :: diss_est(:,:,:) _NULL !< dissipation estimate taken from 'heat_source'
@@ -1228,9 +1246,10 @@ module fv_arrays_mod
!-----------------------------------------------------------------------
! Others:
!-----------------------------------------------------------------------
- real, _ALLOCATABLE :: phis(:,:) _NULL !< Surface geopotential (g*Z_surf)
- real, _ALLOCATABLE :: omga(:,:,:) _NULL !< Vertical pressure velocity (pa/s)
- real, _ALLOCATABLE :: ua(:,:,:) _NULL !< (ua, va) are mostly used as the A grid winds
+ real, _ALLOCATABLE :: phis(:,:) _NULL ! Surface geopotential (g*Z_surf)
+ real, _ALLOCATABLE :: omga(:,:,:) _NULL ! Vertical pressure velocity (pa/s)
+ real, _ALLOCATABLE :: local_omga(:,:,:) _NULL ! Vertical pressure velocity (pa/s)
+ real, _ALLOCATABLE :: ua(:,:,:) _NULL ! (ua, va) are mostly used as the A grid winds
real, _ALLOCATABLE :: va(:,:,:) _NULL
real, _ALLOCATABLE :: uc(:,:,:) _NULL ! (uc, vc) are mostly used as the C grid winds
real, _ALLOCATABLE :: vc(:,:,:) _NULL
@@ -1286,7 +1305,7 @@ module fv_arrays_mod
real :: ptop
- type(fv_grid_type) :: gridstruct
+ type(fv_grid_type) :: gridstruct
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -1313,20 +1332,18 @@ module fv_arrays_mod
!Hold on to coarse-grid global grid, so we don't have to waste processor time getting it again when starting to do grid nesting
real(kind=R_GRID), allocatable, dimension(:,:,:,:) :: grid_global
- integer :: atmos_axes(4)
+ integer :: atmos_axes(4)
type(inline_mp_type) :: inline_mp
type(phys_diag_type) :: phys_diag
type(nudge_diag_type) :: nudge_diag
+ type(sg_diag_type) :: sg_diag
+ type(coarse_restart_type) :: coarse_restart
type(fv_coarse_graining_type) :: coarse_graining
-
end type fv_atmos_type
contains
-!>@brief The subroutine 'allocate_fv_atmos_type' allocates the fv_atmos_type
-!>@details It includes an option to define dummy grids that have scalar and
-!! small arrays defined as null 3D arrays.
subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in, &
npx_in, npy_in, npz_in, ndims_in, ntiles_in, ncnst_in, nq_in, dummy, alloc_2d, ngrids_in)
@@ -1450,9 +1467,13 @@ 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%ts(is:ie,js:je) )
allocate ( Atm%phis(isd:ied ,jsd:jed ) )
allocate ( Atm%omga(isd:ied ,jsd:jed ,npz) ); Atm%omga=0.
+ if (.not. Atm%flagstruct%hydrostatic .and. .not. Atm%flagstruct%pass_full_omega_to_physics_in_non_hydrostatic_mode) then
+ allocate (Atm%local_omga(isd:ied,jsd:jed,npz)); Atm%local_omga = 0.
+ endif
allocate ( Atm%ua(isd:ied ,jsd:jed ,npz) )
allocate ( Atm%va(isd:ied ,jsd:jed ,npz) )
allocate ( Atm%uc(isd:ied+1,jsd:jed ,npz) )
@@ -1470,6 +1491,10 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie
allocate ( Atm%inline_mp%prei(is:ie,js:je) )
allocate ( Atm%inline_mp%pres(is:ie,js:je) )
allocate ( Atm%inline_mp%preg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%cond(is:ie,js:je) )
+ allocate ( Atm%inline_mp%dep(is:ie,js:je) )
+ allocate ( Atm%inline_mp%reevap(is:ie,js:je) )
+ allocate ( Atm%inline_mp%sub(is:ie,js:je) )
!--------------------------
! Non-hydrostatic dynamics:
@@ -1554,8 +1579,13 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie
Atm%inline_mp%prei(i,j) = real_big
Atm%inline_mp%pres(i,j) = real_big
Atm%inline_mp%preg(i,j) = real_big
+ Atm%inline_mp%cond(i,j) = real_big
+ Atm%inline_mp%dep(i,j) = real_big
+ Atm%inline_mp%reevap(i,j) = real_big
+ Atm%inline_mp%sub(i,j) = real_big
Atm%ts(i,j) = 300.
+
Atm%phis(i,j) = real_big
enddo
enddo
@@ -1788,6 +1818,7 @@ subroutine deallocate_fv_atmos_type(Atm)
deallocate ( Atm%pk )
deallocate ( Atm%peln )
deallocate ( Atm%pkz )
+ deallocate ( Atm%ts )
deallocate ( Atm%phis )
deallocate ( Atm%omga )
deallocate ( Atm%ua )
@@ -1800,11 +1831,16 @@ subroutine deallocate_fv_atmos_type(Atm)
deallocate ( Atm%cy )
deallocate ( Atm%ak )
deallocate ( Atm%bk )
+ deallocate ( Atm%diss_est )
deallocate ( Atm%inline_mp%prer )
deallocate ( Atm%inline_mp%prei )
deallocate ( Atm%inline_mp%pres )
deallocate ( Atm%inline_mp%preg )
+ deallocate ( Atm%inline_mp%cond )
+ deallocate ( Atm%inline_mp%dep )
+ deallocate ( Atm%inline_mp%reevap )
+ deallocate ( Atm%inline_mp%sub )
deallocate ( Atm%u_srf )
deallocate ( Atm%v_srf )
@@ -2118,3 +2154,4 @@ end subroutine deallocate_fv_nest_BC_type_3d
end module fv_arrays_mod
+
diff --git a/model/fv_control.F90 b/model/fv_control.F90
index 9fed20fcc..f939b604b 100644
--- a/model/fv_control.F90
+++ b/model/fv_control.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,7 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
-! $Id$
+
!
!----------------
! FV contro panel
@@ -26,7 +26,8 @@
module fv_control_mod
- use constants_mod, only: pi=>pi_8, kappa, radius, grav, rdgas
+ use constants_mod, only: pi=>pi_8, kappa, grav, rdgas
+ use fv_arrays_mod, only: radius ! scaled for small earth
use field_manager_mod, only: MODEL_ATMOS
use fms_mod, only: write_version_number, check_nml_error
use fms2_io_mod, only: file_exists
@@ -53,6 +54,7 @@ module fv_control_mod
use fv_mp_mod, only: mp_start, domain_decomp, mp_assign_gid, global_nest_domain
use fv_mp_mod, only: broadcast_domains, mp_barrier, is_master, setup_master, grids_master_procs, tile_fine
use fv_mp_mod, only: MAX_NNEST, MAX_NTILE
+ !use test_cases_mod, only: test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size
use test_cases_mod, only: read_namelist_test_case_nml
use fv_timing_mod, only: timing_on, timing_off, timing_init, timing_prt
use mpp_domains_mod, only: domain2D
@@ -170,12 +172,14 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
logical , pointer :: convert_ke
logical , pointer :: do_vort_damp
logical , pointer :: use_old_omega
+ logical , pointer :: remap_te
! PG off centering:
real , pointer :: beta
integer , pointer :: n_sponge
real , pointer :: d_ext
integer , pointer :: nwat
logical , pointer :: warm_start
+
logical , pointer :: inline_q
real , pointer :: shift_fac
logical , pointer :: do_schmidt, do_cube_transform
@@ -239,8 +243,6 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
logical , pointer :: adiabatic
logical , pointer :: moist_phys
logical , pointer :: do_Held_Suarez
- logical , pointer :: do_reed_physics
- logical , pointer :: reed_cond_only
logical , pointer :: reproduce_sum
logical , pointer :: adjust_dry_mass
logical , pointer :: fv_debug
@@ -248,14 +250,16 @@ 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 :: hrrrv3_ic
logical , pointer :: ecmwf_ic
logical , pointer :: gfs_phil
logical , pointer :: agrid_vel_rst
@@ -288,8 +292,8 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
real(kind=R_GRID), pointer :: deglat
logical, pointer :: nested, twowaynest
- logical, pointer :: regional
- integer, pointer :: bc_update_interval
+ logical, pointer :: regional, write_restart_with_bcs, regional_bcs_from_gsi
+ integer, pointer :: bc_update_interval, nrows_blend
integer, pointer :: parent_tile, refinement, nestbctype, nestupdate, nsponge, ioffset, joffset
real, pointer :: s_weight, update_blend
@@ -300,6 +304,7 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
logical, pointer :: write_only_coarse_intermediate_restarts
logical, pointer :: write_coarse_agrid_vel_rst
logical, pointer :: write_coarse_dgrid_vel_rst
+ logical, pointer :: pass_full_omega_to_physics_in_non_hydrostatic_mode
!!!!!!!!!! END POINTERS !!!!!!!!!!!!!!!!!!!!!!!!!!!!
this_grid = -1 ! default
@@ -454,6 +459,7 @@ 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(Atm(this_grid)%nml_filename)
!TODO test_case_nml moved to test_cases
+ call read_namelist_test_case_nml(Atm(this_grid)%nml_filename)
call mpp_get_current_pelist(Atm(this_grid)%pelist, commID=commID) ! for commID
call mp_start(commID,halo_update_type)
@@ -473,6 +479,13 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
endif
+
+ if (Atm(this_grid)%flagstruct%regional) then
+ if ( consv_te > 0.) then
+ call mpp_error(FATAL, 'The global energy fixer cannot be used on a regional grid. consv_te must be set to 0.')
+ end if
+ end if
+
!Now only one call to mpp_define_nest_domains for ALL nests
! set up nest_level, tile_fine, tile_coarse
! need number of tiles, npx, and npy on each grid
@@ -647,7 +660,6 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
!Initialize restart
call fv_restart_init()
-
contains
subroutine set_namelist_pointers(Atm)
@@ -665,6 +677,7 @@ subroutine set_namelist_pointers(Atm)
hord_tm => Atm%flagstruct%hord_tm
hord_dp => Atm%flagstruct%hord_dp
kord_tm => Atm%flagstruct%kord_tm
+ remap_te => Atm%flagstruct%remap_te
hord_tr => Atm%flagstruct%hord_tr
kord_tr => Atm%flagstruct%kord_tr
scale_z => Atm%flagstruct%scale_z
@@ -711,6 +724,9 @@ subroutine set_namelist_pointers(Atm)
target_lon => Atm%flagstruct%target_lon
regional => Atm%flagstruct%regional
bc_update_interval => Atm%flagstruct%bc_update_interval
+ nrows_blend => Atm%flagstruct%nrows_blend
+ write_restart_with_bcs => Atm%flagstruct%write_restart_with_bcs
+ regional_bcs_from_gsi => Atm%flagstruct%regional_bcs_from_gsi
reset_eta => Atm%flagstruct%reset_eta
p_fac => Atm%flagstruct%p_fac
a_imp => Atm%flagstruct%a_imp
@@ -761,17 +777,17 @@ subroutine set_namelist_pointers(Atm)
adiabatic => Atm%flagstruct%adiabatic
moist_phys => Atm%flagstruct%moist_phys
do_Held_Suarez => Atm%flagstruct%do_Held_Suarez
- do_reed_physics => Atm%flagstruct%do_reed_physics
- reed_cond_only => Atm%flagstruct%reed_cond_only
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
@@ -830,6 +846,7 @@ subroutine set_namelist_pointers(Atm)
write_only_coarse_intermediate_restarts => Atm%coarse_graining%write_only_coarse_intermediate_restarts
write_coarse_agrid_vel_rst => Atm%coarse_graining%write_coarse_agrid_vel_rst
write_coarse_dgrid_vel_rst => Atm%coarse_graining%write_coarse_dgrid_vel_rst
+ pass_full_omega_to_physics_in_non_hydrostatic_mode => Atm%flagstruct%pass_full_omega_to_physics_in_non_hydrostatic_mode
end subroutine set_namelist_pointers
@@ -900,12 +917,13 @@ subroutine read_namelist_fv_core_nml(Atm)
use_logp, p_fac, a_imp, k_split, n_split, m_split, q_split, print_freq, write_3d_diags, &
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, fv_debug, fv_land, nudge, do_sat_adj, do_inline_mp, do_f3d, &
+ kord_mt, kord_wz, kord_tm, kord_tr, remap_te, fv_debug, fv_land, &
+ do_am4_remap, nudge, do_sat_adj, do_inline_mp, do_f3d, &
external_ic, read_increment, ncep_ic, nggps_ic, hrrrv3_ic, ecmwf_ic, use_new_ncep, use_ncep_phy, fv_diag_ic, &
external_eta, res_latlon_dynamics, res_latlon_tracers, scale_z, w_max, z_min, lim_fac, &
dddmp, 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, &
- dry_mass, grid_type, do_Held_Suarez, do_reed_physics, reed_cond_only, &
+ 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, tau_h2o, rf_cutoff, nf_omega, hydrostatic, fv_sg_adj, sg_cutoff, breed_vortex_inline, &
@@ -916,12 +934,13 @@ subroutine read_namelist_fv_core_nml(Atm)
phys_hydrostatic, use_hydro_pressure, make_hybrid_z, old_divg_damp, add_noise, &
nested, twowaynest, nudge_qv, &
nestbctype, nestupdate, nsponge, s_weight, &
- check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, &
+ check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, &
do_uni_zfull, adj_mass_vmr, update_blend, regional,&
- bc_update_interval, write_coarse_restart_files,&
- write_coarse_diagnostics,&
+ bc_update_interval, nrows_blend, write_restart_with_bcs, regional_bcs_from_gsi, &
+ w_limiter, write_coarse_restart_files, write_coarse_diagnostics,&
write_only_coarse_intermediate_restarts, &
- write_coarse_agrid_vel_rst, write_coarse_dgrid_vel_rst
+ write_coarse_agrid_vel_rst, write_coarse_dgrid_vel_rst, &
+ pass_full_omega_to_physics_in_non_hydrostatic_mode
! Read FVCORE namelist
diff --git a/model/fv_dynamics.F90 b/model/fv_dynamics.F90
index 8a36a96d7..f8ebaff08 100644
--- a/model/fv_dynamics.F90
+++ b/model/fv_dynamics.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,8 +18,10 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_dynamics_mod
- use constants_mod, only: grav, pi=>pi_8, radius, hlv, rdgas, omega, rvgas, cp_vapor
+ use constants_mod, only: grav, pi=>pi_8, hlv, rdgas, rvgas, cp_vapor
+ 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_tracer2d_mod, only: tracer_2d, tracer_2d_1L, tracer_2d_nested
@@ -30,7 +32,7 @@ module fv_dynamics_mod
use fv_mp_mod, only: start_group_halo_update, complete_group_halo_update
use fv_timing_mod, only: timing_on, timing_off
use diag_manager_mod, only: send_data
- use fv_diagnostics_mod, only: fv_time, prt_mxm, range_check, prt_minmax
+ use fv_diagnostics_mod, only: fv_time, prt_mxm, range_check, prt_minmax, is_ideal_case
use mpp_domains_mod, only: DGRID_NE, CGRID_NE, mpp_update_domains, domain2D
use mpp_mod, only: mpp_pe
use field_manager_mod, only: MODEL_ATMOS
@@ -57,9 +59,8 @@ module fv_dynamics_mod
real :: agrav
-#ifdef HIWPP
real, allocatable:: u00(:,:,:), v00(:,:,:)
-#endif
+
private
public :: fv_dynamics
@@ -75,7 +76,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
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, time_total)
+ parent_grid, domain, inline_mp, diss_est, time_total)
real, intent(IN) :: bdt ! Large time-step
real, intent(IN) :: consv_te
@@ -106,6 +107,7 @@ 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
! ze0 no longer used
!-----------------------------------------------------------------------
@@ -163,7 +165,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
integer :: sphum, liq_wat = -999, ice_wat = -999 ! GFDL physics
integer :: rainwat = -999, snowwat = -999, graupel = -999, cld_amt = -999
integer :: theta_d = -999
- logical used, last_step, do_omega
+ logical used, last_step
integer, parameter :: max_packs=13
type(group_halo_update_type), save :: i_pack(max_packs)
integer :: is, ie, js, je
@@ -296,7 +298,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
!$OMP private(cvm)
do k=1,npz
if ( flagstruct%moist_phys ) then
- do j=js,je
+ 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)
@@ -315,15 +317,26 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
! (1.-q(i,j,k,sphum))/delz(i,j,k)) )
#endif
enddo
- 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
+ endif
enddo
endif
@@ -362,14 +375,14 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
endif
if( .not.flagstruct%RF_fast .and. flagstruct%tau > 0. ) then
- if ( gridstruct%grid_type<4 .or. gridstruct%bounded_domain ) then
+ if ( gridstruct%grid_type<4 .or. gridstruct%bounded_domain .or. 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, u, v, w, pt, &
ua, va, delz, gridstruct%agrid, cp_air, rdgas, ptop, hydrostatic, &
- .not. gridstruct%bounded_domain, flagstruct%rf_cutoff, gridstruct, domain, bd)
+ .not. (gridstruct%bounded_domain .or. is_ideal_case), flagstruct%rf_cutoff, gridstruct, domain, bd)
! endif
else
call Rayleigh_Friction(abs(bdt), npx, npy, npz, ks, pfull, flagstruct%tau, u, v, w, pt, &
@@ -377,30 +390,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
endif
endif
-#endif
-
-#ifndef SW_DYNAMICS
! Convert pt to virtual potential temperature on the first timestep
- if ( flagstruct%adiabatic .and. flagstruct%kord_tm>0 ) then
- if ( .not.pt_initialized )then
-!$OMP parallel do default(none) shared(theta_d,is,ie,js,je,npz,pt,pkz,q)
- do k=1,npz
- do j=js,je
- do i=is,ie
- pt(i,j,k) = pt(i,j,k)/pkz(i,j,k)
- enddo
- enddo
- if ( theta_d>0 ) then
- do j=js,je
- do i=is,ie
- q(i,j,k,theta_d) = pt(i,j,k)
- enddo
- enddo
- endif
- enddo
- pt_initialized = .true.
- endif
- else
!$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,dp1,pkz,q_con)
do k=1,npz
do j=js,je
@@ -413,8 +403,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
enddo
enddo
enddo
- endif
-#endif
+#endif !end ifdef SW_DYNAMICS
last_step = .false.
mdt = bdt / real(k_split)
@@ -437,6 +426,21 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
inline_mp%prei = 0.0
inline_mp%pres = 0.0
inline_mp%preg = 0.0
+ inline_mp%cond = 0.0
+ inline_mp%dep = 0.0
+ inline_mp%reevap = 0.0
+ inline_mp%sub = 0.0
+ if (allocated(inline_mp%qv_dt)) inline_mp%qv_dt = 0.0
+ if (allocated(inline_mp%ql_dt)) inline_mp%ql_dt = 0.0
+ if (allocated(inline_mp%qi_dt)) inline_mp%qi_dt = 0.0
+ if (allocated(inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt = 0.0
+ if (allocated(inline_mp%qr_dt)) inline_mp%qr_dt = 0.0
+ if (allocated(inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt = 0.0
+ if (allocated(inline_mp%qg_dt)) inline_mp%qg_dt = 0.0
+ if (allocated(inline_mp%qs_dt)) inline_mp%qs_dt = 0.0
+ 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
endif
call timing_on('FV_DYN_LOOP')
@@ -483,7 +487,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
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, time_total)
+ domain, n_map==1, i_pack, last_step, diss_est, time_total)
call timing_off('DYN_CORE')
@@ -555,20 +559,20 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
if ( iq==cld_amt ) kord_tracer(iq) = 9 ! monotonic
enddo
- do_omega = hydrostatic .and. last_step
call timing_on('Remapping')
-#ifdef AVEC_TIMERS
- call avec_timer_start(6)
-#endif
-
if ( flagstruct%fv_debug ) then
if (is_master()) write(*,'(A, I3, A1, I3)') 'before remap k_split ', n_map, '/', k_split
call prt_mxm('T_ldyn', pt, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain)
call prt_mxm('SPHUM_ldyn', q(isd,jsd,1,sphum ), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( liq_wat > 0 ) &
call prt_mxm('liq_wat_ldyn', q(isd,jsd,1,liq_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( rainwat > 0 ) &
call prt_mxm('rainwat_ldyn', q(isd,jsd,1,rainwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( ice_wat > 0 ) &
call prt_mxm('ice_wat_ldyn', q(isd,jsd,1,ice_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( snowwat > 0 ) &
call prt_mxm('snowwat_ldyn', q(isd,jsd,1,snowwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( graupel > 0 ) &
call prt_mxm('graupel_ldyn', q(isd,jsd,1,graupel), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
#ifdef TEST_LMH
@@ -587,33 +591,35 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
#endif
endif
-
call Lagrangian_to_Eulerian(last_step, consv_te, ps, pe, delp, &
pkz, pk, mdt, bdt, npx, npy, npz, is,ie,js,je, isd,ied,jsd,jed, &
nr, nwat, sphum, q_con, u, v, w, delz, pt, q, phis, &
zvir, cp_air, akap, cappa, flagstruct%kord_mt, flagstruct%kord_wz, &
- kord_tracer, flagstruct%kord_tm, peln, te_2d, &
+ kord_tracer, flagstruct%kord_tm, flagstruct%remap_te, peln, te_2d, &
ng, ua, va, omga, dp1, ws, fill, reproduce_sum, &
idiag%id_mdt>0, dtdt_m, ptop, ak, bk, pfull, gridstruct, domain, &
- flagstruct%do_sat_adj, hydrostatic, flagstruct%phys_hydrostatic, &
- hybrid_z, do_omega, &
+ 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%moist_phys)
+ flagstruct%moist_phys, flagstruct%w_limiter, flagstruct%do_am4_remap)
if ( flagstruct%fv_debug ) then
if (is_master()) write(*,'(A, I3, A1, I3)') 'finished k_split ', n_map, '/', k_split
call prt_mxm('T_dyn_a4', pt, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain)
- if (sphum > 0) call prt_mxm('SPHUM_dyn', q(isd,jsd,1,sphum ), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
- if (liq_wat > 0) call prt_mxm('liq_wat_dyn', q(isd,jsd,1,liq_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
- if (rainwat > 0) call prt_mxm('rainwat_dyn', q(isd,jsd,1,rainwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
- if (ice_wat > 0)call prt_mxm('ice_wat_dyn', q(isd,jsd,1,ice_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
- if (snowwat > 0)call prt_mxm('snowwat_dyn', q(isd,jsd,1,snowwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
- if (graupel > 0) call prt_mxm('graupel_dyn', q(isd,jsd,1,graupel), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ call prt_mxm('pkz', pkz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain)
+ call prt_mxm('SPHUM_dyn', q(isd,jsd,1,sphum ), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( liq_wat > 0 ) &
+ call prt_mxm('liq_wat_dyn', q(isd,jsd,1,liq_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( rainwat > 0 ) &
+ call prt_mxm('rainwat_dyn', q(isd,jsd,1,rainwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( ice_wat > 0 ) &
+ call prt_mxm('ice_wat_dyn', q(isd,jsd,1,ice_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( snowwat > 0 ) &
+ call prt_mxm('snowwat_dyn', q(isd,jsd,1,snowwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
+ if ( graupel > 0 ) &
+ call prt_mxm('graupel_dyn', q(isd,jsd,1,graupel), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain)
endif
-#ifdef AVEC_TIMERS
- call avec_timer_stop(6)
-#endif
call timing_off('Remapping')
#ifdef MOIST_CAPPA
if ( neststruct%nested .and. .not. last_step) then
@@ -630,26 +636,16 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
reg_bc_update_time )
endif
#endif
-
- if( last_step ) then
- if( .not. hydrostatic ) then
-!$OMP parallel do default(none) shared(is,ie,js,je,npz,omga,delp,delz,w)
- do k=1,npz
- do j=js,je
- do i=is,ie
- omga(i,j,k) = delp(i,j,k)/delz(i,j,k)*w(i,j,k)
- enddo
- enddo
- enddo
- endif
!--------------------------
! Filter omega for physics:
!--------------------------
- if(flagstruct%nf_omega>0) &
+ if (last_step) then
+ if(flagstruct%nf_omega>0) then
call del2_cubed(omga, 0.18*gridstruct%da_min, gridstruct, domain, npx, npy, npz, flagstruct%nf_omega, bd)
+ endif
endif
end if
-#endif
+#endif !endif SW_DYNAMICS
enddo ! n_map loop
! Initialize rain, ice, snow and graupel precipitaiton
@@ -658,6 +654,21 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
inline_mp%prei = inline_mp%prei / k_split
inline_mp%pres = inline_mp%pres / k_split
inline_mp%preg = inline_mp%preg / k_split
+ inline_mp%cond = inline_mp%cond / k_split
+ inline_mp%dep = inline_mp%dep / k_split
+ inline_mp%reevap = inline_mp%reevap / k_split
+ inline_mp%sub = inline_mp%sub / k_split
+ if (allocated(inline_mp%qv_dt)) inline_mp%qv_dt = inline_mp%qv_dt / bdt
+ if (allocated(inline_mp%ql_dt)) inline_mp%ql_dt = inline_mp%ql_dt / bdt
+ if (allocated(inline_mp%qi_dt)) inline_mp%qi_dt = inline_mp%qi_dt / bdt
+ if (allocated(inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt = inline_mp%liq_wat_dt / bdt
+ if (allocated(inline_mp%qr_dt)) inline_mp%qr_dt = inline_mp%qr_dt / bdt
+ if (allocated(inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt = inline_mp%ice_wat_dt / bdt
+ if (allocated(inline_mp%qg_dt)) inline_mp%qg_dt = inline_mp%qg_dt / bdt
+ if (allocated(inline_mp%qs_dt)) inline_mp%qs_dt = inline_mp%qs_dt / bdt
+ 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
endif
call timing_off('FV_DYN_LOOP')
@@ -950,7 +961,7 @@ subroutine Rayleigh_Super(dt, npx, npy, npz, ks, pm, phis, tau, u, v, w, pt, &
rcv = 1. / (cp - rg)
if ( .not. RF_initialized ) then
-#ifdef HIWPP
+ if ( is_ideal_case )then
allocate ( u00(is:ie, js:je+1,npz) )
allocate ( v00(is:ie+1,js:je ,npz) )
!$OMP parallel do default(none) shared(is,ie,js,je,npz,u00,u,v00,v)
@@ -966,30 +977,30 @@ subroutine Rayleigh_Super(dt, npx, npy, npz, ks, pm, phis, tau, u, v, w, pt, &
enddo
enddo
enddo
-#endif
+ endif
#ifdef SMALL_EARTH_TEST ! changed!!!
- tau0 = tau
+ tau0 = tau
#else
- tau0 = tau * sday
+ tau0 = tau * sday
#endif
- allocate( rf(npz) )
- rf(:) = 0.
+ allocate( rf(npz) )
+ rf(:) = 0.
- do k=1, ks+1
- if( is_master() ) write(6,*) k, 0.01*pm(k)
- enddo
- if( is_master() ) write(6,*) 'Rayleigh friction E-folding time (days):'
- do k=1, npz
- if ( pm(k) < rf_cutoff ) then
- rf(k) = dt/tau0*sin(0.5*pi*log(rf_cutoff/pm(k))/log(rf_cutoff/ptop))**2
- if( is_master() ) write(6,*) k, 0.01*pm(k), dt/(rf(k)*sday)
- kmax = k
- else
- exit
- endif
- enddo
- RF_initialized = .true.
- endif
+ do k=1, ks+1
+ if( is_master() ) write(6,*) k, 0.01*pm(k)
+ enddo
+ if( is_master() ) write(6,*) 'Rayleigh friction E-folding time (days):'
+ do k=1, npz
+ if ( pm(k) < rf_cutoff ) then
+ rf(k) = dt/tau0*sin(0.5*pi*log(rf_cutoff/pm(k))/log(rf_cutoff/ptop))**2
+ if( is_master() ) write(6,*) k, 0.01*pm(k), dt/(rf(k)*sday)
+ kmax = k
+ else
+ exit
+ endif
+ enddo
+ RF_initialized = .true.
+ endif
call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain)
@@ -1009,66 +1020,64 @@ subroutine Rayleigh_Super(dt, npx, npy, npz, ks, pm, phis, tau, u, v, w, pt, &
call timing_off('COMM_TOTAL')
!$OMP parallel do default(none) shared(is,ie,js,je,kmax,pm,rf_cutoff,w,rf,u,v, &
-#ifdef HIWPP
-!$OMP u00,v00, &
-#endif
+!$OMP u00,v00,is_ideal_case, &
!$OMP conserve,hydrostatic,pt,ua,va,u2f,cp,rg,ptop,rcv)
do k=1,kmax
if ( pm(k) < rf_cutoff ) then
-#ifdef HIWPP
- if (.not. hydrostatic) then
+ if (is_ideal_case) then
+ if (.not. hydrostatic) then
+ do j=js,je
+ do i=is,ie
+ w(i,j,k) = w(i,j,k)/(1.+rf(k))
+ enddo
+ enddo
+ endif
+ do j=js,je+1
+ do i=is,ie
+ u(i,j,k) = (u(i,j,k)+rf(k)*u00(i,j,k))/(1.+rf(k))
+ enddo
+ enddo
do j=js,je
+ do i=is,ie+1
+ v(i,j,k) = (v(i,j,k)+rf(k)*v00(i,j,k))/(1.+rf(k))
+ enddo
+ enddo
+ else
+ ! Add heat so as to conserve TE
+ if ( conserve ) then
+ if ( hydrostatic ) then
+ do j=js,je
+ do i=is,ie
+ pt(i,j,k) = pt(i,j,k) + 0.5*(ua(i,j,k)**2+va(i,j,k)**2)*(1.-u2f(i,j,k)**2)/(cp-rg*ptop/pm(k))
+ enddo
+ enddo
+ else
+ do j=js,je
+ do i=is,ie
+ pt(i,j,k) = pt(i,j,k) + 0.5*(ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2)*(1.-u2f(i,j,k)**2)*rcv
+ enddo
+ enddo
+ endif
+ endif
+
+ do j=js,je+1
do i=is,ie
- w(i,j,k) = w(i,j,k)/(1.+rf(k))
+ u(i,j,k) = 0.5*(u2f(i,j-1,k)+u2f(i,j,k))*u(i,j,k)
+ enddo
+ enddo
+ do j=js,je
+ do i=is,ie+1
+ v(i,j,k) = 0.5*(u2f(i-1,j,k)+u2f(i,j,k))*v(i,j,k)
enddo
enddo
+ if ( .not. hydrostatic ) then
+ do j=js,je
+ do i=is,ie
+ w(i,j,k) = u2f(i,j,k)*w(i,j,k)
+ enddo
+ enddo
+ endif
endif
- do j=js,je+1
- do i=is,ie
- u(i,j,k) = (u(i,j,k)+rf(k)*u00(i,j,k))/(1.+rf(k))
- enddo
- enddo
- do j=js,je
- do i=is,ie+1
- v(i,j,k) = (v(i,j,k)+rf(k)*v00(i,j,k))/(1.+rf(k))
- enddo
- enddo
-#else
-! Add heat so as to conserve TE
- if ( conserve ) then
- if ( hydrostatic ) then
- do j=js,je
- do i=is,ie
- pt(i,j,k) = pt(i,j,k) + 0.5*(ua(i,j,k)**2+va(i,j,k)**2)*(1.-u2f(i,j,k)**2)/(cp-rg*ptop/pm(k))
- enddo
- enddo
- else
- do j=js,je
- do i=is,ie
- pt(i,j,k) = pt(i,j,k) + 0.5*(ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2)*(1.-u2f(i,j,k)**2)*rcv
- enddo
- enddo
- endif
- endif
-
- do j=js,je+1
- do i=is,ie
- u(i,j,k) = 0.5*(u2f(i,j-1,k)+u2f(i,j,k))*u(i,j,k)
- enddo
- enddo
- do j=js,je
- do i=is,ie+1
- v(i,j,k) = 0.5*(u2f(i-1,j,k)+u2f(i,j,k))*v(i,j,k)
- enddo
- enddo
- if ( .not. hydrostatic ) then
- do j=js,je
- do i=is,ie
- w(i,j,k) = u2f(i,j,k)*w(i,j,k)
- enddo
- enddo
- endif
-#endif
endif
enddo
@@ -1237,7 +1246,7 @@ subroutine compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, 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) &
+!$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)
do j=js,je
do i=is,ie
@@ -1261,3 +1270,4 @@ subroutine compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd,
end subroutine compute_aam
end module fv_dynamics_mod
+
diff --git a/model/fv_fill.F90 b/model/fv_fill.F90
index 5742e2961..edcdff6d3 100644
--- a/model/fv_fill.F90
+++ b/model/fv_fill.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_fill_mod
use mpp_domains_mod, only: mpp_update_domains, domain2D
diff --git a/model/fv_grid_utils.F90 b/model/fv_grid_utils.F90
index 6dabc26bb..602c30e07 100644
--- a/model/fv_grid_utils.F90
+++ b/model/fv_grid_utils.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,10 +18,12 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_grid_utils_mod
#include
- use constants_mod, only: omega, pi=>pi_8, cnst_radius=>radius
+ use constants_mod, only: pi=>pi_8
+ use fv_arrays_mod, only: radius, omega ! scaled for small earth
use mpp_mod, only: FATAL, mpp_error, WARNING
use external_sst_mod, only: i_sst, j_sst, sst_ncep, sst_anom
use mpp_domains_mod, only: mpp_update_domains, DGRID_NE, mpp_global_sum
@@ -50,8 +52,6 @@ module fv_grid_utils_mod
real, parameter:: big_number=1.d8
real, parameter:: tiny_number=1.d-8
- real(kind=R_GRID) :: radius=cnst_radius
-
real, parameter:: ptop_min=1.d-8
public f_p
@@ -485,14 +485,8 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order)
call normalize_vect( ee2(1:3,i,j) )
! symmetrical grid
-#ifdef TEST_FP
- tmp1 = inner_prod(ee1(1:3,i,j), ee2(1:3,i,j))
- cosa(i,j) = sign(min(1., abs(tmp1)), tmp1)
- sina(i,j) = sqrt(max(0.,1. -cosa(i,j)**2))
-#else
cosa(i,j) = 0.5*(cos_sg(i-1,j-1,8)+cos_sg(i,j,6))
sina(i,j) = 0.5*(sin_sg(i-1,j-1,8)+sin_sg(i,j,6))
-#endif
enddo
enddo
@@ -582,56 +576,35 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order)
sin_sg(i,0,4) = sin_sg(1,i,1)
cos_sg(0,i,3) = cos_sg(i,1,2)
cos_sg(i,0,4) = cos_sg(1,i,1)
-!!! cos_sg(0,i,7) = cos_sg(i,1,6)
-!!! cos_sg(0,i,8) = cos_sg(i,1,7)
-!!! cos_sg(i,0,8) = cos_sg(1,i,9)
-!!! cos_sg(i,0,9) = cos_sg(1,i,6)
enddo
-!!! cos_sg(0,0,8) = 0.5*(cos_sg(0,1,7)+cos_sg(1,0,9))
-
endif
if ( nw_corner ) then
do i=npy,npy+2
sin_sg(0,i,3) = sin_sg(npy-i,npy-1,4)
cos_sg(0,i,3) = cos_sg(npy-i,npy-1,4)
-!!! cos_sg(0,i,7) = cos_sg(npy-i,npy-1,8)
-!!! cos_sg(0,i,8) = cos_sg(npy-i,npy-1,9)
enddo
do i=0,-2,-1
sin_sg(i,npy,2) = sin_sg(1,npy-i,1)
cos_sg(i,npy,2) = cos_sg(1,npy-i,1)
-!!! cos_sg(i,npy,6) = cos_sg(1,npy-i,9)
-!!! cos_sg(i,npy,7) = cos_sg(1,npy-i,6)
enddo
-!!! cos_sg(0,npy,7) = 0.5*(cos_sg(1,npy,6)+cos_sg(0,npy-1,8))
endif
if ( se_corner ) then
do j=0,-2,-1
sin_sg(npx,j,1) = sin_sg(npx-j,1,2)
cos_sg(npx,j,1) = cos_sg(npx-j,1,2)
-!!! cos_sg(npx,j,6) = cos_sg(npx-j,1,7)
-!!! cos_sg(npx,j,9) = cos_sg(npx-j,1,6)
enddo
do i=npx,npx+2
sin_sg(i,0,4) = sin_sg(npx-1,npx-i,3)
cos_sg(i,0,4) = cos_sg(npx-1,npx-i,3)
-!!! cos_sg(i,0,9) = cos_sg(npx-1,npx-i,8)
-!!! cos_sg(i,0,8) = cos_sg(npx-1,npx-i,7)
enddo
-!!! cos_sg(npx,0,9) = 0.5*(cos_sg(npx,1,6)+cos_sg(npx-1,0,8))
endif
if ( ne_corner ) then
do i=0,2
sin_sg(npx,npy+i,1) = sin_sg(npx+i,npy-1,4)
sin_sg(npx+i,npy,2) = sin_sg(npx-1,npy+i,3)
cos_sg(npx,npy+i,1) = cos_sg(npx+i,npy-1,4)
-!!! cos_sg(npx,npy+i,6) = cos_sg(npx+i,npy-1,9)
-!!! cos_sg(npx,npy+i,9) = cos_sg(npx+i,npy-1,8)
cos_sg(npx+i,npy,2) = cos_sg(npx-1,npy+i,3)
-!!! cos_sg(npx+i,npy,6) = cos_sg(npx-1,npy+i,7)
-!!! cos_sg(npx+i,npy,7) = cos_sg(npx-1,npy+i,8)
end do
-!!! cos_sg(npx,npy,6) = 0.5*(cos_sg(npx-1,npy,7)+cos_sg(npx,npy-1,9))
endif
else
@@ -650,42 +623,6 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order)
if ( grid_type < 3 ) then
-#ifdef USE_NORM_VECT
-!-------------------------------------------------------------
-! Make normal vect at face edges after consines are computed:
-!-------------------------------------------------------------
-! for old d2a2c_vect routines
- if (.not. Atm%gridstruct%bounded_domain) then
- do j=js-1,je+1
- if ( is==1 ) then
- i=1
- call vect_cross(ew(1,i,j,1), grid3(1,i,j+1), grid3(1,i,j))
- call normalize_vect( ew(1,i,j,1) )
- endif
- if ( (ie+1)==npx ) then
- i=npx
- call vect_cross(ew(1,i,j,1), grid3(1,i,j+1), grid3(1,i,j))
- call normalize_vect( ew(1,i,j,1) )
- endif
- enddo
-
- if ( js==1 ) then
- j=1
- do i=is-1,ie+1
- call vect_cross(es(1,i,j,2), grid3(1,i,j),grid3(1,i+1,j))
- call normalize_vect( es(1,i,j,2) )
- enddo
- endif
- if ( (je+1)==npy ) then
- j=npy
- do i=is-1,ie+1
- call vect_cross(es(1,i,j,2), grid3(1,i,j),grid3(1,i+1,j))
- call normalize_vect( es(1,i,j,2) )
- enddo
- endif
- endif
-#endif
-
! For omega computation:
! Unit vectors:
do j=js,je+1
@@ -741,7 +678,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order)
call global_mx_c(area_c(is:ie,js:je), is, ie, js, je, Atm%gridstruct%da_min_c, Atm%gridstruct%da_max_c)
- if( is_master() ) write(*,*) 'da_max_c/da_min_c=', Atm%gridstruct%da_max_c/Atm%gridstruct%da_min_c
+ if( is_master() ) write(*,*) 'da_max_c, da_min_c, da_max_c/da_min_c=', Atm%gridstruct%da_max_c, Atm%gridstruct%da_min_c, Atm%gridstruct%da_max_c/Atm%gridstruct%da_min_c
!------------------------------------------------
! Initialization for interpolation at face edges
@@ -1815,14 +1752,6 @@ subroutine get_center_vect( npx, npy, pp, u1, u2, bd )
u1(1:3,i,j) = 0.d0
u2(1:3,i,j) = 0.d0
else
-#ifdef OLD_VECT
- do k=1,3
- u1(k,i,j) = pp(k,i+1,j)+pp(k,i+1,j+1) - pp(k,i,j)-pp(k,i,j+1)
- u2(k,i,j) = pp(k,i,j+1)+pp(k,i+1,j+1) - pp(k,i,j)-pp(k,i+1,j)
- enddo
- call normalize_vect( u1(1,i,j) )
- call normalize_vect( u2(1,i,j) )
-#else
call cell_center3(pp(1,i,j), pp(1,i+1,j), pp(1,i,j+1), pp(1,i+1,j+1), pc)
! e1:
call mid_pt3_cart(pp(1,i,j), pp(1,i,j+1), p1)
@@ -1836,7 +1765,6 @@ subroutine get_center_vect( npx, npy, pp, u1, u2, bd )
call vect_cross(p3, p2, p1)
call vect_cross(u2(1,i,j), pc, p3)
call normalize_vect( u2(1,i,j) )
-#endif
endif
enddo
enddo
@@ -3205,11 +3133,6 @@ subroutine make_eta_level(km, pe, area, kks, ak, bk, ptop, domain, bd)
if ( is_master() ) then
write(*,*) 'Make_eta_level ...., ptop=', ptop
-#ifdef PRINT_GRID
- do k=1,km+1
- write(*,*) ph(k), ak(k), bk(k)
- enddo
-#endif
endif
deallocate ( pem )
diff --git a/model/fv_mapz.F90 b/model/fv_mapz.F90
index 75a813516..dbbfb8399 100644
--- a/model/fv_mapz.F90
+++ b/model/fv_mapz.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,25 +18,27 @@
!* License along with the FV3 dynamical core.
!* 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
- use constants_mod, only: radius, pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor
+ use constants_mod, only: pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor
+ use fv_arrays_mod, only: radius ! scaled for small earth
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, update_dwinds_phys
use fv_fill_mod, only: fillz
use mpp_domains_mod, only: mpp_update_domains, domain2d
- use mpp_mod, only: NOTE, mpp_error, get_unit, mpp_root_pe, mpp_pe
+ use mpp_mod, only: FATAL, NOTE, mpp_error, get_unit, mpp_root_pe, mpp_pe
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 fv_cmp_mod, only: qs_init, fv_sat_adj
-#ifndef DYCORE_SOLO
- use gfdl_mp_mod, only: gfdl_mp_driver
-#endif
+ use fast_sat_adj_mod, only: fast_sat_adj, qsmith_init
+ use gfdl_mp_mod, only: gfdl_mp_driver, c_liq, c_ice
implicit none
real, parameter:: consv_min = 0.001 ! below which no correction applies
@@ -44,16 +46,11 @@ module fv_mapz_mod
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:: c_ice = 2106. ! heat capacity of ice at 0.C
-! real, parameter:: c_ice = 1972. ! heat capacity of ice at -15.C
-! real, parameter:: c_liq = 4.1855e+3 ! GFS: heat capacity of water at 0C
- real, parameter:: c_liq = 4218. ! ECMWF-IFS
real, parameter:: cp_vap = cp_vapor ! 1846.
real, parameter:: tice = 273.16
real, parameter :: w_max = 90.
real, parameter :: w_min = -60.
- logical, parameter :: w_limiter = .False.
real(kind=4) :: E_Flux = 0.
private
@@ -66,14 +63,16 @@ module fv_mapz_mod
subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
mdt, pdt, npx, npy, km, is,ie,js,je, isd,ied,jsd,jed, &
nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, &
- akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, &
+ akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, remap_te, peln, te0_2d, &
ng, ua, va, omga, te, ws, fill, reproduce_sum, out_dt, dtdt, &
ptop, ak, bk, pfull, gridstruct, domain, do_sat_adj, &
- hydrostatic, phys_hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, &
+ hydrostatic, hybrid_z, adiabatic, do_adiabatic_init, &
do_inline_mp, inline_mp, c2l_ord, bd, fv_debug, &
- moist_phys)
+ moist_phys, w_limiter, do_am4_remap)
logical, intent(in):: last_step
logical, intent(in):: fv_debug
+ logical, intent(in):: w_limiter
+ logical, intent(in):: do_am4_remap
real, intent(in):: mdt ! remap time step
real, intent(in):: pdt ! phys time step
integer, intent(in):: npx, npy
@@ -102,7 +101,8 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
logical, intent(in):: do_inline_mp
logical, intent(in):: fill ! fill negative tracers
logical, intent(in):: reproduce_sum
- logical, intent(in):: do_omega, adiabatic, do_adiabatic_init
+ logical, intent(in):: adiabatic, do_adiabatic_init
+ logical, intent(in):: remap_te
real, intent(in) :: ptop
real, intent(in) :: ak(km+1)
real, intent(in) :: bk(km+1)
@@ -126,10 +126,10 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
! as input; output: temperature
real, intent(inout), dimension(isd:,jsd:,1:)::q_con, cappa
real, intent(inout), dimension(is:,js:,1:)::delz
- logical, intent(in):: hydrostatic, phys_hydrostatic
+ logical, intent(in):: hydrostatic
logical, intent(in):: hybrid_z
logical, intent(in):: out_dt
- logical, intent(in):: moist_phys
+ logical, intent(in):: moist_phys !not used --- lmh 13 may 21
real, intent(inout):: ua(isd:ied,jsd:jed,km) ! u-wind (m/s) on physics grid
real, intent(inout):: va(isd:ied,jsd:jed,km) ! v-wind (m/s) on physics grid
@@ -147,52 +147,59 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
! SJL 03.11.04: Initial version for partial remapping
!
!-----------------------------------------------------------------------
+ real, allocatable, dimension(:,:) :: dz, wa
real, allocatable, dimension(:,:,:) :: dp0, u0, v0
real, allocatable, dimension(:,:,:) :: u_dt, v_dt
real, dimension(is:ie,js:je):: te_2d, zsum0, zsum1, dpln
- real, dimension(is:ie,km) :: q2, dp2, t0, w2
+ real, dimension(is:ie,km) :: q2, dp2, t0, w2, q3
real, dimension(is:ie,km+1):: pe1, pe2, pk1, pk2, pn2, phis
real, dimension(isd:ied,jsd:jed,km):: pe4
real, dimension(is:ie+1,km+1):: pe0, pe3
- real, dimension(is:ie):: gsize, gz, cvm, qv
+ real, dimension(is:ie):: gsize, gz, cvm
+ real, dimension(isd:ied,jsd:jed,km):: qnl, qni
- real rcp, rg, rrg, bkh, dtmp, k1k
+ real rcp, rg, rrg, bkh, dtmp, k1k, dlnp, tmp, tpe
logical:: fast_mp_consv
integer:: i,j,k
integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, iq, n, kmp, kp, k_next
- integer:: ccn_cm3
-
- k1k = rdgas/cv_air ! akap / (1.-akap) = rg/Cv=0.4
- rg = rdgas
- rcp = 1./ cp
- rrg = -rdgas/grav
-
- liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
- ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
- rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
- snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
- graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
- cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt')
- ccn_cm3 = get_tracer_index (MODEL_ATMOS, 'ccn_cm3')
-
- if ( do_adiabatic_init .or. do_sat_adj ) then
- fast_mp_consv = (.not.do_adiabatic_init) .and. consv>consv_min
- do k=1,km
- kmp = k
- if ( pfull(k) > 10.E2 ) exit
- enddo
- call qs_init(kmp)
- endif
+ integer:: ccn_cm3, cin_cm3
+
+
+ k1k = rdgas/cv_air ! akap / (1.-akap) = rg/Cv=0.4
+ rg = rdgas
+ rcp = 1./ cp
+ rrg = -rdgas/grav
+
+ liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
+ ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
+ rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
+ snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
+ graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
+ cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt')
+ ccn_cm3 = get_tracer_index (MODEL_ATMOS, 'ccn_cm3')
+ cin_cm3 = get_tracer_index (MODEL_ATMOS, 'cin_cm3')
+
+ if ( do_adiabatic_init .or. do_sat_adj ) then
+ fast_mp_consv = (.not.do_adiabatic_init) .and. consv>consv_min
+ do k=1,km
+ kmp = k
+ if ( pfull(k) > 10.E2 ) exit
+ enddo
+ call qsmith_init
+ endif
!$OMP parallel do default(none) shared(is,ie,js,je,km,pe,ptop,kord_tm,hydrostatic, &
!$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, &
-!$OMP graupel,q_con,sphum,cappa,r_vir,rcp,k1k,delp, &
+!$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,do_omega,omga,rrg,kord_mt,pe4) &
-!$OMP private(qv,gz,cvm,kp,k_next,bkh,dp2, &
+!$OMP hs,w,ws,kord_wz,omga,rrg,kord_mt,pe4,w_limiter,cp,remap_te,do_am4_remap) &
+!$OMP private(gz,cvm,kp,k_next,bkh,dp2,dlnp,tpe, &
!$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2,w2)
- do 1000 j=js,je+1
+
+ do j=js,je+1
+
+ !0) Prepare pressure (pe, pk, ps, delp), temperature, density, and energy
do k=1,km+1
do i=is,ie
@@ -205,62 +212,113 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
pe2(i,km+1) = pe(i,km+1,j)
enddo
- if ( j /= (je+1) ) then
- if ( kord_tm < 0 ) then
-! Note: pt at this stage is Theta_v
- if ( hydrostatic ) then
-! Transform virtual pt to virtual Temp
- do k=1,km
- do i=is,ie
- pt(i,j,k) = pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k))/(akap*(peln(i,k+1,j)-peln(i,k,j)))
- enddo
- enddo
- else
-! Transform "density pt" to "density temp"
- do k=1,km
+ if ( j /= (je+1) ) then
+
+ if ( .not. remap_te ) then
+ if ( kord_tm < 0 ) then
+ ! Note: pt at this stage is Theta_v
+ if ( hydrostatic ) then
+ ! Transform virtual pt to virtual Temp
+ do k=1,km
+ do i=is,ie
+ pt(i,j,k) = pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k))/(akap*(peln(i,k+1,j)-peln(i,k,j)))
+ enddo
+ enddo
+ else
+ ! Transform "density pt" to "density temp"
+ 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, cvm)
- 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
+ call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, &
+ ice_wat, snowwat, graupel, q, gz, cvm)
+ 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
+ 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
- enddo
- endif ! hydro test
- elseif ( hydrostatic ) then
- call pkez(km, is, ie, js, je, j, pe, pk, akap, peln, pkz, ptop)
-! Compute cp*T + KE
- do k=1,km
+ enddo
+ endif ! hydro test
+
+
+ endif !kord_tm
+ else
+ !----------------------------------
+ ! Compute cp*T + KE +phis
+ do i=is,ie
+ phis(i,km+1) = hs(i,j)
+ enddo
+ if ( hydrostatic ) then
+ call pkez(km, is, ie, js, je, j, pe, pk, akap, peln, pkz, ptop)
+ do k=km,1,-1
+ do i=is,ie
+ phis(i,k) = phis(i,k+1) + cp_air*pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k)) !Pt:theta_v
+ enddo
+ enddo
+ do k=1,km+1
+ do i=is,ie
+ phis(i,k) = phis(i,k) * pe1(i,k)
+ enddo
+ enddo
+ do k=1,km
do i=is,ie
te(i,j,k) = 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)) &
- + cp_air*pt(i,j,k)*pkz(i,j,k)
+ 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)) &
+ + cp_air*pt(i,j,k)*pkz(i,j,k) + (phis(i,k+1)-phis(i,k))/(pe1(i,k+1)-pe1(i,k))
enddo
- enddo
- endif
+ enddo
+ else
+ do k=km,1,-1
+ 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, cvm)
+ 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
- if ( .not. hydrostatic ) then
+ endif !end hydrostatic test
+ endif ! .not. remap_te
+
+ if ( .not. hydrostatic ) then
do k=1,km
do i=is,ie
delz(i,j,k) = -delz(i,j,k) / delp(i,j,k) ! ="specific volume"/grav
enddo
enddo
- endif
+ endif
! update ps
- do i=is,ie
- ps(i,j) = pe1(i,km+1)
- enddo
+ do i=is,ie
+ ps(i,j) = pe1(i,km+1)
+ enddo
!
! Hybrid sigma-P coordinate:
!
@@ -287,52 +345,69 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
!------------------
! Compute p**Kappa
!------------------
- do k=1,km+1
- do i=is,ie
- pk1(i,k) = pk(i,j,k)
+ do k=1,km+1
+ do i=is,ie
+ pk1(i,k) = pk(i,j,k)
+ enddo
enddo
- enddo
-
- do i=is,ie
- pn2(i, 1) = peln(i, 1,j)
- pn2(i,km+1) = peln(i,km+1,j)
- pk2(i, 1) = pk1(i, 1)
- pk2(i,km+1) = pk1(i,km+1)
- enddo
- do k=2,km
do i=is,ie
- pn2(i,k) = log(pe2(i,k))
- pk2(i,k) = exp(akap*pn2(i,k))
+ pn2(i, 1) = peln(i, 1,j)
+ pn2(i,km+1) = peln(i,km+1,j)
+ pk2(i, 1) = pk1(i, 1)
+ pk2(i,km+1) = pk1(i,km+1)
enddo
- enddo
- if ( kord_tm<0 ) then
+ do k=2,km
+ do i=is,ie
+ pn2(i,k) = log(pe2(i,k))
+ pk2(i,k) = exp(akap*pn2(i,k))
+ enddo
+ enddo
+
+ !1) Remap Tv, thetav, or TE
+ if ( remap_te ) then
+ if ( kord_tm==0 ) then
!----------------------------------
-! Map t using logp
+! map Total Energy using GMAO cubic
!----------------------------------
- call map_scalar(km, peln(is,1,j), pt, gz, &
- km, pn2, pt, &
- is, ie, j, isd, ied, jsd, jed, 1, abs(kord_tm), t_min)
- else
-! Map pt using pe
- call map1_ppm (km, pe1, pt, gz, &
- km, pe2, pt, &
- is, ie, j, isd, ied, jsd, jed, 1, abs(kord_tm))
- endif
+ call map1_cubic (km, pe1, te, &
+ km, pe2, te, &
+ is, ie, j, isd, ied, jsd, jed, akap, T_VAR=1, conserv=.true.)
+ else
+ call map_scalar(km, peln(is,1,j), te, gz, &
+ km, pn2, te, &
+ is, ie, j, isd, ied, jsd, jed, 1, abs(kord_tm), cp_air*t_min, do_am4_remap)
+ endif
+
+ else
+ if ( kord_tm<0 ) then
+ ! Map t using logp
+ call map_scalar(km, peln(is,1,j), pt, gz, &
+ km, pn2, pt, &
+ is, ie, j, isd, ied, jsd, jed, &
+ 1, abs(kord_tm), t_min, do_am4_remap)
+ else
+ ! Map pt using pe
+ call map1_ppm (km, pe1, pt, gz, &
+ km, pe2, pt, &
+ is, ie, j, isd, ied, jsd, jed, &
+ 1, abs(kord_tm), do_am4_remap)
+ endif
+ endif
+
+ !2) Map constituents
-!----------------
-! Map constituents
-!----------------
if( nq > 5 ) then
call mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr, j, &
- is, ie, isd, ied, jsd, jed, 0., fill)
+ is, ie, isd, ied, jsd, jed, 0., fill, do_am4_remap)
elseif ( nq > 0 ) then
-! Remap one tracer at a time
+ ! Remap one tracer at a time
do iq=1,nq
call map1_q2(km, pe1, q(isd,jsd,1,iq), &
km, pe2, q2, dp2, &
- is, ie, 0, kord_tr(iq), j, isd, ied, jsd, jed, 0.)
+ is, ie, 0, kord_tr(iq), j, &
+ isd, ied, jsd, jed, 0., do_am4_remap)
if (fill) call fillz(ie-is+1, km, 1, q2, dp2)
do k=1,km
do i=is,ie
@@ -342,228 +417,293 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
enddo
endif
- if ( .not. hydrostatic ) then
-! Remap vertical wind:
- call map1_ppm (km, pe1, w, ws(is,j), &
- km, pe2, w, &
- is, ie, j, isd, ied, jsd, jed, -2, kord_wz)
-! Remap delz for hybrid sigma-p coordinate
- call map1_ppm (km, pe1, delz, gz, & ! works
- km, pe2, delz, &
- is, ie, j, is, ie, js, je, 1, abs(kord_tm))
- do k=1,km
- do i=is,ie
- 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) Map W and density; recompute delz; limit w if needed
+ if ( .not. hydrostatic ) then
+ ! Remap vertical wind:
+ if (kord_wz < 0) then
+ call map1_ppm (km, pe1, w, ws(is,j), &
+ km, pe2, w, &
+ is, ie, j, isd, ied, jsd, jed, &
+ -3, abs(kord_wz), do_am4_remap)
+ else
+ call map1_ppm (km, pe1, w, ws(is,j), &
+ km, pe2, w, &
+ is, ie, j, isd, ied, jsd, jed, &
+ -2, abs(kord_wz), do_am4_remap)
+ endif
+ ! Remap delz for hybrid sigma-p coordinate
+ call map1_ppm (km, pe1, delz, gz, & ! works
+ km, pe2, delz, &
+ is, ie, j, is, ie, js, je, &
+ 1, abs(kord_tm), do_am4_remap)
+ do k=1,km
+ do i=is,ie
+ delz(i,j,k) = -delz(i,j,k)*dp2(i,k)
+ enddo
+ enddo
-!----------
-! Update pk
-!----------
- do k=1,km+1
- do i=is,ie
- pk(i,j,k) = pk2(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
-!----------------
- if ( do_omega ) then
-! Start do_omega
-! Copy omega field to pe3
- do i=is,ie
- pe3(i,1) = 0.
- enddo
- do k=2,km+1
+ ! 3.1) Update pressure variables
+ do k=1,km+1
do i=is,ie
- pe3(i,k) = omga(i,j,k-1)
+ pk(i,j,k) = pk2(i,k)
enddo
enddo
- endif
- do k=1,km+1
- do i=is,ie
- pe0(i,k) = peln(i,k,j)
- peln(i,k,j) = pn2(i,k)
- enddo
- enddo
+ if ( last_step ) then
+ ! 4.1) Start do_last_step
+ ! save omega field in pe3
+ do i=is,ie
+ pe3(i,1) = 0.
+ enddo
+ do k=2,km+1
+ do i=is,ie
+ pe3(i,k) = omga(i,j,k-1)
+ enddo
+ enddo
+ endif
-!------------
-! Compute pkz
-!------------
- if ( hydrostatic ) then
- do k=1,km
+ do k=1,km+1
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)))
+ pe0(i,k) = peln(i,k,j)
+ peln(i,k,j) = pn2(i,k)
enddo
enddo
- else
-! Note: pt at this stage is T_v or T_m
- 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, cvm)
- 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)))
+
+ ! 3.2) Compute pkz
+ if ( .not. remap_te ) then
+ 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)))
+ enddo
enddo
-#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
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
- if ( last_step .and. (.not.adiabatic) ) then
- do i=is,ie
- pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
- enddo
- endif
- endif
+ ! 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,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, &
+ ice_wat, snowwat, graupel, q, gz, cvm)
+ 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
+ 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
+ enddo
+ endif
+ if ( kord_tm > 0 ) then
+ do k=1,km
+ do i=is,ie
+ pt(i,j,k) = pt(i,j,k)*pkz(i,j,k) !Need Tv for energy calculations
+ enddo
+ enddo
+ endif
+ endif ! end not remap_te
+
+ ! 3.3) On last step Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
+ if ( last_step ) then
+ do k=1,km
+ do i=is,ie
+ dp2(i,k) = 0.5*(peln(i,k,j) + peln(i,k+1,j))
+ enddo
enddo
- endif
+ do i=is,ie
+ k_next = 1
+ do n=1,km
+ kp = k_next
+ do k=kp,km
+ if( dp2(i,n) <= pe0(i,k+1) .and. dp2(i,n) >= pe0(i,k) ) then
+ omga(i,j,n) = pe3(i,k) + (pe3(i,k+1) - pe3(i,k)) * &
+ (dp2(i,n)-pe0(i,k)) / (pe0(i,k+1)-pe0(i,k) )
+ k_next = k
+ exit
+ endif
+ enddo
+ enddo
+ enddo
+ endif ! end last_step
-! Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
- if ( do_omega ) then
- do k=1,km
+ endif !(j < je+1)
+
+ do i=is,ie+1
+ pe0(i,1) = pe(i,1,j)
+ enddo
+
+ !4) Remap winds
+
+ ! 4.1) map u (on STAGGERED grid)
+ do k=2,km+1
do i=is,ie
- dp2(i,k) = 0.5*(peln(i,k,j) + peln(i,k+1,j))
+ pe0(i,k) = 0.5*(pe(i,k,j-1)+pe1(i,k))
enddo
enddo
- do i=is,ie
- k_next = 1
- do n=1,km
- kp = k_next
- do k=kp,km
- if( dp2(i,n) <= pe0(i,k+1) .and. dp2(i,n) >= pe0(i,k) ) then
- omga(i,j,n) = pe3(i,k) + (pe3(i,k+1) - pe3(i,k)) * &
- (dp2(i,n)-pe0(i,k)) / (pe0(i,k+1)-pe0(i,k) )
- k_next = k
- exit
- endif
- enddo
- enddo
+
+ do k=1,km+1
+ bkh = 0.5*bk(k)
+ do i=is,ie
+ pe3(i,k) = ak(k) + bkh*(pe(i,km+1,j-1)+pe1(i,km+1))
+ enddo
enddo
- endif ! end do_omega
- endif !(j < je+1)
+ call map1_ppm( km, pe0(is:ie,:), u, gz, &
+ km, pe3(is:ie,:), u, &
+ is, ie, j, isd, ied, jsd, jed+1, &
+ -1, kord_mt, do_am4_remap)
+
+ if (j < je+1) then
+
+ ! 4.2) map v
do i=is,ie+1
- pe0(i,1) = pe(i,1,j)
- enddo
-!------
-! map u
-!------
- do k=2,km+1
- do i=is,ie
- pe0(i,k) = 0.5*(pe(i,k,j-1)+pe1(i,k))
- enddo
+ pe3(i,1) = ak(1)
enddo
- do k=1,km+1
+ do k=2,km+1
bkh = 0.5*bk(k)
- do i=is,ie
- pe3(i,k) = ak(k) + bkh*(pe(i,km+1,j-1)+pe1(i,km+1))
+ do i=is,ie+1
+ pe0(i,k) = 0.5*(pe(i-1,k, j)+pe(i,k, j))
+ pe3(i,k) = ak(k) + bkh*(pe(i-1,km+1,j)+pe(i,km+1,j))
enddo
enddo
- call map1_ppm( km, pe0(is:ie,:), u, gz, &
- km, pe3(is:ie,:), u, &
- is, ie, j, isd, ied, jsd, jed+1, -1, kord_mt)
+ call map1_ppm (km, pe0, v, gz, &
+ km, pe3, v, is, ie+1, &
+ j, isd, ied+1, jsd, jed, -1, kord_mt, do_am4_remap)
- if (j < je+1) then
-!------
-! map v
-!------
- do i=is,ie+1
- pe3(i,1) = ak(1)
- enddo
-
- do k=2,km+1
- bkh = 0.5*bk(k)
- do i=is,ie+1
- pe0(i,k) = 0.5*(pe(i-1,k, j)+pe(i,k, j))
- pe3(i,k) = ak(k) + bkh*(pe(i-1,km+1,j)+pe(i,km+1,j))
- enddo
- enddo
+ ! 4a) update Tv and pkz from total energy (if remapping total energy)
+ if ( remap_te ) then
+ do i=is,ie
+ phis(i,km+1) = hs(i,j)
+ enddo
+ ! calculate Tv from TE
+ if ( hydrostatic ) then
+ do k=km,1,-1
+ do i=is,ie
+ tpe = te(i,j,k) - phis(i,k+1) - 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) )
+ dlnp = rg*(peln(i,k+1,j) - peln(i,k,j))
+ pt(i,j,k)= tpe / (cp - pe2(i,k)*dlnp/delp(i,j,k))
+ pkz(i,j,k) = (pk2(i,k+1)-pk2(i,k))/(akap*(peln(i,k+1,j)-peln(i,k,j)))
+ phis(i,k) = phis(i,k+1) + dlnp*pt(i,j,k)
+ enddo
+ 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, cvm)
+ 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
- call map1_ppm (km, pe0, v, gz, &
- km, pe3, v, is, ie+1, &
- j, isd, ied+1, jsd, jed, -1, kord_mt)
+ enddo ! end k-loop
+ endif
+ endif
endif ! (j < je+1)
- do k=1,km
- do i=is,ie
- pe4(i,j,k) = pe2(i,k+1)
- enddo
- enddo
+ do k=1,km
+ do i=is,ie
+ pe4(i,j,k) = pe2(i,k+1)
+ enddo
+ enddo
-1000 continue
+ enddo !j-loop
!-----------------------------------------------------------------------
-! Inline GFDL MP
+! 5) Inline GFDL MP setup
!-----------------------------------------------------------------------
if ((.not. do_adiabatic_init) .and. do_inline_mp) then
@@ -600,19 +740,8 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
endif
-!$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,va,isd,ied,jsd,jed,kord_mt, &
-!$OMP te_2d,te,delp,hydrostatic,phys_hydrostatic,hs,rg,pt,peln,adiabatic, &
-!$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, &
-!$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, &
-!$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, &
-!$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, &
-!$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, &
-!$OMP fast_mp_consv,kord_tm,pe4, &
-!$OMP npx,npy,ccn_cm3,inline_mp,u_dt,v_dt, &
-!$OMP do_inline_mp,c2l_ord,bd,dp0,ps) &
-!$OMP private(q2,pe0,pe1,pe2,pe3,qv,cvm,gz,gsize,phis,dpln,dp2,t0)
-
-!$OMP do
+ !6) Energy fixer
+!$OMP parallel do default(none) shared(is,ie,js,je,km,pe4,pe)
do k=2,km
do j=js,je
do i=is,ie
@@ -621,144 +750,186 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
enddo
enddo
-dtmp = 0.
-if( last_step .and. (.not.do_adiabatic_init) ) then
+ dtmp = 0.
- if ( consv > consv_min ) then
+ if( last_step .and. (.not.do_adiabatic_init) ) then
-!$OMP do
- do j=js,je
- if ( hydrostatic ) then
- do i=is,ie
- gz(i) = hs(i,j)
- do k=1,km
- gz(i) = gz(i) + rg*pt(i,j,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)*hs(i,j) - pe(i,1,j)*gz(i)
- enddo
+ if ( consv > consv_min ) then
- do k=1,km
- do i=is,ie
- te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*pt(i,j,k) + &
+!$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 private(cvm,gz,phis)
+ do j=js,je
+ if ( remap_te ) then
+ do i=is,ie
+ te_2d(i,j) = te(i,j,1)*delp(i,j,1)
+ enddo
+ do k=2,km
+ do i=is,ie
+ te_2d(i,j) = te_2d(i,j) + te(i,j,k)*delp(i,j,k)
+ enddo
+ enddo
+ else
+ if ( hydrostatic ) then
+ do i=is,ie
+ gz(i) = hs(i,j)
+ do k=1,km
+ gz(i) = gz(i) + rg*pt(i,j,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)*hs(i,j) - pe(i,1,j)*gz(i)
+ enddo
+
+ do k=1,km
+ do i=is,ie
+ te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*pt(i,j,k) + &
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)))
- enddo
- enddo
- else
+ 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
+ enddo
+ else
+ do i=is,ie
+ te_2d(i,j) = 0.
+ phis(i,km+1) = hs(i,j)
+ enddo
+ do k=km,1,-1
+ do i=is,ie
+ phis(i,k) = phis(i,k+1) - grav*delz(i,j,k)
+ enddo
+ 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, cvm)
+ 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
+
do i=is,ie
- te_2d(i,j) = 0.
- phis(i,km+1) = hs(i,j)
+ te_2d(i,j) = te0_2d(i,j) - te_2d(i,j)
+ zsum1(i,j) = pkz(i,j,1)*delp(i,j,1)
enddo
- do k=km,1,-1
+ do k=2,km
do i=is,ie
- phis(i,k) = phis(i,k+1) - grav*delz(i,j,k)
+ zsum1(i,j) = zsum1(i,j) + pkz(i,j,k)*delp(i,j,k)
enddo
enddo
-
- 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, cvm)
- 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
+ if ( hydrostatic ) then
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))))
+ zsum0(i,j) = ptop*(pk(i,j,1)-pk(i,j,km+1)) + zsum1(i,j)
enddo
-#endif
- enddo ! k-loop
- endif ! end non-hydro
-
- do i=is,ie
- te_2d(i,j) = te0_2d(i,j) - te_2d(i,j)
- zsum1(i,j) = pkz(i,j,1)*delp(i,j,1)
- enddo
- do k=2,km
- do i=is,ie
- zsum1(i,j) = zsum1(i,j) + pkz(i,j,k)*delp(i,j,k)
- enddo
- enddo
- if ( hydrostatic ) then
- do i=is,ie
- zsum0(i,j) = ptop*(pk(i,j,1)-pk(i,j,km+1)) + zsum1(i,j)
- enddo
- endif
+ endif
- enddo ! j-loop
+ enddo ! j-loop
-!$OMP single
- dtmp = consv*g_sum(domain, te_2d, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)
- E_Flux = dtmp / (grav*pdt*4.*pi*radius**2) ! unit: W/m**2
- ! Note pdt is "phys" time step
- if ( hydrostatic ) then
- dtmp = dtmp / (cp* g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.))
- else
- dtmp = dtmp / (cv_air*g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.))
- endif
-!$OMP end single
+ dtmp = consv*g_sum(domain, te_2d, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)
+ E_Flux = dtmp / (grav*pdt*4.*pi*radius**2) ! unit: W/m**2
+ ! Note pdt is "phys" time step
+ if ( hydrostatic ) then !AM4 version multiplies in cp or cv_air to g_sum here
+ dtmp = dtmp / g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)
+ else
+ dtmp = dtmp / g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)
+ endif
- elseif ( consv < -consv_min ) then
+ elseif ( consv < -consv_min ) then
-!$OMP do
- do j=js,je
- do i=is,ie
- zsum1(i,j) = pkz(i,j,1)*delp(i,j,1)
- enddo
- do k=2,km
- do i=is,ie
- zsum1(i,j) = zsum1(i,j) + pkz(i,j,k)*delp(i,j,k)
- enddo
- enddo
- if ( hydrostatic ) then
- do i=is,ie
- zsum0(i,j) = ptop*(pk(i,j,1)-pk(i,j,km+1)) + zsum1(i,j)
- enddo
- endif
- enddo
+!$OMP parallel do default(none) shared(is,ie,js,je,km,pkz,delp,zsum1,zsum0,ptop,pk,hydrostatic)
+ do j=js,je
+ do i=is,ie
+ zsum1(i,j) = pkz(i,j,1)*delp(i,j,1)
+ enddo
+ do k=2,km
+ do i=is,ie
+ zsum1(i,j) = zsum1(i,j) + pkz(i,j,k)*delp(i,j,k)
+ enddo
+ enddo
+ if ( hydrostatic ) then
+ do i=is,ie
+ zsum0(i,j) = ptop*(pk(i,j,1)-pk(i,j,km+1)) + zsum1(i,j)
+ enddo
+ endif
+ enddo
- E_Flux = consv
-!$OMP single
- if ( hydrostatic ) then
+ E_Flux = consv
+ if ( hydrostatic ) then !AM4 multiplies in cp or cv_air to g_sum here
dtmp = E_flux*(grav*pdt*4.*pi*radius**2) / &
- (cp*g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.))
- else
+ g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)
+ else
dtmp = E_flux*(grav*pdt*4.*pi*radius**2) / &
- (cv_air*g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.))
- endif
-!$OMP end single
- endif ! end consv check
-endif ! end last_step check
+ g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)
+ endif
+ endif ! end consv check
+ endif ! end last_step check
! Note: pt at this stage is T_v
+!-----------------------------------------------------------------------
+! 7) Split GFDL MP
+!-----------------------------------------------------------------------
! if ( (.not.do_adiabatic_init) .and. do_sat_adj ) then
if (do_adiabatic_init .or. do_sat_adj) then
call timing_on('sat_adj2')
-!$OMP do
+ if (cld_amt <= 0) then
+ call mpp_error(FATAL, " fv_mapz_mod: cld_amt must be defined in field_table to use do_adiabatic_init or do_sat_adj")
+ endif
+
+ allocate(dz(is:ie,js:je))
+
+!$OMP parallel do default(none) shared(is,ie,js,je,km,kmp,isd,jsd,te,delp,hydrostatic,hs,pt,peln, &
+!$OMP delz,rainwat,liq_wat,ice_wat,snowwat,graupel,q_con,r_vir, &
+!$OMP sphum,pkz,last_step,ng,gridstruct,q,mdt,cld_amt,cappa,dtdt, &
+!$OMP out_dt,rrg,akap,fast_mp_consv) &
+!$OMP private(qnl,qni,dpln,dz)
do k=kmp,km
do j=js,je
do i=is,ie
dpln(i,j) = peln(i,k+1,j) - peln(i,k,j)
+ qnl(i,j,k) = 0.0
+ qni(i,j,k) = 0.0
+ if (.not. hydrostatic) then
+ dz(i,j) = delz(i,j,k)
+ endif
enddo
enddo
- call fv_sat_adj(abs(mdt), r_vir, is, ie, js, je, ng, hydrostatic, fast_mp_consv, &
+ call fast_sat_adj(abs(mdt), is, ie, js, je, ng, hydrostatic, fast_mp_consv, &
te(isd,jsd,k), q(isd,jsd,k,sphum), q(isd,jsd,k,liq_wat), &
q(isd,jsd,k,ice_wat), q(isd,jsd,k,rainwat), &
- q(isd,jsd,k,snowwat), q(isd,jsd,k,graupel), &
- hs ,dpln, delz(is:ie,js:je,k), pt(isd,jsd,k), delp(isd,jsd,k), q_con(isd:,jsd:,k), & ! TEMPORARY
- cappa(isd:,jsd:,k), gridstruct%area_64, dtdt(is,js,k), out_dt, last_step, cld_amt>0, q(isd,jsd,k,cld_amt))
+ q(isd,jsd,k,snowwat), q(isd,jsd,k,graupel), q(isd,jsd,k,cld_amt), &
+ qnl(isd,jsd,k), qni(isd,jsd,k), hs ,dpln, dz(is:ie,js:je), &
+ pt(isd,jsd,k), delp(isd,jsd,k), &
+#ifdef USE_COND
+ q_con(isd:,jsd:,k), &
+#else
+ q_con(isd:,jsd:,1), &
+#endif
+#ifdef MOIST_CAPPA
+ cappa(isd:,jsd:,k), &
+#else
+ cappa(isd:,jsd:,1), &
+#endif
+ sqrt(gridstruct%area_64(is:ie,js:je)), &
+ dtdt(is,js,k), out_dt, last_step)
if ( .not. hydrostatic ) then
do j=js,je
do i=is,ie
@@ -772,8 +943,10 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
endif
enddo ! OpenMP k-loop
+ deallocate(dz)
+
if ( fast_mp_consv ) then
-!$OMP do
+!$OMP parallel do default(none) shared(is,ie,js,je,km,kmp,te,te0_2d)
do j=js,je
do i=is,ie
do k=kmp,km
@@ -787,14 +960,30 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
endif ! do_sat_adj
!-----------------------------------------------------------------------
-! Inline GFDL MP
+! 8) Inline GFDL MP --- full call
!-----------------------------------------------------------------------
if ((.not. do_adiabatic_init) .and. do_inline_mp) then
-!$OMP do
+ allocate(dz(is:ie,km))
+ allocate(wa(is:ie,km))
+
+!$OMP parallel do default(none) shared(is,ie,js,je,isd,jsd,km,pe,ua,va, &
+!$OMP te,delp,hydrostatic,hs,pt,peln, &
+!$OMP delz,rainwat,liq_wat,ice_wat,snowwat, &
+!$OMP graupel,q_con,sphum,w,pk,pkz,last_step,consv, &
+!$OMP do_adiabatic_init,te0_2d, &
+!$OMP gridstruct,q, &
+!$OMP mdt,cld_amt,cappa,rrg,akap, &
+!$OMP ccn_cm3,cin_cm3,inline_mp, &
+!$OMP do_inline_mp,ps) &
+!$OMP private(u_dt,v_dt,q2,q3,gsize,dp2,t0,dz,wa)
do j = js, je
+ if (cld_amt <= 0) then
+ call mpp_error(FATAL, " fv_mapz_mod: cld_amt must be defined in field_table to use do_inline_mp")
+ endif
+
gsize(is:ie) = sqrt(gridstruct%area_64(is:ie,j))
if (ccn_cm3 .gt. 0) then
@@ -802,15 +991,21 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
else
q2(is:ie,:) = 0.0
endif
+ if (cin_cm3 .gt. 0) then
+ q3(is:ie,:) = q(is:ie,j,:,cin_cm3)
+ else
+ q3(is:ie,:) = 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)
! note: delz is negative, delp is positive, delz doesn't change in constant volume situation
! note: hs is geopotential height (m^2/s^2)
- ! note: the unit of q2 is #/cc
+ ! note: the unit of q2 or q3 is #/cm^3
! note: the unit of area is m^2
! note: the unit of prer, prei, pres, preg is mm/day
+ ! note: the unit of cond, dep, reevap, sub is mm/day
! save ua, va for wind tendency calculation
u_dt(is:ie,j,:) = ua(is:ie,j,:)
@@ -820,50 +1015,66 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
dp2(is:ie,:) = q(is:ie,j,:,sphum)
t0(is:ie,:) = pt(is:ie,j,:)
+ if (allocated(inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt(is:ie,j,:) = inline_mp%liq_wat_dt(is:ie,j,:) - q(is:ie,j,:,liq_wat)
+ if (allocated(inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt(is:ie,j,:) = inline_mp%ice_wat_dt(is:ie,j,:) - q(is:ie,j,:,ice_wat)
+ if (allocated(inline_mp%qv_dt)) inline_mp%qv_dt(is:ie,j,:) = inline_mp%qv_dt(is:ie,j,:) - q(is:ie,j,:,sphum)
+ if (allocated(inline_mp%ql_dt)) inline_mp%ql_dt(is:ie,j,:) = inline_mp%ql_dt(is:ie,j,:) - (q(is:ie,j,:,liq_wat) + q(is:ie,j,:,rainwat))
+ if (allocated(inline_mp%qi_dt)) inline_mp%qi_dt(is:ie,j,:) = inline_mp%qi_dt(is:ie,j,:) - (q(is:ie,j,:,ice_wat) + q(is:ie,j,:,snowwat) + q(is:ie,j,:,graupel))
+ if (allocated(inline_mp%qr_dt)) inline_mp%qr_dt(is:ie,j,:) = inline_mp%qr_dt(is:ie,j,:) - q(is:ie,j,:,rainwat)
+ if (allocated(inline_mp%qs_dt)) inline_mp%qs_dt(is:ie,j,:) = inline_mp%qs_dt(is:ie,j,:) - q(is:ie,j,:,snowwat)
+ if (allocated(inline_mp%qg_dt)) inline_mp%qg_dt(is:ie,j,:) = inline_mp%qg_dt(is:ie,j,:) - q(is:ie,j,:,graupel)
+ if (allocated(inline_mp%t_dt)) inline_mp%t_dt(is:ie,j,:) = inline_mp%t_dt(is:ie,j,:) - pt(is:ie,j,:)
+ if (allocated(inline_mp%u_dt)) inline_mp%u_dt(is:ie,j,:) = inline_mp%u_dt(is:ie,j,:) - ua(is:ie,j,:)
+ if (allocated(inline_mp%v_dt)) inline_mp%v_dt(is:ie,j,:) = inline_mp%v_dt(is:ie,j,:) - va(is:ie,j,:)
- if (allocated(inline_mp%ql_dt)) inline_mp%ql_dt(is:ie,j,:) = q(is:ie,j,:,liq_wat) + q(is:ie,j,:,rainwat)
- if (allocated(inline_mp%qi_dt)) inline_mp%qi_dt(is:ie,j,:) = &
- q(is:ie,j,:,ice_wat) + q(is:ie,j,:,snowwat) + q(is:ie,j,:,graupel)
-
- if (allocated(inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt(is:ie,j,:) = q(is:ie,j,:,liq_wat)
- if (allocated(inline_mp%qr_dt)) inline_mp%qr_dt(is:ie,j,:) = q(is:ie,j,:,rainwat)
- if (allocated(inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt(is:ie,j,:) = q(is:ie,j,:,ice_wat)
- if (allocated(inline_mp%qg_dt)) inline_mp%qg_dt(is:ie,j,:) = q(is:ie,j,:,graupel)
- if (allocated(inline_mp%qs_dt)) inline_mp%qs_dt(is:ie,j,:) = q(is:ie,j,:,snowwat)
+ if (.not. hydrostatic) then
+ wa(is:ie,:) = w(is:ie,j,:)
+ dz(is:ie,:) = delz(is:ie,j,:)
+ else
+ dz(is:ie,:) = (peln(is:je,1:km,j) - peln(is:ie,2:km+1,j)) * rdgas * pt(is:ie,j,:) / grav
+ endif
-#ifndef DYCORE_SOLO
call gfdl_mp_driver(q(is:ie,j,:,sphum), q(is:ie,j,:,liq_wat), &
q(is:ie,j,:,rainwat), q(is:ie,j,:,ice_wat), q(is:ie,j,:,snowwat), &
- q(is:ie,j,:,graupel), q(is:ie,j,:,cld_amt), q2(is:ie,:), &
- pt(is:ie,j,:), w(is:ie,j,:), ua(is:ie,j,:), va(is:ie,j,:), &
- delz(is:ie,j,:), delp(is:ie,j,:), gsize, abs(mdt), &
+ q(is:ie,j,:,graupel), q(is:ie,j,:,cld_amt), q2(is:ie,:), q3(is:ie,:), &
+ pt(is:ie,j,:), wa(is:ie,:), ua(is:ie,j,:), va(is:ie,j,:), &
+ dz(is:ie,:), delp(is:ie,j,:), gsize, abs(mdt), &
hs(is:ie,j), inline_mp%prer(is:ie,j), inline_mp%pres(is:ie,j), &
- inline_mp%prei(is:ie,j), inline_mp%preg(is:ie,j), &
- hydrostatic, phys_hydrostatic, &
- is, ie, 1, km, q_con(is:ie,j,:), cappa(is:ie,j,:), consv>consv_min, &
- te(is:ie,j,:), last_step)
+ inline_mp%prei(is:ie,j), inline_mp%preg(is:ie,j), hydrostatic, &
+ is, ie, 1, km, &
+#ifdef USE_COND
+ q_con(is:ie,j,:), &
+#else
+ q_con(isd:,jsd,1:), &
+#endif
+#ifdef MOIST_CAPPA
+ cappa(is:ie,j,:), &
+#else
+ cappa(isd:,jsd,1:), &
#endif
+ consv>consv_min, &
+ te(is:ie,j,:), inline_mp%cond(is:ie,j), inline_mp%dep(is:ie,j), &
+ inline_mp%reevap(is:ie,j), inline_mp%sub(is:ie,j), last_step, do_inline_mp)
+
+ if (.not. hydrostatic) then
+ w(is:ie,j,:) = wa(is:ie,:)
+ endif
! compute wind tendency at A grid fori D grid wind update
u_dt(is:ie,j,:) = (ua(is:ie,j,:) - u_dt(is:ie,j,:)) / abs(mdt)
v_dt(is:ie,j,:) = (va(is:ie,j,:) - v_dt(is:ie,j,:)) / abs(mdt)
- if (.not. do_adiabatic_init) then
- if (allocated(inline_mp%qv_dt)) inline_mp%qv_dt(is:ie,j,:) = (q(is:ie,j,:,sphum) - dp2(is:ie,:)) / abs(mdt)
- if (allocated(inline_mp%ql_dt)) inline_mp%ql_dt(is:ie,j,:) = &
- (q(is:ie,j,:,liq_wat) + q(is:ie,j,:,rainwat) - inline_mp%ql_dt(is:ie,j,:)) / abs(mdt)
- if (allocated(inline_mp%qi_dt)) inline_mp%qi_dt(is:ie,j,:) = &
- (q(is:ie,j,:,ice_wat) + q(is:ie,j,:,snowwat) + q(is:ie,j,:,graupel) - inline_mp%qi_dt(is:ie,j,:)) / abs(mdt)
-
- if (allocated(inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt(is:ie,j,:) = (q(is:ie,j,:,liq_wat) - inline_mp%liq_wat_dt(is:ie,j,:)) / abs(mdt)
- if (allocated(inline_mp%qr_dt)) inline_mp%qr_dt(is:ie,j,:) = (q(is:ie,j,:,rainwat) - inline_mp%qr_dt(is:ie,j,:)) / abs(mdt)
- if (allocated(inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt(is:ie,j,:) = (q(is:ie,j,:,ice_wat) - inline_mp%ice_wat_dt(is:ie,j,:)) / abs(mdt)
- if (allocated(inline_mp%qg_dt)) inline_mp%qg_dt(is:ie,j,:) = (q(is:ie,j,:,graupel) - inline_mp%qg_dt(is:ie,j,:)) / abs(mdt)
- if (allocated(inline_mp%qs_dt)) inline_mp%qs_dt(is:ie,j,:) = (q(is:ie,j,:,snowwat) - inline_mp%qs_dt(is:ie,j,:)) / abs(mdt)
- if (allocated(inline_mp%t_dt)) inline_mp%t_dt(is:ie,j,:) = (pt(is:ie,j,:) - t0(is:ie,:)) / abs(mdt)
- if (allocated(inline_mp%u_dt)) inline_mp%u_dt(is:ie,j,:) = u_dt(is:ie,j,:)
- if (allocated(inline_mp%v_dt)) inline_mp%v_dt(is:ie,j,:) = v_dt(is:ie,j,:)
- endif
+ if (allocated(inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt(is:ie,j,:) = inline_mp%liq_wat_dt(is:ie,j,:) + q(is:ie,j,:,liq_wat)
+ if (allocated(inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt(is:ie,j,:) = inline_mp%ice_wat_dt(is:ie,j,:) + q(is:ie,j,:,ice_wat)
+ if (allocated(inline_mp%qv_dt)) inline_mp%qv_dt(is:ie,j,:) = inline_mp%qv_dt(is:ie,j,:) + q(is:ie,j,:,sphum)
+ if (allocated(inline_mp%ql_dt)) inline_mp%ql_dt(is:ie,j,:) = inline_mp%ql_dt(is:ie,j,:) + (q(is:ie,j,:,liq_wat) + q(is:ie,j,:,rainwat))
+ if (allocated(inline_mp%qi_dt)) inline_mp%qi_dt(is:ie,j,:) = inline_mp%qi_dt(is:ie,j,:) + (q(is:ie,j,:,ice_wat) + q(is:ie,j,:,snowwat) + q(is:ie,j,:,graupel))
+ if (allocated(inline_mp%qr_dt)) inline_mp%qr_dt(is:ie,j,:) = inline_mp%qr_dt(is:ie,j,:) + q(is:ie,j,:,rainwat)
+ if (allocated(inline_mp%qs_dt)) inline_mp%qs_dt(is:ie,j,:) = inline_mp%qs_dt(is:ie,j,:) + q(is:ie,j,:,snowwat)
+ if (allocated(inline_mp%qg_dt)) inline_mp%qg_dt(is:ie,j,:) = inline_mp%qg_dt(is:ie,j,:) + q(is:ie,j,:,graupel)
+ if (allocated(inline_mp%t_dt)) inline_mp%t_dt(is:ie,j,:) = inline_mp%t_dt(is:ie,j,:) + pt(is:ie,j,:)
+ if (allocated(inline_mp%u_dt)) inline_mp%u_dt(is:ie,j,:) = inline_mp%u_dt(is:ie,j,:) + ua(is:ie,j,:)
+ if (allocated(inline_mp%v_dt)) inline_mp%v_dt(is:ie,j,:) = inline_mp%v_dt(is:ie,j,:) + va(is:ie,j,:)
! update pe, peln, pk, ps
do k=2,km+1
@@ -883,61 +1094,65 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
#endif
endif
+ if (consv .gt. consv_min) then
+ do i = is, ie
+ do k = 1, km
+ te0_2d(i, j) = te0_2d(i, j) + te(i, j, k)
+ enddo
+ enddo
+ endif
+
enddo
- endif
+ deallocate(dz)
+ deallocate(wa)
+ endif
if ( last_step ) then
- ! Output temperature if last_step
+ ! 9a) Convert T_v/T_m to T if last_step
!!! if ( is_master() ) write(*,*) 'dtmp=', dtmp, nwat
-!$OMP do
- do k=1,km
- do j=js,je
+!$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 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))
+ enddo
+ else
#ifdef USE_COND
- if ( nwat==2 ) then
- do i=is,ie
- gz(i) = max(0., q(i,j,k,liq_wat))
- qv(i) = max(0., q(i,j,k,sphum))
- pt(i,j,k) = (pt(i,j,k)+dtmp*pkz(i,j,k)) / ((1.+r_vir*qv(i))*(1.-gz(i)))
- enddo
- elseif ( nwat==6 ) then
- do i=is,ie
- gz(i) = q(i,j,k,liq_wat)+q(i,j,k,rainwat)+q(i,j,k,ice_wat)+q(i,j,k,snowwat)+q(i,j,k,graupel)
- pt(i,j,k) = (pt(i,j,k)+dtmp*pkz(i,j,k))/((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i)))
- enddo
- else
- call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, &
- ice_wat, snowwat, graupel, q, gz, cvm)
- do i=is,ie
- pt(i,j,k) = (pt(i,j,k)+dtmp*pkz(i,j,k)) / ((1.+r_vir*q(i,j,k,sphum))*(1.-gz(i)))
- enddo
- endif
+ call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, &
+ ice_wat, snowwat, graupel, q, gz, cvm)
+ 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
do i=is,ie
- pt(i,j,k) = (pt(i,j,k)+dtmp*pkz(i,j,k)) / (1.+r_vir*q(i,j,k,sphum))
+ 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
- enddo ! j-loop
- enddo ! k-loop
- else ! not last_step
- if ( kord_tm < 0 ) then
-!$OMP do
- do k=1,km
- do j=js,je
- do i=is,ie
- pt(i,j,k) = pt(i,j,k)/pkz(i,j,k)
- enddo
- enddo
- enddo
- endif
+ endif
+ enddo ! j-loop
+ enddo ! k-loop
+ 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)
+ do k=1,km
+ do j=js,je
+ do i=is,ie
+ pt(i,j,k) = pt(i,j,k)/pkz(i,j,k)
+ enddo
+ enddo
+ enddo
endif
-!$OMP end parallel
!-----------------------------------------------------------------------
-! Inline GFDL MP
+! 10) Finish Inline GFDL MP
!-----------------------------------------------------------------------
if ((.not. do_adiabatic_init) .and. do_inline_mp) then
@@ -959,11 +1174,13 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
! update dry total energy
if (consv .gt. consv_min) then
+!$OMP parallel do default(none) shared(is,ie,js,je,km,te0_2d,hydrostatic,delp,gridstruct,u,v,dp0,u0,v0,hs,delz,w) &
+!$OMP private(phis)
do j=js,je
if (hydrostatic) then
do k = 1, km
do i=is,ie
- te0_2d(i,j) = te0_2d(i,j) + te(i,j,k) + delp(i,j,k) * &
+ te0_2d(i,j) = te0_2d(i,j) + delp(i,j,k) * &
(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))) &
@@ -984,7 +1201,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
enddo
do k = 1, km
do i=is,ie
- te0_2d(i,j) = te0_2d(i,j) + te(i,j,k) + delp(i,j,k) * &
+ te0_2d(i,j) = te0_2d(i,j) + delp(i,j,k) * &
(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)))) &
@@ -1006,7 +1223,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
deallocate(dp0)
endif
- endif
+ endif
end subroutine Lagrangian_to_Eulerian
@@ -1095,6 +1312,7 @@ subroutine compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, &
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
@@ -1202,100 +1420,16 @@ subroutine pkez(km, ifirst, ilast, jfirst, jlast, j, &
end subroutine pkez
-
-
- subroutine remap_z(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
-
-! !INPUT PARAMETERS:
- integer, intent(in) :: i1 ! Starting longitude
- integer, intent(in) :: i2 ! Finishing longitude
- integer, intent(in) :: kord ! Method order
- integer, intent(in) :: km ! Original vertical dimension
- integer, intent(in) :: kn ! Target vertical dimension
- integer, intent(in) :: iv
-
- real, intent(in) :: pe1(i1:i2,km+1) ! height at layer edges
- ! (from model top to bottom surface)
- real, intent(in) :: pe2(i1:i2,kn+1) ! hieght at layer edges
- ! (from model top to bottom surface)
- real, intent(in) :: q1(i1:i2,km) ! Field input
-
-! !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, delp, 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) ! negative
- 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
-
-! 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
- delp = pe2(i,k+1)-pe1(i,m)
- esl = delp / dp1(i,m)
- qsum = qsum + delp*(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 / ( pe2(i,k+1) - pe2(i,k) )
-555 continue
-1000 continue
-
- end subroutine remap_z
-
subroutine map_scalar( km, pe1, q1, qs, &
kn, pe2, q2, i1, i2, &
- j, ibeg, iend, jbeg, jend, iv, kord, q_min)
+ j, ibeg, iend, jbeg, jend, &
+ iv, kord, q_min, do_am4_remap)
! 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
@@ -1309,12 +1443,13 @@ subroutine map_scalar( km, pe1, q1, qs, &
! (from model top to bottom surface)
! in the new vertical coordinate
real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
+ logical, intent(in) :: do_am4_remap
! !INPUT/OUTPUT PARAMETERS:
real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output
real, intent(in):: q_min
! !DESCRIPTION:
-! IV = 0: constituents
+! 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)
@@ -1332,9 +1467,13 @@ subroutine map_scalar( km, pe1, q1, qs, &
enddo
enddo
-! Compute vertical subgrid distribution
+ ! Compute vertical subgrid distribution
if ( kord >7 ) then
- call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min )
+ if (do_am4_remap) then
+ call scalar_profile_am4( qs, q4, dp1, km, i1, i2, iv, kord, q_min )
+ else
+ call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min )
+ endif
else
call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
endif
@@ -1385,17 +1524,19 @@ end subroutine map_scalar
subroutine map1_ppm( km, pe1, q1, qs, &
kn, pe2, q2, i1, i2, &
- j, ibeg, iend, jbeg, jend, iv, kord)
+ j, ibeg, iend, jbeg, jend, &
+ iv, kord, do_am4_remap)
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) :: 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
@@ -1403,6 +1544,7 @@ subroutine map1_ppm( km, pe1, q1, qs, &
! (from model top to bottom surface)
! in the new vertical coordinate
real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
+ logical, intent(in) :: do_am4_remap
! !INPUT/OUTPUT PARAMETERS:
real, intent(inout):: q2(ibeg:iend,jbeg:jend,kn) ! Field output
@@ -1427,7 +1569,11 @@ subroutine map1_ppm( km, pe1, q1, qs, &
! Compute vertical subgrid distribution
if ( kord >7 ) then
- call cs_profile( qs, q4, dp1, km, i1, i2, iv, kord )
+ if (do_am4_remap) then
+ call cs_profile_am4( qs, q4, dp1, km, i1, i2, iv, kord )
+ else
+ call cs_profile( qs, q4, dp1, km, i1, i2, iv, kord )
+ endif
else
call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
endif
@@ -1476,8 +1622,11 @@ subroutine map1_ppm( km, pe1, q1, qs, &
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)
+ i1, i2, isd, ied, jsd, jed, &
+ q_min, fill, do_am4_remap)
! !INPUT PARAMETERS:
integer, intent(in):: km ! vertical dimension
integer, intent(in):: j, nq, i1, i2
@@ -1493,6 +1642,7 @@ subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, &
real, intent(in):: q_min
logical, intent(in):: fill
real, intent(inout):: q1(isd:ied,jsd:jed,km,nq) ! Field input
+ logical, intent(in) :: do_am4_remap
! !LOCAL VARIABLES:
real:: q4(4,i1:i2,km,nq)
real:: q2(i1:i2,km,nq) ! Field output
@@ -1514,7 +1664,11 @@ subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, &
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 )
+ if (do_am4_remap) then
+ call scalar_profile_am4( qs, q4(1,i1,1,iq), dp1, km, i1, i2, 0, kord(iq), q_min )
+ else
+ call scalar_profile( qs, q4(1,i1,1,iq), dp1, km, i1, i2, 0, kord(iq), q_min )
+ endif
enddo
! Mapping
@@ -1592,10 +1746,12 @@ subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, &
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 )
+ ibeg, iend, jbeg, jend, &
+ q_min, do_am4_remap )
! !INPUT PARAMETERS:
@@ -1616,6 +1772,7 @@ subroutine map1_q2(km, pe1, q1, &
real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
real, intent(in) :: dp2(i1:i2,kn)
real, intent(in) :: q_min
+ logical, intent(in) :: do_am4_remap
! !INPUT/OUTPUT PARAMETERS:
real, intent(inout):: q2(i1:i2,kn) ! Field output
! !LOCAL VARIABLES:
@@ -1635,7 +1792,11 @@ subroutine map1_q2(km, pe1, q1, &
! Compute vertical subgrid distribution
if ( kord >7 ) then
- call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min )
+ if (do_am4_remap) then
+ call scalar_profile_am4( qs, q4, dp1, km, i1, i2, iv, kord, q_min )
+ else
+ call scalar_profile( qs, q4, dp1, km, i1, i2, iv, kord, q_min )
+ endif
else
call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
endif
@@ -1685,10 +1846,12 @@ subroutine map1_q2(km, pe1, q1, &
end subroutine map1_q2
-
+ !Currently this routine is only called with kord = 4,
+ ! so do_am4_remap is unnecessary --- lmh 9 june 21
subroutine remap_2d(km, pe1, q1, &
kn, pe2, q2, &
- i1, i2, iv, kord)
+ i1, i2, &
+ iv, kord)
integer, intent(in):: i1, i2
integer, intent(in):: iv ! Mode: 0 == constituents 1 ==others
integer, intent(in):: kord
@@ -1716,72 +1879,997 @@ subroutine remap_2d(km, pe1, q1, &
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
+! 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.)
+ 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) > 16 ) 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 ( 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
+
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(2,i,1) = max(0., a4(2,i,1))
+ 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 ( iv==2 ) then
+ 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
+ endif
+
+ 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
+ if ( abs(kord)<9 ) then
+ 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
+
+ elseif ( abs(kord)==9 ) then
+ 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
+ elseif ( abs(kord)==10 ) then
+ 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
+ elseif ( abs(kord)==12 ) then
+ do i=i1,i2
+ if( extm(i,k) ) then
+ a4(2,i,k) = a4(1,i,k)
+ a4(3,i,k) = a4(1,i,k)
+ a4(4,i,k) = 0.
+ 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
+ elseif ( abs(kord)==13 ) then
+ do i=i1,i2
+ if( ext6(i,k) ) then
+ if ( ext6(i,k-1) .and. ext6(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)
+ 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
+ elseif ( abs(kord)==14 ) then
+
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+
+ elseif ( abs(kord)==15 ) then ! Revised abs(kord)=9 scheme
+ do i=i1,i2
+ if ( ext5(i,k) .and. ext5(i,k-1) ) then
+ a4(2,i,k) = a4(1,i,k)
+ a4(3,i,k) = a4(1,i,k)
+ else if ( ext5(i,k) .and. ext5(i,k+1) ) then
+ a4(2,i,k) = a4(1,i,k)
+ a4(3,i,k) = a4(1,i,k)
+ else if ( ext5(i,k) .and. a4(1,i,k) 16 ) 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
+!----- Perfectly linear scheme --------------------------------
+
+!------------------
+! Apply constraints
+!------------------
+ im = i2 - i1 + 1
+
+! Apply *large-scale* constraints
+ 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) ! now dq
+ enddo
+ enddo
+
+! Interior:
+ do k=3,km-1
+ do i=i1,i2
+ if ( gam(i,k-1)*gam(i,k+1)>0. ) then
+! Apply large-scale constraint to ALL fields if not local max/min
+ 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
+
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(2,i,1) = max(0., a4(2,i,1))
+ 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 ( iv==2 ) then
+ 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
+ endif
+
+ 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
+ if ( abs(kord)<9 ) then
+ 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
+
+ elseif ( abs(kord)==9 ) then
+ 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
+ elseif ( abs(kord)==10 ) then
+ 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
+ elseif ( abs(kord)==12 ) then
+ do i=i1,i2
+ if( extm(i,k) ) 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 ! 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
+ elseif ( abs(kord)==13 ) then
+ do i=i1,i2
+ if( ext6(i,k) ) then
+ if ( ext6(i,k-1) .and. ext6(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)
+ 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
+ elseif ( abs(kord)==14 ) then
+
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+
+ elseif ( abs(kord)==15 ) then ! revised kord=9 scehem
+ do i=i1,i2
+ if ( ext5(i,k) ) then ! c90_mp122
+ if ( ext5(i,k-1) .or. ext5(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)
+ endif
+ elseif( ext6(i,k) ) then
+! Check within the smooth region if subgrid profile is non-monotonic
+ 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
+ enddo
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+ elseif ( abs(kord)==16 ) then
+ 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
+ ! 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) )
+ 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
+ else ! kord = 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
+ endif
+
+! Additional constraint to ensure positivity
+ if ( iv==0 ) call cs_limiters(im, extm(i1,k), a4(1,i1,k), 0)
+
+ enddo ! k-loop
+
+!----------------------------------
+! Bottom layer subgrid constraints:
+!----------------------------------
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(3,i,km) = max(0., a4(3,i,km))
+ enddo
+ elseif ( iv .eq. -1 ) then
+ do i=i1,i2
+ if ( a4(3,i,km)*a4(1,i,km) <= 0. ) a4(3,i,km) = 0.
+ enddo
+ endif
+
+ 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
- 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
+ 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 scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
+ subroutine scalar_profile_am4(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
@@ -1795,12 +2883,12 @@ subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
real, intent(inout):: a4(4,i1:i2,km) ! Interpolated values
real, intent(in):: qmin
!-----------------------------------------------------------------------
- logical, dimension(i1:i2,km):: extm, ext5, ext6
+ logical, dimension(i1:i2,km):: extm, 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
+ real pmp_1, lac_1, pmp_2, lac_2
integer i, k, im
if ( iv .eq. -2 ) then
@@ -1929,13 +3017,10 @@ subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
extm(i,k) = gam(i,k)*gam(i,k+1) < 0.
enddo
endif
- if ( abs(kord) > 9 ) then
+ if ( abs(kord)==16 ) 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
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ ext6(i,k) = abs(a4(4,i,k)) > abs(a4(2,i,k)-a4(3,i,k))
enddo
endif
enddo
@@ -2030,36 +3115,32 @@ subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
enddo
elseif ( abs(kord)==10 ) then
do i=i1,i2
- if( ext5(i,k) ) then
- if( ext5(i,k-1) .or. ext5(i,k+1) ) then
+ 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)
- 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) )
+ 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
- elseif( ext6(i,k) ) then
- if( ext5(i,k-1) .or. ext5(i,k+1) ) then
+ 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) )
+ 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
+ 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
- do i=i1,i2
- a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
- enddo
elseif ( abs(kord)==12 ) then
do i=i1,i2
if( extm(i,k) ) then
@@ -2084,55 +3165,38 @@ subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
enddo
elseif ( abs(kord)==13 ) then
do i=i1,i2
- if( ext6(i,k) ) then
- if ( ext6(i,k-1) .and. ext6(i,k+1) ) then
+ if( extm(i,k) ) then
+ if ( extm(i,k-1) .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
+ ! 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)))
endif
+ else
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
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
elseif ( abs(kord)==14 ) then
do i=i1,i2
a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
enddo
-
- elseif ( abs(kord)==15 ) then ! Revised abs(kord)=9 scheme
- do i=i1,i2
- if ( ext5(i,k) .and. ext5(i,k-1) ) then
- a4(2,i,k) = a4(1,i,k)
- a4(3,i,k) = a4(1,i,k)
- else if ( ext5(i,k) .and. ext5(i,k+1) ) then
- a4(2,i,k) = a4(1,i,k)
- a4(3,i,k) = a4(1,i,k)
- else if ( ext5(i,k) .and. 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
+ 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
enddo
@@ -2434,36 +3487,32 @@ subroutine cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
enddo
elseif ( abs(kord)==10 ) then
do i=i1,i2
- if( ext5(i,k) ) then
- if( ext5(i,k-1) .or. ext5(i,k+1) ) then
+ 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)
- 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) )
+ 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
- elseif( ext6(i,k) ) then
- if( ext5(i,k-1) .or. ext5(i,k+1) ) then
+ 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) )
+ 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
+ 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
- do i=i1,i2
- a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
- enddo
elseif ( abs(kord)==12 ) then
do i=i1,i2
if( extm(i,k) ) then
@@ -2489,53 +3538,13 @@ subroutine cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
enddo
elseif ( abs(kord)==13 ) then
do i=i1,i2
- if( ext6(i,k) ) then
- if ( ext6(i,k-1) .and. ext6(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)
- 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
- elseif ( abs(kord)==14 ) then
-
- do i=i1,i2
- a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
- enddo
-
- elseif ( abs(kord)==15 ) then ! revised kord=9 scehem
- do i=i1,i2
- if ( ext5(i,k) ) then ! c90_mp122
- if ( ext5(i,k-1) .or. ext5(i,k+1) ) then ! c90_mp122
+ if( extm(i,k) ) then
+ if ( extm(i,k-1) .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)
- endif
- elseif( ext6(i,k) ) then
-! Check within the smooth region if subgrid profile is non-monotonic
- 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
- enddo
- do i=i1,i2
- a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
- enddo
- elseif ( abs(kord)==16 ) then
- 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
+ a4(4,i,k) = 0.
+ else
! Left edges
pmp_1 = a4(1,i,k) - 2.*gam(i,k+1)
lac_1 = pmp_1 + 1.5*gam(i,k+2)
@@ -2546,15 +3555,19 @@ subroutine cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
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
+ else
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
endif
enddo
+ elseif ( abs(kord)==14 ) then
do i=i1,i2
a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
enddo
else ! kord = 11
do i=i1,i2
- if ( ext5(i,k) .and. (ext5(i,k-1) .or. ext5(i,k+1)) ) then
+ if ( extm(i,k) .and. (extm(i,k-1) .or. extm(i,k+1)) ) then
! Noisy region:
a4(2,i,k) = a4(1,i,k)
a4(3,i,k) = a4(1,i,k)
@@ -2591,85 +3604,7 @@ subroutine cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
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
+ end subroutine cs_profile_am4
@@ -3072,7 +4007,7 @@ subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4)
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, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, &
delp, u, v, w, delz, pt, q, qdiag, &
@@ -3350,12 +4285,14 @@ subroutine rst_remap(km, kn, is,ie,js,je, isd,ied,jsd,jed, nq, ntp, &
end subroutine rst_remap
-
- subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
+ !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)
@@ -3366,9 +4303,9 @@ subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
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)
- real, intent(out):: q2(i1:i2,kn)
- real, intent(IN) :: ptop
+ 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)
@@ -3385,22 +4322,11 @@ subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
enddo
if ( kord >7 ) then
- call cs_profile( qs, a4, dp1, km, i1, i2, iv, kord )
+ call cs_profile( qs, a4, dp1, km, i1, i2, iv, kord )
else
call ppm_profile( a4, dp1, km, i1, i2, iv, kord )
endif
-!------------------------------------
-! Lowest layer: constant distribution
-!------------------------------------
-#ifdef NGGPS_SUBMITTED
- do i=i1,i2
- a4(2,i,km) = q1(i,km)
- a4(3,i,km) = q1(i,km)
- a4(4,i,km) = 0.
- enddo
-#endif
-
do 5555 i=i1,i2
k0 = 1
do 555 k=1,kn
@@ -3410,11 +4336,7 @@ subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
q2(i,k) = q1(i,1)
elseif(pe2(i,k) .ge. pe1(i,km+1)) then
! Entire grid below old ps
-#ifdef NGGPS_SUBMITTED
- q2(i,k) = a4(3,i,km) ! this is not good.
-#else
q2(i,k) = q1(i,km)
-#endif
else
do 45 L=k0,km
@@ -3465,11 +4387,7 @@ subroutine mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
delp = pe2(i,k+1) - pe1(i,km+1)
if(delp > 0.) then
! Extended below old ps
-#ifdef NGGPS_SUBMITTED
- qsum = qsum + delp * a4(3,i,km) ! not good.
-#else
qsum = qsum + delp * q1(i,km)
-#endif
dpsum = dpsum + delp
endif
123 q2(i,k) = qsum / dpsum
@@ -3635,5 +4553,209 @@ subroutine moist_cp(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rai
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 495c39394..309a1cd48 100644
--- a/model/fv_nesting.F90
+++ b/model/fv_nesting.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_nesting_mod
use mpp_domains_mod, only: mpp_update_domains
@@ -36,14 +37,16 @@ module fv_nesting_mod
use fv_arrays_mod, only: allocate_fv_nest_BC_type, fv_atmos_type, fv_grid_bounds_type, deallocate_fv_nest_BC_type
use fv_grid_utils_mod, only: ptop_min, g_sum, cubed_to_latlon, f_p
use init_hydro_mod, only: p_var
- use constants_mod, only: grav, pi=>pi_8, radius, hlv, rdgas, cp_air, rvgas, cp_vapor, kappa
- use fv_mapz_mod, only: mappm, remap_2d
+ use constants_mod, only: grav, pi=>pi_8, hlv, rdgas, cp_air, rvgas, cp_vapor, kappa
+ use fv_arrays_mod, only: radius ! scaled for small earth
+ use fv_mapz_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
use fv_diagnostics_mod, only: sphum_ll_fix, range_check
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
implicit none
logical :: RF_initialized = .false.
@@ -1184,7 +1187,7 @@ subroutine remap_BC_k(pe_lagBC, pe_eulBC, var_lagBC, var_eulBC, isd_BC, ied_BC,
call mappm(npz_coarse, peln_lag, var_lagBC(istart:iend,j:j,:), &
npz, peln_eul, var_eulBC(istart:iend,j:j,:), &
- istart, iend, iv, kord, pe_eulBC(istart,j,1))
+ istart, iend, iv, kord)
enddo
@@ -1195,7 +1198,7 @@ subroutine remap_BC_k(pe_lagBC, pe_eulBC, var_lagBC, var_eulBC, isd_BC, ied_BC,
call mappm(npz_coarse, pe_lagBC(istart:iend,j:j,:), var_lagBC(istart:iend,j:j,:), &
npz, pe_eulBC(istart:iend,j:j,:), var_eulBC(istart:iend,j:j,:), &
- istart, iend, iv, kord, pe_eulBC(istart,j,1))
+ istart, iend, iv, kord)
!!! NEED A FILLQ/FILLZ CALL HERE??
enddo
@@ -1329,10 +1332,6 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, &
integer, intent(IN) :: npx, npy, npz
real, intent(IN) :: zvir
- !real, parameter:: c_liq = 4185.5 ! heat capacity of water at 0C
- !real, parameter:: c_ice = 1972. ! heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice)
- real, parameter:: c_liq = 4218.0 ! heat capacity of water at 0C
- real, parameter:: c_ice = 2106. ! heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice)
real, parameter:: cv_vap = cp_vapor - rvgas ! 1384.5
real, dimension(:,:,:), pointer :: liq_watBC_west, ice_watBC_west, rainwatBC_west, snowwatBC_west, graupelBC_west
@@ -1579,10 +1578,6 @@ subroutine setup_pt_NH_BC_k(ptBC,sphumBC,delpBC,delzBC, &
integer :: i,j,k
real :: dp1, q_con, q_sol, q_liq, cvm, pkz, rdg, cv_air
- !real, parameter:: c_liq = 4185.5 ! heat capacity of water at 0C
- real, parameter:: c_liq = 4218.0 ! heat capacity of water at 0C
- !real, parameter:: c_ice = 1972. ! heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice)
- real, parameter:: c_ice = 2106. ! heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice)
real, parameter:: cv_vap = cp_vapor - rvgas ! 1384.5
real, parameter:: tice = 273.16 ! For GFS Partitioning
real, parameter:: t_i0 = 15.
@@ -2692,7 +2687,7 @@ subroutine remap_up_k(ps_src, ps_dst, ak_src, bk_src, ak_dst, bk_dst, var_src, v
!remap_2d seems to have some bugs when doing logp remapping
call mappm(npz_src, peln_src, var_src(istart:iend,j:j,:), &
npz_dst, peln_dst, var_dst_unblend, &
- istart, iend, iv, kord, peln_dst(istart,1))
+ istart, iend, iv, kord)
do k=1,npz_dst
bw1 = blend_wt(k)
@@ -2711,7 +2706,7 @@ subroutine remap_up_k(ps_src, ps_dst, ak_src, bk_src, ak_dst, bk_dst, var_src, v
call mappm(npz_src, pe_src, var_src(istart:iend,j:j,:), &
npz_dst, pe_dst, var_dst_unblend, &
- istart, iend, iv, kord, pe_dst(istart,1))
+ istart, iend, iv, kord)
do k=1,npz_dst
bw1 = blend_wt(k)
@@ -2879,7 +2874,7 @@ subroutine update_remap_tqw( npz, ak_dst, bk_dst, ps_dst, t_dst, q_dst, w_dst,
qp(i,k) = q_dst(i,j,k,iq)
enddo
enddo
- call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_tr, ptop) !not sure about indices
+ call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_tr) !not sure about indices
do k=1,npz
do i=istart,iend
q_dst(i,j,k,iq) = qn1(i,k)
@@ -2894,7 +2889,7 @@ subroutine update_remap_tqw( npz, ak_dst, bk_dst, ps_dst, t_dst, q_dst, w_dst,
enddo
enddo
!Remap T using logp
- call mappm(kmd, pn0(istart:iend,:), tp(istart:iend,:), npz, pn1(istart:iend,:), qn1(istart:iend,:), istart,iend, 1, abs(kord_tm), ptop)
+ call mappm(kmd, pn0(istart:iend,:), tp(istart:iend,:), npz, pn1(istart:iend,:), qn1(istart:iend,:), istart,iend, 1, abs(kord_tm))
do k=1,npz
wt1 = blend_wt(k)
@@ -2912,7 +2907,7 @@ subroutine update_remap_tqw( npz, ak_dst, bk_dst, ps_dst, t_dst, q_dst, w_dst,
enddo
!Remap w using p
!Using iv == -1 instead of -2
- call mappm(kmd, pe0(istart:iend,:), tp(istart:iend,:), npz, pe1(istart:iend,:), qn1(istart:iend,:), istart,iend, -1, kord_wz, ptop)
+ call mappm(kmd, pe0(istart:iend,:), tp(istart:iend,:), npz, pe1(istart:iend,:), qn1(istart:iend,:), istart,iend, -1, kord_wz)
do k=1,npz
wt1 = blend_wt(k)
@@ -3002,7 +2997,7 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, &
enddo
enddo
qn1 = 0.
- call mappm(kmd, pe0(istart:iend,:), qt(istart:iend,:), npz, pe1(istart:iend,:), qn1(istart:iend,:), istart,iend, -1, kord_mt, ptop)
+ call mappm(kmd, pe0(istart:iend,:), qt(istart:iend,:), npz, pe1(istart:iend,:), qn1(istart:iend,:), istart,iend, -1, kord_mt)
do k=1,npz
wt1 = blend_wt(k)
wt2 = 1. - wt1
@@ -3023,7 +3018,7 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, &
!------
! map v
!------
-!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,ak_src,bk_src,ps_src,npz,u_src,v_src,ptop,istart,iend_v,jstart,jend,blend_wt) &
+!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,ak_src,bk_src,ps_src,npz,u_src,v_src,ptop,istart,iend_v,jstart,jend,blend_wt,kord_mt) &
!$OMP private(pe0,pe1,qt,qn1,wt1,wt2)
do j=jstart,jend
!------
@@ -3052,7 +3047,7 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, &
enddo
enddo
qn1 = 0.
- call mappm(kmd, pe0(istart:iend_v+1,:), qt(istart:iend_v+1,:), npz, pe1(istart:iend_v+1,:), qn1(istart:iend_v+1,:), istart,iend_v+1, -1, 8, ptop)
+ call mappm(kmd, pe0(istart:iend_v+1,:), qt(istart:iend_v+1,:), npz, pe1(istart:iend_v+1,:), qn1(istart:iend_v+1,:), istart,iend_v+1, -1, kord_mt)
do k=1,npz
wt1 = blend_wt(k)
wt2 = 1. - wt1
diff --git a/model/fv_regional_bc.F90 b/model/fv_regional_bc.F90
index 92fa94ce7..cca3a0d30 100644
--- a/model/fv_regional_bc.F90
+++ b/model/fv_regional_bc.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -66,8 +66,7 @@ module fv_regional_mod
use fv_eta_mod, only: get_eta_level
use fms_mod, only: check_nml_error
use boundary_mod, only: fv_nest_BC_type_3D
- use fv_cmp_mod, only: c_liq, c_ice
- use sim_nc_mod, only: open_ncfile, close_ncfile, get_ncdim1
+ use gfdl_mp_mod, only: c_liq, c_ice
implicit none
@@ -1971,6 +1970,7 @@ subroutine regional_bc_data(Atm,bc_hour &
endif
endif
!
+#ifndef SW_DYNAMICS
if(call_remap)then
call remap_scalar_nggps_regional_bc(Atm &
,side &
@@ -2148,6 +2148,7 @@ subroutine regional_bc_data(Atm,bc_hour &
endif
endif
+#endif
!
!-----------------------------------------------------------------------
enddo sides_scalars
@@ -2491,9 +2492,11 @@ subroutine fill_BC_for_DA
do j=js_input,je_input
do i=is_input,ie_input
BC_t1%north%delp_BC(i,j,k)=delp_input(i,j,k)
+#ifndef SW_DYNAMICS
BC_t1%north%pt_BC(i,j,k)=t_input(i,j,k)
BC_t1%north%w_BC(i,j,k)=w_input(i,j,k)
BC_t1%north%delz_BC(i,j,k)=delz_input(i,j,k)
+#endif
enddo
enddo
enddo
@@ -2552,9 +2555,11 @@ subroutine fill_BC_for_DA
do j=js_input,je_input
do i=is_input,ie_input
BC_t1%south%delp_BC(i,j,k)=delp_input(i,j,k)
+#ifndef SW_DYNAMICS
BC_t1%south%pt_BC(i,j,k)=t_input(i,j,k)
BC_t1%south%w_BC(i,j,k)=w_input(i,j,k)
BC_t1%south%delz_BC(i,j,k)=delz_input(i,j,k)
+#endif
enddo
enddo
enddo
@@ -2613,9 +2618,11 @@ subroutine fill_BC_for_DA
do j=js_input,je_input
do i=is_input,ie_input
BC_t1%east%delp_BC(i,j,k)=delp_input(i,j,k)
+#ifndef SW_DYNAMICS
BC_t1%east%pt_BC(i,j,k)=t_input(i,j,k)
BC_t1%east%w_BC(i,j,k)=w_input(i,j,k)
BC_t1%east%delz_BC(i,j,k)=delz_input(i,j,k)
+#endif
enddo
enddo
enddo
@@ -2674,9 +2681,11 @@ subroutine fill_BC_for_DA
do j=js_input,je_input
do i=is_input,ie_input
BC_t1%west%delp_BC(i,j,k)=delp_input(i,j,k)
+#ifndef SW_DYNAMICS
BC_t1%west%pt_BC(i,j,k)=t_input(i,j,k)
BC_t1%west%w_BC(i,j,k)=w_input(i,j,k)
BC_t1%west%delz_BC(i,j,k)=delz_input(i,j,k)
+#endif
enddo
enddo
enddo
@@ -3446,6 +3455,7 @@ end subroutine allocate_regional_BC_arrays
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!---------------------------------------------------------------------
+#ifndef SW_DYNAMICS
subroutine remap_scalar_nggps_regional_bc(Atm &
,side &
,isd,ied,jsd,jed &
@@ -3655,7 +3665,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
enddo
enddo
- call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop)
+ call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8)
if ( iq==sphum ) then
call fillq(ie-is+1, npz, 1, qn1, dp2)
@@ -3739,6 +3749,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
! Compute true temperature using hydrostatic balance if not read from input.
+#ifndef SW_DYNAMICS
if ( .not. data_source_fv3gfs ) then
do k=1,npz
BC_side%pt_BC(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*BC_side%q_BC(i,j,k,sphum)) )
@@ -3752,6 +3763,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
enddo
endif
+#endif
enddo i_loop
!-----------------------------------------------------------------------
@@ -3764,6 +3776,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
! If the source is from old GFS or operational GSM then the tracers will be fixed in the boundaries
! and may not provide a very good result
!
+#ifndef SW_DYNAMICS
if ( .not. data_source_fv3gfs ) then
if ( Atm%flagstruct%nwat .eq. 6 ) then
do k=1,npz
@@ -3809,6 +3822,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
enddo
endif
endif ! data source /= FV3GFS GAUSSIAN NEMSIO/NETCDF and GRIB2 FILE
+#endif
!
! For GFS spectral input, omega in pa/sec is stored as w in the input data so actual w(m/s) is calculated
! For GFS nemsio input, omega is 0, so best not to use for input since boundary data will not exist for w
@@ -3823,7 +3837,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
enddo
enddo
- call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop)
+ call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4)
if ( data_source_fv3gfs ) then
do k=1,npz
@@ -3840,7 +3854,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
enddo
enddo
- call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 2, 4, Atm%ptop)
+ call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 2, 4)
do k=1,npz
do i=is,ie
@@ -3882,6 +3896,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm &
end subroutine remap_scalar_nggps_regional_bc
+#endif
!---------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!---------------------------------------------------------------------
@@ -3939,9 +3954,9 @@ subroutine remap_dwinds_regional_bc(Atm &
enddo
enddo
call mappm(km, pe0(is_u:ie_u,1:km+1), ud(is_u:ie_u,j,1:km), npz, pe1(is_u:ie_u,1:npz+1), &
- qn1_d(is_u:ie_u,1:npz), is_u,ie_u, -1, 8, Atm%ptop )
+ qn1_d(is_u:ie_u,1:npz), is_u,ie_u, -1, 8 )
call mappm(km, pe0(is_u:ie_u,1:km+1), vc(is_u:ie_u,j,1:km), npz, pe1(is_u:ie_u,1:npz+1), &
- qn1_c(is_u:ie_u,1:npz), is_u,ie_u, -1, 8, Atm%ptop )
+ qn1_c(is_u:ie_u,1:npz), is_u,ie_u, -1, 8 )
do k=1,npz
do i=is_u,ie_u
BC_side%u_BC(i,j,k) = qn1_d(i,k)
@@ -3980,9 +3995,9 @@ subroutine remap_dwinds_regional_bc(Atm &
enddo
enddo
call mappm(km, pe0(is_v:ie_v,1:km+1), vd(is_v:ie_v,j,1:km), npz, pe1(is_v:ie_v,1:npz+1), &
- qn1_d(is_v:ie_v,1:npz), is_v,ie_v, -1, 8, Atm%ptop)
+ qn1_d(is_v:ie_v,1:npz), is_v,ie_v, -1, 8)
call mappm(km, pe0(is_v:ie_v,1:km+1), uc(is_v:ie_v,j,1:km), npz, pe1(is_v:ie_v,1:npz+1), &
- qn1_c(is_v:ie_v,1:npz), is_v,ie_v, -1, 8, Atm%ptop)
+ qn1_c(is_v:ie_v,1:npz), is_v,ie_v, -1, 8)
do k=1,npz
do i=is_v,ie_v
BC_side%v_BC(i,j,k) = qn1_d(i,k)
@@ -4231,6 +4246,7 @@ subroutine bc_values_into_arrays(side_t0,side_t1 &
delp(i,j,k)=side_t0%delp_BC(i,j,k) &
+(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) &
+(side_t1%pt_BC(i,j,k)-side_t0%pt_BC(i,j,k)) &
*fraction_interval
@@ -4253,6 +4269,7 @@ subroutine bc_values_into_arrays(side_t0,side_t1 &
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
enddo
enddo
!
@@ -4279,9 +4296,9 @@ subroutine bc_values_into_arrays(side_t0,side_t1 &
enddo
enddo
!
- ie=min(ubound(side_t0%w_BC,1),ubound(w,1))
- je=min(ubound(side_t0%w_BC,2),ubound(w,2))
- nz=ubound(w,3)
+ ie=min(ubound(side_t0%delp_BC,1),ubound(delp,1))
+ je=min(ubound(side_t0%delp_BC,2),ubound(delp,2))
+ nz=ubound(delp,3)
!
do nt=1,ntracers
do k=1,nz
@@ -4644,6 +4661,7 @@ subroutine retrieve_bc_variable_data(bc_vbl_name &
case ('delp')
bc_t0=>bc_side_t0%delp_BC
bc_t1=>bc_side_t1%delp_BC
+#ifndef SW_DYNAMICS
case ('delz')
bc_t0=>bc_side_t0%delz_BC
bc_t1=>bc_side_t1%delz_BC
@@ -4653,6 +4671,7 @@ subroutine retrieve_bc_variable_data(bc_vbl_name &
case ('w')
bc_t0=>bc_side_t0%w_BC
bc_t1=>bc_side_t1%w_BC
+#endif
case ('divgd')
bc_t0=>bc_side_t0%divgd_BC
bc_t1=>bc_side_t1%divgd_BC
@@ -5153,6 +5172,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
j1=regional_bounds%js_north
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
@@ -5163,6 +5183,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
#endif
pt =>BC_t1%north%pt_BC
call compute_vpt !<-- Compute the virtual potential temperature.
+#endif
endif
!
if(south_bc)then
@@ -5171,6 +5192,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
j1=regional_bounds%js_south
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
@@ -5181,6 +5203,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
#endif
pt =>BC_t1%south%pt_BC
call compute_vpt !<-- Compute the virtual potential temperature.
+#endif
endif
!
if(east_bc)then
@@ -5189,6 +5212,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
j1=regional_bounds%js_east
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
@@ -5199,6 +5223,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
#endif
pt =>BC_t1%east%pt_BC
call compute_vpt !<-- Compute the virtual potential temperature.
+#endif
endif
!
if(west_bc)then
@@ -5207,6 +5232,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
j1=regional_bounds%js_west
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
@@ -5217,6 +5243,7 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz)
#endif
pt =>BC_t1%west%pt_BC
call compute_vpt !<-- Compute the virtual potential temperature.
+#endif
endif
!
!-----------------------------------------------------------------------
@@ -6733,7 +6760,7 @@ end subroutine exch_uv
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!---------------------------------------------------------------------
- subroutine get_data_source(data_source_fv3gfs,regional)
+ subroutine get_data_source(data_source_fv3gfs,regional,directory)
!
! This routine extracts the data source information if it is present in the datafile.
!
@@ -6742,8 +6769,13 @@ subroutine get_data_source(data_source_fv3gfs,regional)
character (len=80) :: source
logical :: lstatus
+ character(len=*), intent(in), optional :: directory
+ character(len=128) :: dir
type(FmsNetcdfFile_t) :: Gfs_data
integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist
+
+ dir = 'INPUT/'
+ if(present(directory)) dir = directory
!
! Use the fms call here so we can actually get the return code value.
! The term 'source' is specified by 'chgres_cube'
@@ -6752,8 +6784,8 @@ subroutine get_data_source(data_source_fv3gfs,regional)
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
- if (open_file(Gfs_data , 'INPUT/gfs_data.nc', "read", pelist=pes) .or. &
- open_file(Gfs_data , 'INPUT/gfs_data.tile1.nc', "read", pelist=pes)) then
+ if (open_file(Gfs_data , trim(dir)//'/gfs_data.nc', "read", pelist=pes) .or. &
+ open_file(Gfs_data , trim(dir)//'/gfs_data.tile1.nc', "read", pelist=pes)) then
lstatus = global_att_exists(Gfs_data, "source")
if(lstatus) call get_global_attribute(Gfs_data, "source", source)
call close_file(Gfs_data)
@@ -6761,7 +6793,8 @@ subroutine get_data_source(data_source_fv3gfs,regional)
deallocate(pes)
if (.not. lstatus) then
- if (mpp_pe() == 0) write(0,*) 'INPUT source not found ',lstatus,' set source=No Source Attribute'
+ if (mpp_pe() == 0) write(0,*) 'INPUT source not found in ', trim(dir), &
+ ' status=', lstatus,' set source=No Source Attribute'
source='No Source Attribute'
endif
if (mpp_pe()==0) write(*,*) 'INPUT gfs_data source string=',source
diff --git a/model/fv_sg.F90 b/model/fv_sg.F90
index b6bf503f8..31f3eba3e 100644
--- a/model/fv_sg.F90
+++ b/model/fv_sg.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_sg_mod
!-----------------------------------------------------------------------
@@ -26,7 +27,7 @@ module fv_sg_mod
use constants_mod, only: rdgas, rvgas, cp_air, cp_vapor, hlv, hlf, kappa, grav
use tracer_manager_mod, only: get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
- use gfdl_cloud_microphys_mod, only: wqs1, wqs2, wqsat2_moist
+ use gfdl_mp_mod, only: wqs1, wqs2, wqsat2_moist, c_liq, c_ice
use fv_mp_mod, only: mp_reduce_min, is_master
use mpp_mod, only: mpp_pe
@@ -37,10 +38,6 @@ module fv_sg_mod
real, parameter:: esl = 0.621971831
real, parameter:: tice = 273.16
- real, parameter:: c_ice = 2106. ! Emanuel table, page 566
-! real, parameter:: c_ice = 1972. ! -15 C
-! real, parameter:: c_liq = 4.1855e+3 ! GFS
- real, parameter:: c_liq = 4218. ! ECMWF-IFS
real, parameter:: cv_vap = cp_vapor - rvgas ! 1384.5
real, parameter:: c_con = c_ice
@@ -978,7 +975,7 @@ subroutine qsmith_init
allocate ( table(length) )
allocate ( des (length) )
- call qs_table(length, table)
+ call qs_table_m(length, table)
do i=1,length-1
des(i) = table(i+1) - table(i)
diff --git a/model/fv_tracer2d.F90 b/model/fv_tracer2d.F90
index fd298279e..54b156f31 100644
--- a/model/fv_tracer2d.F90
+++ b/model/fv_tracer2d.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_tracer2d_mod
use tp_core_mod, only: fv_tp_2d, copy_corners
use fv_mp_mod, only: mp_reduce_max
diff --git a/model/fv_update_phys.F90 b/model/fv_update_phys.F90
index d3672defb..83d2955fd 100644
--- a/model/fv_update_phys.F90
+++ b/model/fv_update_phys.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,9 +18,10 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_update_phys_mod
- use constants_mod, only: kappa, rdgas, rvgas, grav, cp_air, cp_vapor, pi=>pi_8, radius, TFREEZE
+ use constants_mod, only: kappa, rdgas, rvgas, grav, cp_air, cp_vapor, pi=>pi_8, TFREEZE
use field_manager_mod, only: MODEL_ATMOS
use mpp_domains_mod, only: mpp_update_domains, domain2d
use mpp_parameter_mod, only: AGRID_PARAM=>AGRID
@@ -546,7 +547,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq,
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), &
- ptop, ak, bk, &
+ ak, bk, &
ps(is:ie,js:je), ua(is:ie,js:je,:), va(is:ie,js:je,:), &
pt(is:ie,js:je,:), q(is:ie,js:je,:,sphum:sphum), &
ps_dt(is:ie,js:je), u_dt(is:ie,js:je,:), &
@@ -594,7 +595,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq,
enddo
enddo
call fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt_nudge, &
- zvir, ptop, ak, bk, ts, ps, delp, ua, va, pt, &
+ 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
@@ -624,7 +625,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq,
enddo
enddo
call fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt_nudge, &
- zvir, ptop, ak, bk, ts, ps, delp, ua, va, pt, &
+ 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
diff --git a/driver/SHiELD/gfdl_cloud_microphys.F90 b/model/gfdl_cld_mp.F90
similarity index 56%
rename from driver/SHiELD/gfdl_cloud_microphys.F90
rename to model/gfdl_cld_mp.F90
index 3dd6c40cd..5316f4bc3 100644
--- a/driver/SHiELD/gfdl_cloud_microphys.F90
+++ b/model/gfdl_cld_mp.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -27,180 +27,186 @@
! developer: shian - jiann lin, linjiong zhou
! =======================================================================
-module gfdl_cloud_microphys_mod
+module gfdl_cld_mp_mod
- ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, &
- ! mpp_clock_begin, mpp_clock_end, clock_routine, &
- ! input_nml_file
- ! use time_manager_mod, only: time_type, get_time
- ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8
- ! use fms_mod, only: write_version_number, open_namelist_file, &
- ! check_nml_error, file_exist, close_file
+#ifdef GFS_PHYS
+ use machine, only: r_grid => kind_phys
+#endif
implicit none
private
- public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end
- public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist
- public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d
- public setup_con, wet_bulb
-
- real :: missing_value = - 1.e10
+ public gfdl_cld_mp_driver, gfdl_cld_mp_init, gfdl_cld_mp_end
+ public wqs1, wqs2, iqs1, iqs2, mpdrv, sedi_heat, warm_rain, revap_racc, &
+ linear_prof, icloud, subgrid_z_proc, terminal_fall, check_column, implicit_fall, &
+ lagrangian_fall_ppm, cs_profile, cs_limiters, fall_speed, setupm, setup_con, &
+ qsmith_init, qs_tablew, qs_table2, qs_table3, qs_table, neg_adj, acr3d, smlt, gmlt, &
+ wet_bulb, qsmith, qs_blend, es3_table1d, es2_table1d, esw_table1d, es2_table, &
+ esw_table, d_sat, qs1d_m, wqsat_moist, wqsat2_moist, qs1d_moist, revap_rac1, &
+ wqs2_vect, rhow, rhor, rhos, rhog, rhoh, rnzr, rnzs, rnzg, rnzh, rvgas, rdgas, &
+ grav, hlv, hlf, cp_air, cp_vap, cv_air, cv_vap, c_ice, c_liq, dc_vap, dc_ice, &
+ t_ice, t_wfr, e00, pi, zvir, rgrav
+
+#ifndef GFS_PHYS
+ integer, parameter :: r_grid = 8
+#endif
logical :: module_is_initialized = .false.
logical :: qsmith_tables_initialized = .false.
- character (len = 17) :: mod_name = 'gfdl_cloud_microphys'
-
real, parameter :: grav = 9.80665 ! gfs: acceleration due to gravity
real, parameter :: rdgas = 287.05 ! gfs: gas constant for dry air
real, parameter :: rvgas = 461.50 ! gfs: gas constant for water vapor
- real, parameter :: cp_air = 1004.6 ! gfs: heat capacity of dry air at constant pressure
+ real, parameter :: cp_air = 1.0046e3 ! gfs: heat capacity of dry air at constant pressure
real, parameter :: hlv = 2.5e6 ! gfs: latent heat of evaporation
real, parameter :: hlf = 3.3358e5 ! gfs: latent heat of fusion
real, parameter :: pi = 3.1415926535897931 ! gfs: ratio of circle circumference to diameter
- ! real, parameter :: rdgas = 287.04 ! gfdl: gas constant for dry air
-
! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure
real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0, heat capacity of water vapore at constnat pressure
- ! real, parameter :: cv_air = 717.56 ! satoh value
+ ! real, parameter :: cv_air = 717.56 ! satoh value, heat capacity of dry air at constant volume
real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume
- ! real, parameter :: cv_vap = 1410.0 ! emanuel value
+ ! real, parameter :: cv_vap = 1410.0 ! emanuel value, heat capacity of water vapor at constant volume
real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5, heat capacity of water vapor at constant volume
- ! the following two are from emanuel's book "atmospheric convection"
- real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice)
- ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c
+ ! http: // www.engineeringtoolbox.com / ice - thermal - properties - d_576.html
+ ! c_ice = 2050.0 at 0 deg c
+ ! c_ice = 2000.0 at - 10 deg c
+ ! c_ice = 1943.0 at - 20 deg c
+ ! c_ice = 1882.0 at - 30 deg c
+ ! c_ice = 1818.0 at - 40 deg c
- ! real, parameter :: c_ice = 1972.0 ! gfdl: heat capacity of ice at - 15 deg c
- ! real, parameter :: c_liq = 4185.5 ! gfdl: heat capacity of water at 15 deg c
- real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c
+ ! https: // www.engineeringtoolbox.com / specific - heat - capacity - water - d_660.html
+ ! c_liq = 4219.9 at 0.01 deg c
+ ! c_liq = 4195.5 at 10 deg c
+ ! c_liq = 4184.4 at 20 deg c
+ ! c_liq = 4180.1 at 30 deg c
+ ! c_liq = 4179.6 at 40 deg c
+
+ ! the following two are from emanuel's book "atmospheric convection"
+ ! real, parameter :: c_ice = 2.106e3 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice)
+ ! real, parameter :: c_liq = 4.190e3 ! heat capacity of water at 0 deg c
+ ! real, parameter :: c_ice = 1.972e3 ! gfdl: heat capacity of ice at - 15 deg c
+ ! real, parameter :: c_liq = 4.1855e3 ! gfdl: heat capacity of water at 15 deg c
+ ! real, parameter :: c_ice = 2.106e3 ! gfs: heat capacity of ice at 0 deg c
+ ! real, parameter :: c_liq = 4.1855e3 ! gfs: heat capacity of liquid at 15 deg c
+ real, parameter :: c_ice = 2.106e3 ! ifs: heat capacity of ice at 0 deg c
+ real, parameter :: c_liq = 4.218e3 ! ifs: heat capacity of water at 0 deg c
real, parameter :: eps = rdgas / rvgas ! 0.6219934995
real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077338443
+ real, parameter :: dc_vap = cp_vap - c_liq ! - 2.372e3, isobaric heating / cooling
+ real, parameter :: dc_ice = c_liq - c_ice ! 2.112e3, isobaric heating / colling
+
real, parameter :: t_ice = 273.16 ! freezing temperature
real, parameter :: table_ice = 273.16 ! freezing point for qs table
+ real :: t_wfr ! complete freezing temperature
- ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c
- real, parameter :: e00 = 611.21 ! ifs: saturation vapor pressure at 0 deg c
-
- real, parameter :: dc_vap = cp_vap - c_liq ! - 2339.5, isobaric heating / cooling
- real, parameter :: dc_ice = c_liq - c_ice ! 2213.5, isobaric heating / colling
+ real (kind = r_grid), parameter :: e00 = 611.21 ! ifs: saturation vapor pressure at 0 deg c
+ ! real (kind = r_grid), parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c
real, parameter :: hlv0 = hlv ! gfs: evaporation latent heat coefficient at 0 deg c
- ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2
+ ! real, parameter :: hlv0 = 2.501e6 ! emanuel value
real, parameter :: hlf0 = hlf ! gfs: fussion latent heat coefficient at 0 deg c
- ! real, parameter :: hlf0 = 3.337e5 ! emanuel
+ ! real, parameter :: hlf0 = 3.337e5 ! emanuel value
- real, parameter :: lv0 = hlv0 - dc_vap * t_ice! 3.13905782e6, evaporation latent heat coefficient at 0 deg k
- real, parameter :: li00 = hlf0 - dc_ice * t_ice! - 2.7105966e5, fussion latend heat coefficient at 0 deg k
+ real, parameter :: lv0 = hlv0 - dc_vap * t_ice ! 3.14893552e6, evaporation latent heat coefficient at 0 deg k
+ real, parameter :: li0 = hlf0 - dc_ice * t_ice ! - 2.2691392e5, fussion latend heat coefficient at 0 deg k
- real, parameter :: d2ice = dc_vap + dc_ice ! - 126, isobaric heating / cooling
- real, parameter :: li2 = lv0 + li00 ! 2.86799816e6, sublimation latent heat coefficient at 0 deg k
+ real (kind = r_grid), parameter :: d2ice = cp_vap - c_ice ! - 260.0, isobaric heating / cooling
+ real (kind = r_grid), parameter :: li2 = lv0 + li0 ! 2.9220216e6, sublimation latent heat coefficient at 0 deg k
- real, parameter :: qrmin = 1.e-8 ! min value for ???
+ real, parameter :: qrmin = 1.e-8 ! min value for cloud condensates
real, parameter :: qvmin = 1.e-20 ! min value for water vapor (treated as zero)
real, parameter :: qcmin = 1.e-12 ! min value for cloud condensates
real, parameter :: vr_min = 1.e-3 ! min fall speed for rain
real, parameter :: vf_min = 1.e-5 ! min fall speed for cloud ice, snow, graupel
- real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height
+ real, parameter :: dz_min = 1.e-2 ! used for correcting flipped height
real, parameter :: sfcrho = 1.2 ! surface air density
- ! intercept parameters
-
- real, parameter :: rnzr = 8.0e6 ! lin83
- real, parameter :: rnzs = 3.0e6 ! lin83
- real, parameter :: rnzg = 4.0e6 ! rh84
- real, parameter :: rnzh = 4.0e4 ! lin83 --- lmh 29 sep 17
-
- ! density parameters
+ real, parameter :: rnzr = 8.0e6 ! lin et al. 1983
+ real, parameter :: rnzs = 3.0e6 ! lin et al. 1983
+ real, parameter :: rnzg = 4.0e6 ! rutledge and hobbs 1984
+ ! lmh, 20170929
+ real, parameter :: rnzh = 4.0e4 ! lin et al. 1983
- real, parameter :: rhor = 1.e3 ! density of rain water, lin83
- real, parameter :: rhos = 0.1e3 ! lin83 (snow density; 1 / 10 of water)
- real, parameter :: rhog = 0.4e3 ! rh84 (graupel density)
- real, parameter :: rhoh = 0.917e3 ! lin83 --- lmh 29 sep 17
+ real, parameter :: rhow = 1.0e3 ! density of cloud water
+ real, parameter :: rhor = 1.0e3 ! lin et al. 1983
+ real, parameter :: rhos = 0.1e3 ! lin et al. 1983
+ real, parameter :: rhog = 0.4e3 ! rutledge and hobbs 1984
+ ! lmh, 20170929
+ real, parameter :: rhoh = 0.917e3 ! lin et al. 1983
- public rhor, rhos, rhog, rhoh, rnzr, rnzs, rnzg, rnzh
+ real, parameter :: rgrav = 1. / grav
real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw ! constants for accretions
real :: acco (3, 4) ! constants for accretions
+ ! constants for sublimation / deposition, freezing / melting, condensation / evaporation
real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5)
real :: es0, ces0
- real :: pie, rgrav, fac_rc
+ real :: pie, fac_rc
real :: c_air, c_vap
- real :: lati, latv, lats, lat2, lcp, icp, tcp ! used in bigg mechanism and wet bulk
+ real :: lat2, lcp, icp, tcp ! used in bigg mechanism and wet bulk
real :: d0_vap ! the same as dc_vap, except that cp_vap can be cp_vap or cv_vap
- real :: lv00 ! the same as lv0, except that cp_vap can be cp_vap or cv_vap
-
- ! cloud microphysics switchers
-
- integer :: icloud_f = 0 ! cloud scheme
- integer :: irain_f = 0 ! cloud water to rain auto conversion scheme
-
- logical :: de_ice = .false. ! to prevent excessive build - up of cloud ice from external sources
- logical :: sedi_transport = .true. ! transport of momentum in sedimentation
- logical :: do_sedi_w = .false. ! transport of vertical motion in sedimentation
- logical :: do_sedi_heat = .false. ! transport of heat in sedimentation ! default changed to false 19oct17 lmh
- logical :: prog_ccn = .false. ! do prognostic ccn (yi ming's method)
- logical :: do_qa = .true. ! do inline cloud fraction
- logical :: rad_snow = .true. ! consider snow in cloud fraciton calculation
- logical :: rad_graupel = .true. ! consider graupel in cloud fraction calculation
- logical :: rad_rain = .true. ! consider rain in cloud fraction calculation
- logical :: fix_negative = .false. ! fix negative water species
- logical :: do_setup = .true. ! setup constants and parameters
- logical :: p_nonhydro = .false. ! perform hydrosatic adjustment on air density
+ real (kind = r_grid) :: lv00, li00, li20
+ real (kind = r_grid) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice
+ real (kind = r_grid), parameter :: one_r8 = 1.
real, allocatable :: table (:), table2 (:), table3 (:), tablew (:)
real, allocatable :: des (:), des2 (:), des3 (:), desw (:)
logical :: tables_are_initialized = .false.
- ! logical :: master
- ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, &
- ! id_ice, id_prec, id_cond, id_var, id_droplets
- ! integer :: gfdl_mp_clock ! clock for timing of driver routine
-
real, parameter :: dt_fr = 8. ! homogeneous freezing of all cloud water at t_wfr - dt_fr
! minimum temperature water can exist (moore & molinero nov. 2011, nature)
! dt_fr can be considered as the error bar
- real :: p_min = 100. ! minimum pressure (pascal) for mp to operate
-
- ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km
-
- ! qi0_crt = 0.8e-4
- ! qs0_crt = 0.6e-3
- ! c_psaci = 0.1
- ! c_pgacs = 0.1
+ real, parameter :: p0_min = 100. ! minimum pressure (pascal) for mp to operate
+ real :: p_min
! -----------------------------------------------------------------------
! namelist parameters
! -----------------------------------------------------------------------
+ integer :: ntimes = 1 ! cloud microphysics sub cycles
+
+ integer :: icloud_f = 0 ! cloud scheme
+ integer :: irain_f = 0 ! cloud water to rain auto conversion scheme
+
+ logical :: sedi_transport = .true. ! transport of momentum in sedimentation
+ logical :: do_sedi_w = .true. ! transport of vertical momentum during sedimentation
+ logical :: do_sedi_heat = .true. ! transport of heat in sedimentation
+ logical :: prog_ccn = .false. ! do prognostic ccn (yi ming's method)
+ logical :: do_qa = .true. ! do inline cloud fraction
+ logical :: rad_snow = .true. ! consider snow in cloud fraciton calculation
+ logical :: rad_graupel = .true. ! consider graupel in cloud fraction calculation
+ logical :: rad_rain = .true. ! consider rain in cloud fraction calculation
+ logical :: fix_negative = .false. ! fix negative water species
+ logical :: do_setup = .true. ! setup constants and parameters
+ logical :: disp_heat = .false. ! dissipative heating due to sedimentation
+ logical :: do_cond_timescale = .false. ! whether to apply a timescale to condensation
+
+ real :: cld_fac = 1.0 ! multiplication factor for cloud fraction
real :: cld_min = 0.05 ! minimum cloud fraction
real :: tice = 273.16 ! set tice = 165. to trun off ice - phase phys (kessler emulator)
+ real :: tice_mlt = 273.16 ! set ice melting temperature to 268.0 based on observation (kay et al., 2016, jc)
real :: t_min = 178. ! min temp to freeze - dry all water vapor
real :: t_sub = 184. ! min temp for sublimation of cloud ice
real :: mp_time = 150. ! maximum micro - physics time step (sec)
- ! relative humidity increment
-
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
- ! conversion time scale
-
real :: tau_r2g = 900. ! rain freezing during fast_sat
real :: tau_smlt = 900. ! snow melting
real :: tau_g2r = 600. ! graupel melting to rain
@@ -211,18 +217,15 @@ module gfdl_cloud_microphys_mod
real :: tau_l2v = 300. ! cloud water to water vapor (evaporation)
real :: tau_g2v = 900. ! grapuel sublimation
real :: tau_v2g = 21600. ! grapuel deposition -- make it a slow process
-
- ! horizontal subgrid variability
+ real :: tau_revp = 0. ! rain evaporation
real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land
real :: dw_ocean = 0.10 ! base value for ocean
- ! prescribed ccn
-
real :: ccn_o = 90. ! ccn over ocean (cm^ - 3)
real :: ccn_l = 270. ! ccn over land (cm^ - 3)
- real :: rthresh = 10.0e-6 ! critical cloud drop radius (micro m)
+ real :: rthresh = 10.0e-6 ! critical cloud drop radius (micron)
! -----------------------------------------------------------------------
! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33
@@ -241,7 +244,7 @@ module gfdl_cloud_microphys_mod
real :: ql_mlt = 2.0e-3 ! max value of cloud water allowed from melted cloud ice
real :: qs_mlt = 1.0e-6 ! max cloud water due to snow melt
- real :: ql_gen = 1.0e-3 ! max cloud water generation during remapping step if fast_sat_adj = .t.
+ real :: ql_gen = 1.0e-3 ! max cloud water generation during remapping step if do_sat_adj = .t.
real :: qi_gen = 1.82e-6 ! max cloud ice generation during remapping step
! cloud condensate upper bounds: "safety valves" for ql & qi
@@ -250,87 +253,113 @@ module gfdl_cloud_microphys_mod
real :: qi0_max = 1.0e-4 ! max cloud ice value (by other sources)
real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (was 1.e-4)
- ! qi0_crt is highly dependent on horizontal resolution
+ ! qi0_crt if negative, its magnitude is used as the mixing ration threshold; otherwise, used as density
real :: qr0_crt = 1.0e-4 ! rain to snow or graupel / hail threshold
- ! lfo used * mixing ratio * = 1.e-4 (hail in lfo)
+ ! lin et al. (1983) used * mixing ratio * = 1.e-4 (hail)
real :: qs0_crt = 1.0e-3 ! snow to graupel density threshold (0.6e-3 in purdue lin scheme)
real :: c_paut = 0.55 ! autoconversion cloud water to rain (use 0.5 to reduce autoconversion)
real :: c_psaci = 0.02 ! accretion: cloud ice to snow (was 0.1 in zetac)
- real :: c_piacr = 5.0 ! accretion: rain to ice:
+ real :: c_piacr = 5.0 ! accretion: rain to ice: (not used)
real :: c_cracw = 0.9 ! rain accretion efficiency
real :: c_pgacs = 2.0e-3 ! snow to graupel "accretion" eff. (was 0.1 in zetac)
! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow)
- real :: alin = 842.0 ! "a" in lin1983
- real :: clin = 4.8 ! "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs)
-
- ! fall velocity tuning constants:
+ real :: alin = 842.0 ! "a" in lin et al. (1983)
+ real :: clin = 4.8 ! "c" in lin et al. (1983), 4.8 -- > 6. (to ehance ql -- > qs)
logical :: const_vi = .false. ! if .t. the constants are specified by v * _fac
logical :: const_vs = .false. ! if .t. the constants are specified by v * _fac
logical :: const_vg = .false. ! if .t. the constants are specified by v * _fac
logical :: const_vr = .false. ! if .t. the constants are specified by v * _fac
- ! good values:
-
- real :: vi_fac = 1. ! if const_vi: 1 / 3
- real :: vs_fac = 1. ! if const_vs: 1.
- real :: vg_fac = 1. ! if const_vg: 2.
- real :: vr_fac = 1. ! if const_vr: 4.
-
- ! upper bounds of fall speed (with variable speed option)
+ real :: vi_fac = 1. ! ifs: if const_vi: 1 / 3
+ real :: vs_fac = 1. ! ifs: if const_vs: 1.
+ real :: vg_fac = 1. ! ifs: if const_vg: 2.
+ real :: vr_fac = 1. ! ifs: if const_vr: 4.
real :: vi_max = 0.5 ! max fall speed for ice
real :: vs_max = 5.0 ! max fall speed for snow
real :: vg_max = 8.0 ! max fall speed for graupel
real :: vr_max = 12. ! max fall speed for rain
- ! cloud microphysics switchers
+ real :: xr_a = 0.25 ! p value in xu and randall, 1996
+ real :: xr_b = 100. ! alpha_0 value in xu and randall, 1996
+ real :: xr_c = 0.49 ! gamma value in xu and randall, 1996
- logical :: fast_sat_adj = .false. ! has fast saturation adjustments
+ real :: te_err = 1.e-14 ! 64bit: 1.e-14, 32bit: 1.e-7
+
+ logical :: do_sat_adj = .false. ! has fast saturation adjustments
logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions
logical :: z_slope_ice = .false. ! use linear mono slope for autocconversions
logical :: use_ccn = .false. ! must be true when prog_ccn is false
logical :: use_ppm = .false. ! use ppm fall scheme
+ logical :: use_ppm_ice = .false. ! use ppm fall scheme for cloud ice
logical :: mono_prof = .true. ! perform terminal fall with mono ppm scheme
- logical :: mp_print = .false. ! cloud microphysics debugging printout
logical :: do_hail = .false. ! use hail parameters instead of graupel
-
- ! real :: global_area = - 1.
-
- real :: log_10, tice0, t_wfr
+ logical :: hd_icefall = .false. ! use heymsfield and donner, 1990's fall speed of cloud ice
+ logical :: use_xr_cloud = .false. ! use xu and randall, 1996's cloud diagnosis
+ logical :: use_park_cloud = .false. ! park et al. 2016
+ logical :: use_gi_cloud = .false. ! gultepe and isaac (2007, grl)
+ logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation
+ logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation
+ logical :: consv_checker = .false. ! turn on energy and water conservation checker
+ logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only
+ ! turn off to save time, turn on only in c48 64bit
+
+ real :: g2, log_10
+
+ real :: rh_thres = 0.75
+ real :: rhc_cevap = 0.85 ! cloud water
+ real :: rhc_revap = 0.85 ! cloud water
+
+ real :: f_dq_p = 1.0
+ real :: f_dq_m = 1.0
+ logical :: do_cld_adj = .false.
+
+ integer :: inflag = 1 ! ice nucleation scheme
+ ! 1: hong et al., 2004
+ ! 2: meyers et al., 1992
+ ! 3: meyers et al., 1992
+ ! 4: cooper, 1986
+ ! 5: flecther, 1962
! -----------------------------------------------------------------------
! namelist
! -----------------------------------------------------------------------
- namelist / gfdl_cloud_microphysics_nml / &
- mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, &
+ namelist / gfdl_mp_nml / &
+ t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, &
vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, &
vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, &
- qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
+ qi0_crt, do_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, &
tau_g2v, tau_v2g, sat_adj0, tau_imlt, tau_v2l, tau_l2v, &
tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, &
z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, &
- rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, &
- do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, &
- mp_print, do_hail
+ rad_snow, rad_graupel, rad_rain, cld_fac, cld_min, use_ppm, use_ppm_ice, mono_prof, &
+ do_sedi_heat, sedi_transport, do_sedi_w, icloud_f, irain_f, &
+ ntimes, disp_heat, do_hail, use_xr_cloud, xr_a, xr_b, xr_c, tau_revp, tice_mlt, hd_icefall, &
+ do_cond_timescale, mp_time, consv_checker, te_err, use_park_cloud, &
+ use_gi_cloud, use_rhc_cevap, use_rhc_revap, inflag, do_warm_rain_mp, &
+ rh_thres, f_dq_p, f_dq_m, do_cld_adj
public &
- mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, &
+ t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, &
vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, &
vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, &
- qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
+ qi0_crt, do_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, &
tau_g2v, tau_v2g, sat_adj0, tau_imlt, tau_v2l, tau_l2v, &
tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, &
z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, &
- rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, &
- do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, &
- mp_print, do_hail
+ rad_snow, rad_graupel, rad_rain, cld_fac, cld_min, use_ppm, use_ppm_ice, mono_prof, &
+ do_sedi_heat, sedi_transport, do_sedi_w, icloud_f, irain_f, &
+ ntimes, disp_heat, do_hail, use_xr_cloud, xr_a, xr_b, xr_c, tau_revp, tice_mlt, hd_icefall, &
+ do_cond_timescale, mp_time, consv_checker, te_err, use_park_cloud, &
+ use_gi_cloud, use_rhc_cevap, use_rhc_revap, inflag, do_warm_rain_mp, &
+ rh_thres, f_dq_p, f_dq_m, do_cld_adj
contains
@@ -338,161 +367,98 @@ module gfdl_cloud_microphys_mod
! the driver of the gfdl cloud microphysics
! -----------------------------------------------------------------------
-subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, &
- qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, &
- uin, vin, udt, vdt, dz, delp, area, dt_in, land, rain, snow, ice, &
- graupel, hydrostatic, phys_hydrostatic, iis, iie, kks, &
- kke, ktop, kbot, seconds)
+subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, &
+ pt, w, ua, va, dz, delp, gsize, dts, hs, rain, snow, ice, &
+ graupel, hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, &
+ te, condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
implicit none
- logical, intent (in) :: hydrostatic, phys_hydrostatic
- integer, intent (in) :: iis, iie ! physics window
- integer, intent (in) :: kks, kke ! vertical dimension
- integer, intent (in) :: ktop, kbot ! vertical compute domain
- integer, intent (in) :: seconds
+ logical, intent (in) :: hydrostatic
+ logical, intent (in) :: last_step
+ logical, intent (in) :: consv_te
+ logical, intent (in) :: do_inline_mp
- real, intent (in) :: dt_in ! physics time step
+ integer, intent (in) :: is, ie ! physics window
+ integer, intent (in) :: ks, ke ! vertical dimension
- real, intent (in), dimension (:) :: area ! cell area
- real, intent (in), dimension (:) :: land ! land fraction
+ real, intent (in) :: dts ! physics time step
- real, intent (in), dimension (:, :) :: delp, dz, uin, vin
- real, intent (in), dimension (:, :) :: pt, qv, ql, qr, qg, qa, qn
+ real, intent (in), dimension (is:ie) :: hs, gsize
- real, intent (inout), dimension (:, :) :: qi, qs
- real, intent (inout), dimension (:, :) :: pt_dt, qa_dt, udt, vdt, w
- real, intent (inout), dimension (:, :) :: qv_dt, ql_dt, qr_dt
- real, intent (inout), dimension (:, :) :: qi_dt, qs_dt, qg_dt
+ real, intent (in), dimension (is:ie, ks:ke) :: dz
+ real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
- real, intent (out), dimension (:) :: rain, snow, ice, graupel
+ real, intent (inout), dimension (is:ie, ks:ke) :: delp
+ real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+ real, intent (inout), dimension (is:ie, ks:ke) :: pt, ua, va, w
+ real, intent (inout), dimension (is:, ks:) :: q_con, cappa
+ real, intent (inout), dimension (is:ie) :: rain, snow, ice, graupel
+ real, intent (inout), dimension (is:ie) :: condensation, deposition
+ real, intent (inout), dimension (is:ie) :: evaporation, sublimation
+ real, intent (inout), dimension (is:ie, ks:ke) :: te
! logical :: used
+ real, dimension (is:ie) :: w_var
+ real, dimension (is:ie, ks:ke) :: vt_r, vt_s, vt_g, vt_i
+ real, dimension (is:ie, ks:ke) :: m2_rain, m2_sol
- real :: mpdt, rdt, dts, convt, tot_prec
-
- integer :: i, k
- integer :: is, ie ! physics window
- integer :: ks, ke ! vertical dimension
- integer :: days, ntimes
-
- real, dimension (iie - iis + 1) :: prec_mp, prec1, cond, w_var, rh0
-
- real, dimension (iie - iis + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2
-
- real, dimension (iie - iis + 1, kke - kks + 1) :: m2_rain, m2_sol
-
- real :: allmax
-
- is = 1
- ks = 1
- ie = iie - iis + 1
- ke = kke - kks + 1
-
- ! call mpp_clock_begin (gfdl_mp_clock)
+ if (last_step) then
+ p_min = p0_min ! final clean - up
+ else
+ p_min = 30.e2 ! time saving trick
+ endif
! -----------------------------------------------------------------------
! define heat capacity of dry air and water vapor based on hydrostatical property
! -----------------------------------------------------------------------
- if (phys_hydrostatic .or. hydrostatic) then
+ if (hydrostatic) then
c_air = cp_air
c_vap = cp_vap
- p_nonhydro = .false.
+ do_sedi_w = .false.
else
c_air = cv_air
c_vap = cv_vap
- p_nonhydro = .true.
endif
d0_vap = c_vap - c_liq
- lv00 = hlv0 - d0_vap * t_ice
-
- if (hydrostatic) do_sedi_w = .false.
-
- ! -----------------------------------------------------------------------
- ! define latent heat coefficient used in wet bulb and bigg mechanism
- ! -----------------------------------------------------------------------
- latv = hlv
- lati = hlf
- lats = latv + lati
- lat2 = lats * lats
+ ! scaled constants (to reduce fp errors for 32 - bit) :
+ d1_vap = d0_vap / c_air
+ d1_ice = dc_ice / c_air
- lcp = latv / cp_air
- icp = lati / cp_air
- tcp = (latv + lati) / cp_air
+ ! lv0 = hlv0 - (c_vap - c_liq) * t_ice! 3.13905782e6, evaporation latent heat coefficient at 0 deg k
+ lv00 = (hlv0 - d0_vap * t_ice) / c_air
+ li00 = (hlf0 - dc_ice * t_ice) / c_air
+ li20 = lv00 + li00
- ! tendency zero out for am moist processes should be done outside the driver
+ c1_vap = c_vap / c_air
+ c1_liq = c_liq / c_air
+ c1_ice = c_ice / c_air
! -----------------------------------------------------------------------
- ! define cloud microphysics sub time step
+ ! define latent heat coefficient used in wet bulb and bigg mechanism
! -----------------------------------------------------------------------
- mpdt = min (dt_in, mp_time)
- rdt = 1. / dt_in
- ntimes = nint (dt_in / mpdt)
-
- ! small time step:
- dts = dt_in / real (ntimes)
-
- ! call get_time (time, seconds, days)
+ lat2 = (hlv + hlf) ** 2
- ! -----------------------------------------------------------------------
- ! initialize precipitation
- ! -----------------------------------------------------------------------
+ lcp = hlv / cp_air
+ icp = hlf / cp_air
+ tcp = (hlv + hlf) / cp_air
- do i = is, ie
- graupel (i) = 0.
- rain (i) = 0.
- snow (i) = 0.
- ice (i) = 0.
- cond (i) = 0.
- enddo
+ ! tendency zero out for am moist processes should be done outside the driver
! -----------------------------------------------------------------------
! major cloud microphysics
! -----------------------------------------------------------------------
- call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg, &
- qa, qn, dz, is, ie, ks, ke, ktop, kbot, dt_in, ntimes, &
- rain, snow, graupel, ice, m2_rain, &
- m2_sol, cond, area, land, udt, vdt, pt_dt, &
- qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, &
- vt_s, vt_g, vt_i, qn2)
-
- ! -----------------------------------------------------------------------
- ! no clouds allowed above ktop
- ! -----------------------------------------------------------------------
-
- if (ks < ktop) then
- do k = ks, ktop
- if (do_qa) then
- do i = is, ie
- qa_dt (i, k) = 0.
- enddo
- else
- do i = is, ie
- ! qa_dt (i, k) = - qa (i, k) * rdt
- qa_dt (i, k) = 0. ! gfs
- enddo
- endif
- enddo
- endif
-
- ! convert to mm / day
-
- convt = 86400. * rdt * rgrav
- do i = is, ie
- rain (i) = rain (i) * convt
- snow (i) = snow (i) * convt
- ice (i) = ice (i) * convt
- graupel (i) = graupel (i) * convt
- prec_mp (i) = rain (i) + snow (i) + ice (i) + graupel (i)
- enddo
-
- ! call mpp_clock_end (gfdl_mp_clock)
+ call mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, qg, &
+ qa, qnl, qni, dz, is, ie, ks, ke, dts, &
+ rain, snow, graupel, ice, m2_rain, m2_sol, gsize, hs, &
+ w_var, vt_r, vt_s, vt_g, vt_i, q_con, cappa, consv_te, te, &
+ condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
-end subroutine gfdl_cloud_microphys_driver
+end subroutine gfdl_cld_mp_driver
! -----------------------------------------------------------------------
! gfdl cloud microphysics, major program
@@ -509,58 +475,75 @@ end subroutine gfdl_cloud_microphys_driver
! 6) qg: graupel (kg / kg)
! -----------------------------------------------------------------------
-subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
- qg, qa, qn, dz, is, ie, ks, ke, ktop, kbot, dt_in, ntimes, &
- rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, &
- u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, &
- w_var, vt_r, vt_s, vt_g, vt_i, qn2)
+subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
+ qg, qa, qnl, qni, dz, is, ie, ks, ke, dt_in, &
+ rain, snow, graupel, ice, m2_rain, m2_sol, gsize, hs, &
+ w_var, vt_r, vt_s, vt_g, vt_i, q_con, cappa, consv_te, te, &
+ condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
implicit none
logical, intent (in) :: hydrostatic
-
+ logical, intent (in) :: last_step
+ logical, intent (in) :: consv_te
+ logical, intent (in) :: do_inline_mp
integer, intent (in) :: is, ie, ks, ke
- integer, intent (in) :: ntimes, ktop, kbot
-
real, intent (in) :: dt_in
-
- real, intent (in), dimension (is:) :: area1, land
-
- real, intent (in), dimension (is:, ks:) :: uin, vin, delp, pt, dz
- real, intent (in), dimension (is:, ks:) :: qv, ql, qr, qg, qa, qn
-
- real, intent (inout), dimension (is:, ks:) :: qi, qs
- real, intent (inout), dimension (is:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt
- real, intent (inout), dimension (is:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt
-
- real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond
-
- real, intent (out), dimension (is:) :: w_var
-
- real, intent (out), dimension (is:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2
-
- real, intent (out), dimension (is:, ks:) :: m2_rain, m2_sol
-
- real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz
- real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz
- real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1
- real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0
- real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac
- real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1
- real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1
+ real, intent (in), dimension (is:ie) :: gsize
+ real, intent (in), dimension (is:ie) :: hs
+ real, intent (in), dimension (is:ie, ks:ke) :: dz
+ real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
+
+ real, intent (inout), dimension (is:ie, ks:ke) :: delp
+ real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+ real, intent (inout), dimension (is:ie, ks:ke) :: pt, ua, va, w
+ real, intent (inout), dimension (is:, ks:) :: q_con, cappa
+ real, intent (inout), dimension (is:ie) :: rain, snow, ice, graupel
+ real, intent (inout), dimension (is:ie) :: condensation, deposition
+ real, intent (inout), dimension (is:ie) :: evaporation, sublimation
+
+ real, intent (out), dimension (is:ie) :: w_var
+ real, intent (out), dimension (is:ie, ks:ke) :: vt_r, vt_s, vt_g, vt_i
+ real, intent (out), dimension (is:ie, ks:ke) :: m2_rain, m2_sol
+ real, intent (out), dimension (is:ie, ks:ke) :: te
+ ! local:
+ real, dimension (ks:ke) :: q_liq, q_sol
+ real, dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz
+ real, dimension (ks:ke) :: vtiz, vtsz, vtgz, vtrz
+ real, dimension (ks:ke) :: dp1, dz1
+ real, dimension (ks:ke) :: den, p1, denfac
+ real, dimension (ks:ke) :: ccn, cin, c_praut, m1_rain, m1_sol, m1
+ real, dimension (ks:ke) :: u0, v0, u1, v1, w1
+
+ real (kind = r_grid), dimension (is:ie, ks:ke) :: te_beg, te_end, tw_beg, tw_end
+ real (kind = r_grid), dimension (is:ie, ks:ke) :: te_beg_0, te_end_0, tw_beg_0, tw_end_0
+ real (kind = r_grid), dimension (is:ie) :: te_b_beg, te_b_end, tw_b_beg, tw_b_end, dte, te_loss
+ real (kind = r_grid), dimension (is:ie) :: te_b_beg_0, te_b_end_0, tw_b_beg_0, tw_b_end_0
+ real (kind = r_grid), dimension (ks:ke) :: te1, te2
real :: cpaut, rh_adj, rh_rain
real :: r1, s1, i1, g1, rdt, ccn0
- real :: dt_rain, dts
- real :: s_leng, t_land, t_ocean, h_var
- real :: cvm, tmp, omq
- real :: dqi, qio, qin
+ real :: dt_rain
+ real :: s_leng, t_land, t_ocean, h_var, tmp
+ real (kind = r_grid), dimension (ks:ke) :: dp0, tz, cvm
+ real (kind = r_grid) :: con_r8, c8
+ real :: convt
+ real :: dts, q_cond
+ real :: cond, dep, reevap, sub
integer :: i, k, n
+ ntimes = max (ntimes, int (dt_in / min (dt_in, mp_time)))
dts = dt_in / real (ntimes)
+
dt_rain = dts * 0.5
- rdt = 1. / dt_in
+ rdt = one_r8 / dts
+
+ dte = 0.0
+
+ ! convert to mm / day
+ convt = 86400. * rdt * rgrav
+ cond = 0.0
! -----------------------------------------------------------------------
! use local variables
@@ -568,93 +551,132 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
do i = is, ie
- do k = ktop, kbot
- qiz (k) = qi (i, k)
- qsz (k) = qs (i, k)
+ do k = ks, ke
+ if (do_inline_mp) then
+#ifdef MOIST_CAPPA
+ tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - (ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k))))
+#else
+ tz (k) = pt (i, k) / (1. + zvir * qv (i, k))
+#endif
+ else
+ tz (k) = pt (i, k)
+ endif
enddo
! -----------------------------------------------------------------------
- ! this is to prevent excessive build - up of cloud ice from external sources
+ ! total energy checker
! -----------------------------------------------------------------------
- if (de_ice) then
- do k = ktop, kbot
- qio = qiz (k) - dt_in * qi_dt (i, k) ! original qi before phys
- qin = max (qio, qi0_max) ! adjusted value
- if (qiz (k) > qin) then
- qsz (k) = qsz (k) + qiz (k) - qin
- qiz (k) = qin
- dqi = (qin - qio) * rdt ! modified qi tendency
- qs_dt (i, k) = qs_dt (i, k) + qi_dt (i, k) - dqi
- qi_dt (i, k) = dqi
- qi (i, k) = qiz (k)
- qs (i, k) = qsz (k)
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = ql (i, k) + qr (i, k)
+ q_sol (k) = qi (i, k) + qs (i, k) + qg (i, k)
+ cvm (k) = c_air * (1.0 - qv (i, k) - q_liq (k) - q_sol (k)) + &
+ qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_beg_0 (i, k) = cvm (k) * tz (k) + lv00 * c_air * qv (i, k) - li00 * c_air * q_sol (k)
+ if (hydrostatic) then
+ te_beg_0 (i, k) = te_beg_0 (i, k) + 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2)
+ else
+ te_beg_0 (i, k) = te_beg_0 (i, k) + 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 + w (i, k) ** 2)
endif
+ te_beg_0 (i, k) = rgrav * te_beg_0 (i, k) * delp (i, k) * gsize (i) ** 2.0
+ tw_beg_0 (i, k) = rgrav * (qv (i, k) + q_liq (k) + q_sol (k)) * delp (i, k) * gsize (i) ** 2.0
enddo
+ te_b_beg_0 (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_beg_0 (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
endif
- do k = ktop, kbot
-
- t0 (k) = pt (i, k)
- tz (k) = t0 (k)
- dp1 (k) = delp (i, k)
- dp0 (k) = dp1 (k) ! moist air mass * grav
-
+ do k = ks, ke
+ dp0 (k) = delp (i, k)
! -----------------------------------------------------------------------
! convert moist mixing ratios to dry mixing ratios
! -----------------------------------------------------------------------
-
qvz (k) = qv (i, k)
qlz (k) = ql (i, k)
qrz (k) = qr (i, k)
+ qiz (k) = qi (i, k)
+ qsz (k) = qs (i, k)
qgz (k) = qg (i, k)
-
- ! dp1: dry air_mass
- ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k)))
- dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs
- omq = dp0 (k) / dp1 (k)
-
- qvz (k) = qvz (k) * omq
- qlz (k) = qlz (k) * omq
- qrz (k) = qrz (k) * omq
- qiz (k) = qiz (k) * omq
- qsz (k) = qsz (k) * omq
- qgz (k) = qgz (k) * omq
-
- qa0 (k) = qa (i, k)
+ ! save moist ratios for te:
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ q_cond = q_liq (k) + q_sol (k)
qaz (k) = 0.
- dz0 (k) = dz (i, k)
-
- den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air
- p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure
-
- ! -----------------------------------------------------------------------
- ! save a copy of old value for computing tendencies
- ! -----------------------------------------------------------------------
-
- qv0 (k) = qvz (k)
- ql0 (k) = qlz (k)
- qr0 (k) = qrz (k)
- qi0 (k) = qiz (k)
- qs0 (k) = qsz (k)
- qg0 (k) = qgz (k)
+ dz1 (k) = dz (i, k)
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ ! dp1 is dry mass (no change during mp)
+ dp1 (k) = dp0 (k) * con_r8
+ con_r8 = one_r8 / con_r8
+ qvz (k) = qvz (k) * con_r8
+ qlz (k) = qlz (k) * con_r8
+ qrz (k) = qrz (k) * con_r8
+ qiz (k) = qiz (k) * con_r8
+ qsz (k) = qsz (k) * con_r8
+ qgz (k) = qgz (k) * con_r8
+
+ den (k) = - dp1 (k) / (grav * dz1 (k)) ! density of dry air
+ p1 (k) = den (k) * rdgas * tz (k) ! dry air pressure
! -----------------------------------------------------------------------
- ! for sedi_momentum
+ ! for sedi_momentum transport:
! -----------------------------------------------------------------------
m1 (k) = 0.
- u0 (k) = uin (i, k)
- v0 (k) = vin (i, k)
+ u0 (k) = ua (i, k)
+ v0 (k) = va (i, k)
+ if (.not. hydrostatic) then
+ w1 (k) = w (i, k)
+ endif
u1 (k) = u0 (k)
v1 (k) = v0 (k)
-
+ denfac (k) = sqrt (sfcrho / den (k))
enddo
- if (do_sedi_w) then
- do k = ktop, kbot
- w1 (k) = w (i, k)
+ ! -----------------------------------------------------------------------
+ ! fix energy conservation
+ ! -----------------------------------------------------------------------
+
+ if (consv_te) then
+ if (hydrostatic) then
+ do k = ks, ke
+ te (i, k) = - c_air * tz (k) * delp (i, k)
+ enddo
+ else
+ do k = ks, ke
+#ifdef MOIST_CAPPA
+ q_liq (k) = ql (i, k) + qr (i, k)
+ q_sol (k) = qi (i, k) + qs (i, k) + qg (i, k)
+ q_cond = q_liq (k) + q_sol (k)
+ cvm (k) = (one_r8 - (qv (i, k) + q_cond)) * c_air + &
+ qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te (i, k) = - cvm (k) * tz (k) * delp (i, k)
+#else
+ te (i, k) = - c_air * tz (k) * delp (i, k)
+#endif
+ enddo
+ endif
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ cvm (k) = c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_beg (i, k) = cvm (k) * tz (k) + lv00 * c_air * qvz (k) - li00 * c_air * q_sol (k)
+ if (hydrostatic) then
+ te_beg (i, k) = te_beg (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2)
+ else
+ te_beg (i, k) = te_beg (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2 + w1 (k) ** 2)
+ endif
+ te_beg (i, k) = rgrav * te_beg (i, k) * dp1 (k) * gsize (i) ** 2.0
+ tw_beg (i, k) = rgrav * (qvz (k) + q_liq (k) + q_sol (k)) * dp1 (k) * gsize (i) ** 2.0
enddo
+ te_b_beg (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_beg (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
endif
! -----------------------------------------------------------------------
@@ -665,24 +687,20 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
cpaut = c_paut * 0.104 * grav / 1.717e-5
if (prog_ccn) then
- do k = ktop, kbot
- ! convert # / cc to # / m^3
- ccn (k) = qn (i, k) * 1.e6
+ do k = ks, ke
+ ! convert # / cm^3 to # / m^3
+ ccn (k) = max (10.0, qnl (i, k)) * 1.e6
+ cin (k) = max (10.0, qni (i, k)) * 1.e6
+ ccn (k) = ccn (k) / den (k)
c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.)
enddo
- use_ccn = .false.
else
- ccn0 = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6
- if (use_ccn) then
- ! -----------------------------------------------------------------------
- ! ccn is formulted as ccn = ccn_surface * (den / den_surface)
- ! -----------------------------------------------------------------------
- ccn0 = ccn0 * rdgas * tz (kbot) / p1 (kbot)
- endif
- tmp = cpaut * (ccn0 * rhor) ** (- 1. / 3.)
- do k = ktop, kbot
- c_praut (k) = tmp
- ccn (k) = ccn0
+ ! convert # / cm^3 to # / m^3
+ ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + &
+ ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6
+ do k = ks, ke
+ ccn (k) = ccn0 / den (k)
+ c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.)
enddo
endif
@@ -692,15 +710,15 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
! default area dependent form: use dx ~ 100 km as the base
! -----------------------------------------------------------------------
- s_leng = sqrt (sqrt (area1 (i) / 1.e10))
+ s_leng = sqrt (gsize (i) / 1.e5)
t_land = dw_land * s_leng
t_ocean = dw_ocean * s_leng
- h_var = t_land * land (i) + t_ocean * (1. - land (i))
+ tmp = min (1., abs (hs (i)) / (10. * grav))
+ h_var = t_land * tmp + t_ocean * (1. - tmp)
h_var = min (0.20, max (0.01, h_var))
- ! if (id_var > 0) w_var (i) = h_var
! -----------------------------------------------------------------------
- ! relative humidity increment
+ ! relative humidity thresholds
! -----------------------------------------------------------------------
rh_adj = 1. - h_var - rh_inc
@@ -711,41 +729,26 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
! -----------------------------------------------------------------------
if (fix_negative) &
- call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz)
+ call neg_adj (ks, ke, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz, cond)
+
+ condensation (i) = condensation (i) + cond * convt * ntimes
m2_rain (i, :) = 0.
m2_sol (i, :) = 0.
do n = 1, ntimes
- ! -----------------------------------------------------------------------
- ! define air density based on hydrostatical property
- ! -----------------------------------------------------------------------
-
- if (p_nonhydro) then
- do k = ktop, kbot
- dz1 (k) = dz0 (k)
- den (k) = den0 (k) ! dry air density remains the same
- denfac (k) = sqrt (sfcrho / den (k))
- enddo
- else
- do k = ktop, kbot
- dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance
- den (k) = den0 (k) * dz0 (k) / dz1 (k)
- denfac (k) = sqrt (sfcrho / den (k))
- enddo
- endif
-
! -----------------------------------------------------------------------
! time - split warm rain processes: 1st pass
! -----------------------------------------------------------------------
- call warm_rain (dt_rain, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, &
- qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var)
+ call warm_rain (dt_rain, ks, ke, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, &
+ qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var, reevap, dte (i))
- rain (i) = rain (i) + r1
+ evaporation (i) = evaporation (i) + reevap * convt
+ rain (i) = rain (i) + r1 * convt
- do k = ktop, kbot
+ do k = ks, ke
m2_rain (i, k) = m2_rain (i, k) + m1_rain (k)
m1 (k) = m1 (k) + m1_rain (k)
enddo
@@ -754,34 +757,59 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
! sedimentation of cloud ice, snow, and graupel
! -----------------------------------------------------------------------
- call fall_speed (ktop, kbot, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz)
+ call fall_speed (ks, ke, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz)
+
+ call terminal_fall (dts, ks, ke, tz, qvz, qlz, qrz, qgz, qsz, qiz, &
+ dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1, dte (i))
- call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, &
- dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1)
+ rain (i) = rain (i) + r1 * convt ! from melted snow & ice that reached the ground
+ snow (i) = snow (i) + s1 * convt
+ graupel (i) = graupel (i) + g1 * convt
+ ice (i) = ice (i) + i1 * convt
- rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground
- snow (i) = snow (i) + s1
- graupel (i) = graupel (i) + g1
- ice (i) = ice (i) + i1
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qvz (k) * c1_vap + (qlz (k) + qrz (k)) * c1_liq + (qiz (k) + qsz (k) + qgz (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp1 (k)
+ enddo
+ endif
! -----------------------------------------------------------------------
! heat transportation during sedimentation
! -----------------------------------------------------------------------
- if (do_sedi_heat) &
- call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, &
- qsz, qgz, c_ice)
+ if (do_sedi_heat) then
+ call sedi_heat (ks, ke, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, &
+ qsz, qgz, c_ice)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qvz (k) * c1_vap + (qlz (k) + qrz (k)) * c1_liq + (qiz (k) + qsz (k) + qgz (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp1 (k)
+ enddo
+ dte (i) = dte (i) + sum (te1) - sum (te2)
+ endif
! -----------------------------------------------------------------------
! time - split warm rain processes: 2nd pass
! -----------------------------------------------------------------------
- call warm_rain (dt_rain, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, &
- qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var)
+ call warm_rain (dt_rain, ks, ke, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, &
+ qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var, reevap, dte (i))
- rain (i) = rain (i) + r1
+ evaporation (i) = evaporation (i) + reevap * convt
+ rain (i) = rain (i) + r1 * convt
- do k = ktop, kbot
+ do k = ks, ke
m2_rain (i, k) = m2_rain (i, k) + m1_rain (k)
m2_sol (i, k) = m2_sol (i, k) + m1_sol (k)
m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k)
@@ -791,8 +819,14 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
! ice - phase microphysics
! -----------------------------------------------------------------------
- call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, &
- denfac, vtsz, vtgz, vtrz, qaz, rh_adj, rh_rain, dts, h_var)
+ call icloud (ks, ke, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, ccn, &
+ cin, denfac, vtsz, vtgz, vtrz, qaz, rh_adj, rh_rain, dts, h_var, gsize (i), &
+ cond, dep, reevap, sub, last_step)
+
+ condensation (i) = condensation (i) + cond * convt
+ deposition (i) = deposition (i) + dep * convt
+ evaporation (i) = evaporation (i) + reevap * convt
+ sublimation (i) = sublimation (i) + sub * convt
enddo
@@ -802,144 +836,213 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, &
! -----------------------------------------------------------------------
if (sedi_transport) then
- do k = ktop + 1, kbot
+ do k = ks + 1, ke
u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1))
v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1))
- u_dt (i, k) = u_dt (i, k) + (u1 (k) - u0 (k)) * rdt
- v_dt (i, k) = v_dt (i, k) + (v1 (k) - v0 (k)) * rdt
+ ua (i, k) = u1 (k)
+ va (i, k) = v1 (k)
enddo
+ ! sjl modify tz due to ke loss:
+ ! seperate loop (vectorize better with no k - dependency)
+ if (disp_heat) then
+ do k = ks + 1, ke
+#ifdef MOIST_CAPPA
+ c8 = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice
+ tz (k) = tz (k) + 0.5 * (u0 (k) ** 2 + v0 (k) ** 2 - (u1 (k) ** 2 + v1 (k) ** 2)) / c8
+#else
+ tz (k) = tz (k) + 0.5 * (u0 (k) ** 2 + v0 (k) ** 2 - (u1 (k) ** 2 + v1 (k) ** 2)) / c_air
+#endif
+ enddo
+ endif
endif
if (do_sedi_w) then
- do k = ktop, kbot
+ ! conserve local te
+ !#ifdef disp_w
+ if (disp_heat) then
+ do k = ks, ke
+#ifdef MOIST_CAPPA
+ c8 = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice
+ tz (k) = tz (k) + 0.5 * (w (i, k) ** 2 - w1 (k) ** 2) / c8
+#else
+ tz (k) = tz (k) + 0.5 * (w (i, k) ** 2 - w1 (k) ** 2) / c_air
+#endif
+ enddo
+ endif
+ !#endif
+ do k = ks, ke
w (i, k) = w1 (k)
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ cvm (k) = c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_end (i, k) = cvm (k) * tz (k) + lv00 * c_air * qvz (k) - li00 * c_air * q_sol (k)
+ if (hydrostatic) then
+ te_end (i, k) = te_end (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2)
+ else
+ te_end (i, k) = te_end (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2 + w1 (k) ** 2)
+ endif
+ te_end (i, k) = rgrav * te_end (i, k) * dp1 (k) * gsize (i) ** 2.0
+ tw_end (i, k) = rgrav * (qvz (k) + q_liq (k) + q_sol (k)) * dp1 (k) * gsize (i) ** 2.0
+ enddo
+ te_b_end (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_end (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
+ ! total energy loss due to sedimentation and its heating
+ te_loss (i) = dte (i) * gsize (i) ** 2.0
+ endif
+
! -----------------------------------------------------------------------
! update moist air mass (actually hydrostatic pressure)
! convert to dry mixing ratios
! -----------------------------------------------------------------------
- do k = ktop, kbot
- omq = dp1 (k) / dp0 (k)
- qv_dt (i, k) = qv_dt (i, k) + rdt * (qvz (k) - qv0 (k)) * omq
- ql_dt (i, k) = ql_dt (i, k) + rdt * (qlz (k) - ql0 (k)) * omq
- qr_dt (i, k) = qr_dt (i, k) + rdt * (qrz (k) - qr0 (k)) * omq
- qi_dt (i, k) = qi_dt (i, k) + rdt * (qiz (k) - qi0 (k)) * omq
- qs_dt (i, k) = qs_dt (i, k) + rdt * (qsz (k) - qs0 (k)) * omq
- qg_dt (i, k) = qg_dt (i, k) + rdt * (qgz (k) - qg0 (k)) * omq
- cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice
- pt_dt (i, k) = pt_dt (i, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air
+ do k = ks, ke
+ ! total mass changed due to sedimentation !!!
+ con_r8 = one_r8 + qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k)
+ delp (i, k) = dp1 (k) * con_r8
+ ! convert back to moist mixing ratios
+ con_r8 = one_r8 / con_r8
+ qvz (k) = qvz (k) * con_r8
+ qlz (k) = qlz (k) * con_r8
+ qrz (k) = qrz (k) * con_r8
+ qiz (k) = qiz (k) * con_r8
+ qsz (k) = qsz (k) * con_r8
+ qgz (k) = qgz (k) * con_r8
+ ! all are moist mixing ratios at this point on:
+ qv (i, k) = qvz (k)
+ ql (i, k) = qlz (k)
+ qr (i, k) = qrz (k)
+ qi (i, k) = qiz (k)
+ qs (i, k) = qsz (k)
+ qg (i, k) = qgz (k)
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ q_cond = q_liq (k) + q_sol (k)
+ cvm (k) = (one_r8 - (qvz (k) + q_cond)) * c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+#ifdef MOIST_CAPPA
+ q_con (i, k) = q_cond
+ tmp = rdgas * (1. + zvir * qvz (k))
+ cappa (i, k) = tmp / (tmp + cvm (k))
+#endif
+ if (do_inline_mp) then
+#ifdef MOIST_CAPPA
+ pt (i, k) = tz (k) * (1. + zvir * qvz (k)) * (1. - q_cond)
+#else
+ pt (i, k) = tz (k) * (1. + zvir * qvz (k))
+#endif
+ else
+ pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * cvm (k) / cp_air
+ endif
enddo
! -----------------------------------------------------------------------
- ! update cloud fraction tendency
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = ql (i, k) + qr (i, k)
+ q_sol (k) = qi (i, k) + qs (i, k) + qg (i, k)
+ cvm (k) = c_air * (1.0 - qv (i, k) - q_liq (k) - q_sol (k)) + &
+ qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_end_0 (i, k) = cvm (k) * tz (k) + lv00 * c_air * qv (i, k) - li00 * c_air * q_sol (k)
+ te_end_0 (i, k) = te_end_0 (i, k) + 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 + w (i, k) ** 2)
+ te_end_0 (i, k) = rgrav * te_end_0 (i, k) * delp (i, k) * gsize (i) ** 2.0
+ tw_end_0 (i, k) = rgrav * (qv (i, k) + q_liq (k) + q_sol (k)) * delp (i, k) * gsize (i) ** 2.0
+ enddo
+ te_b_end_0 (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_end_0 (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! fix energy conservation
! -----------------------------------------------------------------------
- do k = ktop, kbot
- if (do_qa) then
- qa_dt (i, k) = 0.
+ if (consv_te) then
+ if (hydrostatic) then
+ do k = ks, ke
+ te (i, k) = te (i, k) + c_air * tz (k) * delp (i, k)
+ enddo
else
- qa_dt (i, k) = qa_dt (i, k) + rdt * (qaz (k) / real (ntimes) - qa0 (k))
+ do k = ks, ke
+#ifdef MOIST_CAPPA
+ te (i, k) = te (i, k) + cvm (k) * tz (k) * delp (i, k)
+#else
+ te (i, k) = te (i, k) + c_air * tz (k) * delp (i, k)
+#endif
+ enddo
endif
- enddo
+ endif
! -----------------------------------------------------------------------
- ! fms diagnostics:
+ ! update cloud fraction tendency
! -----------------------------------------------------------------------
- ! if (id_cond > 0) then
- ! do k = ktop, kbot ! total condensate
- ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k))
- ! enddo
- ! endif
- !
- ! if (id_vtr > 0) then
- ! do k = ktop, kbot
- ! vt_r (i, k) = vtrz (k)
- ! enddo
- ! endif
- !
- ! if (id_vts > 0) then
- ! do k = ktop, kbot
- ! vt_s (i, k) = vtsz (k)
- ! enddo
- ! endif
- !
- ! if (id_vtg > 0) then
- ! do k = ktop, kbot
- ! vt_g (i, k) = vtgz (k)
- ! enddo
- ! endif
- !
- ! if (id_vts > 0) then
- ! do k = ktop, kbot
- ! vt_i (i, k) = vtiz (k)
- ! enddo
- ! endif
- !
- ! if (id_droplets > 0) then
- ! do k = ktop, kbot
- ! qn2 (i, k) = ccn (k)
- ! enddo
- ! endif
+ do k = ks, ke
+ qa (i, k) = qaz (k)
+ enddo
enddo
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ if (abs (sum (te_end) + sum (te_b_end) - sum (te_beg) - sum (te_b_beg)) / (sum (te_beg) + sum (te_b_beg)) .gt. te_err) then
+ print *, "gfdl_cld_mp te: ", sum (te_beg) / sum (gsize ** 2) + sum (te_b_beg) / sum (gsize ** 2), &
+ sum (te_end) / sum (gsize ** 2) + sum (te_b_end) / sum (gsize ** 2), &
+ (sum (te_end) + sum (te_b_end) - sum (te_beg) - sum (te_b_beg)) / (sum (te_beg) + sum (te_b_beg))
+ endif
+ if (abs (sum (tw_end) + sum (tw_b_end) - sum (tw_beg) - sum (tw_b_beg)) / (sum (tw_beg) + sum (tw_b_beg)) .gt. te_err) then
+ print *, "gfdl_cld_mp tw: ", sum (tw_beg) / sum (gsize ** 2) + sum (tw_b_beg) / sum (gsize ** 2), &
+ sum (tw_end) / sum (gsize ** 2) + sum (tw_b_end) / sum (gsize ** 2), &
+ (sum (tw_end) + sum (tw_b_end) - sum (tw_beg) - sum (tw_b_beg)) / (sum (tw_beg) + sum (tw_b_beg))
+ endif
+ ! print *, "gfdl_cld_mp te loss (%) : ", sum (te_loss) / (sum (te_beg) + sum (te_b_beg)) * 100.0
+ endif
+
end subroutine mpdrv
! -----------------------------------------------------------------------
! sedimentation of heat
! -----------------------------------------------------------------------
-subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw)
-
- implicit none
-
+subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw)
+ ! revised with a precise energy conserving form: s. - j. lin, jan 22, 2018
! input q fields are dry mixing ratios, and dm is dry air mass
-
- integer, intent (in) :: ktop, kbot
-
- real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg
-
- real, intent (inout), dimension (ktop:kbot) :: tz
-
+ implicit none
+ integer, intent (in) :: ks, ke
+ real, intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
real, intent (in) :: cw ! heat capacity
-
- real, dimension (ktop:kbot) :: dgz, cvn
-
- real :: tmp
-
+ ! local:
+ real, dimension (ks:ke) :: dgz, cv0
integer :: k
- do k = ktop, kbot
- dgz (k) = - 0.5 * grav * dz (k) ! > 0
- cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * &
- c_liq + (qi (k) + qs (k) + qg (k)) * c_ice)
+ ! this is the vectorized loop
+ do k = ks + 1, ke
+ dgz (k) = - g2 * (dz (k - 1) + dz (k))
+ cv0 (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * c_liq + &
+ (qi (k) + qs (k) + qg (k)) * c_ice) + cw * (m1 (k) - m1 (k - 1))
+ ! cvm_new + cw * m1 (k) = cvm_old + cw * m1 (k - 1)
enddo
-
- ! -----------------------------------------------------------------------
- ! sjl, july 2014
- ! assumption: the ke in the falling condensates is negligible compared to the potential energy
- ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed
- ! into internal energy (to heat the whole grid box)
- ! backward time - implicit upwind transport scheme:
- ! dm here is dry air mass
- ! -----------------------------------------------------------------------
-
- k = ktop
- tmp = cvn (k) + m1 (k) * cw
- tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp
-
! -----------------------------------------------------------------------
! implicit algorithm: can't be vectorized
! needs an inner i - loop for vectorization
! -----------------------------------------------------------------------
-
- do k = ktop + 1, kbot
- tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * &
- cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k))
+ ! top layer: cv0 = cvn + cw * m1 (k)
+ ! tz (k) = cv0 (k) * tz (k) / (cvn (k) + cw * m1 (k)) = tz (k) -- > no change
+ do k = ks + 1, ke
+ tz (k) = (cv0 (k) * tz (k) + m1 (k - 1) * (cw * tz (k - 1) + dgz (k))) / (cv0 (k) + cw * m1 (k - 1))
enddo
end subroutine sedi_heat
@@ -948,43 +1051,37 @@ end subroutine sedi_heat
! warm rain cloud microphysics
! -----------------------------------------------------------------------
-subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
- den, denfac, ccn, c_praut, rh_rain, vtr, r1, m1_rain, w1, h_var)
+subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
+ den, denfac, ccn, c_praut, rh_rain, vtr, r1, m1_rain, w1, h_var, reevap, dte)
implicit none
- integer, intent (in) :: ktop, kbot
-
+ integer, intent (in) :: ks, ke
real, intent (in) :: dt ! time step (s)
real, intent (in) :: rh_rain, h_var
+ real, intent (in), dimension (ks:ke) :: dp, dz, den
+ real, intent (in), dimension (ks:ke) :: denfac, ccn, c_praut
- real, intent (in), dimension (ktop:kbot) :: dp, dz, den
- real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut
-
- real, intent (inout), dimension (ktop:kbot) :: tz, vtr
- real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg
- real, intent (inout), dimension (ktop:kbot) :: m1_rain, w1
-
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
+ real, intent (inout), dimension (ks:ke) :: vtr, qv, ql, qr, qi, qs, qg, m1_rain, w1
+ real (kind = r_grid), intent (inout) :: dte
real, intent (out) :: r1
-
+ real, intent (out) :: reevap
real, parameter :: so3 = 7. / 3.
+ ! fall velocity constants:
+ real, parameter :: vconr = 2503.23638966667
+ real, parameter :: normr = 25132741228.7183
+ real, parameter :: thr = 1.e-8
- real, dimension (ktop:kbot) :: dl, dm
- real, dimension (ktop:kbot + 1) :: ze, zt
-
- real :: sink, dq, qc0, qc
+ real, dimension (ks:ke) :: dl, dm
+ real (kind = r_grid), dimension (ks:ke) :: te1, te2
+ real, dimension (ks:ke + 1) :: ze, zt
+ real :: sink, dq, qc
real :: qden
real :: zs = 0.
real :: dt5
-
integer :: k
- ! fall velocity constants:
-
- real, parameter :: vconr = 2503.23638966667
- real, parameter :: normr = 25132741228.7183
- real, parameter :: thr = 1.e-8
-
logical :: no_fall
dt5 = 0.5 * dt
@@ -995,7 +1092,9 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
m1_rain (:) = 0.
- call check_column (ktop, kbot, qr, no_fall)
+ call check_column (ks, ke, qr, no_fall)
+
+ reevap = 0
if (no_fall) then
vtr (:) = vf_min
@@ -1009,7 +1108,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
if (const_vr) then
vtr (:) = vr_fac ! ifs_2016: 4.0
else
- do k = ktop, kbot
+ do k = ks, ke
qden = qr (k) * den (k)
if (qr (k) < thr) then
vtr (k) = vr_min
@@ -1021,8 +1120,8 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
enddo
endif
- ze (kbot + 1) = zs
- do k = kbot, ktop, - 1
+ ze (ke + 1) = zs
+ do k = ke, ks, - 1
ze (k) = ze (k + 1) - dz (k) ! dz < 0
enddo
@@ -1030,32 +1129,54 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
! evaporation and accretion of rain for the first 1 / 2 time step
! -----------------------------------------------------------------------
- ! if (.not. fast_sat_adj) &
- call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var)
+ call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
if (do_sedi_w) then
- do k = ktop, kbot
+ do k = ks, ke
dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k))
enddo
endif
! -----------------------------------------------------------------------
- ! mass flux induced by falling rain
+ ! energy loss during sedimentation
! -----------------------------------------------------------------------
- if (use_ppm) then
- zt (ktop) = ze (ktop)
- do k = ktop + 1, kbot
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! mass flux induced by falling rain
+ ! -----------------------------------------------------------------------
+
+ if (use_ppm) then
+ zt (ks) = ze (ks)
+ do k = ks + 1, ke
zt (k) = ze (k) - dt5 * (vtr (k - 1) + vtr (k))
enddo
- zt (kbot + 1) = zs - dt * vtr (kbot)
+ zt (ke + 1) = zs - dt * vtr (ke)
- do k = ktop, kbot
+ do k = ks, ke
if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
enddo
- call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof)
+ call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof)
else
- call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain)
+ call implicit_fall (dt, ks, ke, ze, vtr, dp, qr, r1, m1_rain)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
endif
! -----------------------------------------------------------------------
@@ -1063,25 +1184,51 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
! -----------------------------------------------------------------------
if (do_sedi_w) then
- w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop))
- do k = ktop + 1, kbot
- w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) &
- / (dm (k) + m1_rain (k - 1) - m1_rain (k))
+ ! conservation of vertical momentum:
+ w1 (ks) = w1 (ks) + m1_rain (ks) * vtr (ks) / dm (ks)
+ do k = ks + 1, ke
+ w1 (k) = (dm (k) * w1 (k) + m1_rain (k - 1) * (w1 (k - 1) - vtr (k - 1)) + m1_rain (k) * vtr (k)) &
+ / (dm (k) + m1_rain (k - 1))
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
enddo
endif
! -----------------------------------------------------------------------
- ! heat transportation during sedimentation
+ ! heat exchanges during sedimentation
! -----------------------------------------------------------------------
- if (do_sedi_heat) &
- call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq)
+ if (do_sedi_heat) then
+ call sedi_heat (ks, ke, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+ endif
+
! -----------------------------------------------------------------------
! evaporation and accretion of rain for the remaing 1 / 2 time step
! -----------------------------------------------------------------------
- call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var)
+ call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
endif
@@ -1097,17 +1244,9 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
! no subgrid varaibility
! -----------------------------------------------------------------------
- do k = ktop, kbot
- qc0 = fac_rc * ccn (k)
+ do k = ks, ke
+ qc = fac_rc * ccn (k)
if (tz (k) > t_wfr) then
- if (use_ccn) then
- ! -----------------------------------------------------------------------
- ! ccn is formulted as ccn = ccn_surface * (den / den_surface)
- ! -----------------------------------------------------------------------
- qc = qc0
- else
- qc = qc0 / den (k)
- endif
dq = ql (k) - qc
if (dq > 0.) then
sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))))
@@ -1123,23 +1262,15 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
! with subgrid varaibility
! -----------------------------------------------------------------------
- call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var)
+ call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var)
- do k = ktop, kbot
- qc0 = fac_rc * ccn (k)
+ do k = ks, ke
+ qc = fac_rc * ccn (k)
if (tz (k) > t_wfr + dt_fr) then
dl (k) = min (max (1.e-6, dl (k)), 0.5 * ql (k))
! --------------------------------------------------------------------
! as in klein's gfdl am2 stratiform scheme (with subgrid variations)
! --------------------------------------------------------------------
- if (use_ccn) then
- ! --------------------------------------------------------------------
- ! ccn is formulted as ccn = ccn_surface * (den / den_surface)
- ! --------------------------------------------------------------------
- qc = qc0
- else
- qc = qc0 / den (k)
- endif
dq = 0.5 * (ql (k) + dl (k) - qc)
! --------------------------------------------------------------------
! dq = dl if qc == q_minus = ql - dl
@@ -1163,27 +1294,33 @@ end subroutine warm_rain
! evaporation of rain
! -----------------------------------------------------------------------
-subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var)
+subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
implicit none
- integer, intent (in) :: ktop, kbot
-
+ integer, intent (in) :: ks, ke
real, intent (in) :: dt ! time step (s)
real, intent (in) :: rh_rain, h_var
-
- real, intent (in), dimension (ktop:kbot) :: den, denfac
-
- real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg
-
- real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk
-
+ real, intent (in), dimension (ks:ke) :: den, denfac, dp
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
+ real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg
+ real, intent (out) :: reevap
+ ! local:
+ real (kind = r_grid), dimension (ks:ke) :: cvm
+ real, dimension (ks:ke) :: q_liq, q_sol, lcpk
real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink
real :: qpz, dq, dqh, tin
+ real :: fac_revp, rh_tem
integer :: k
- do k = ktop, kbot
+ if (tau_revp .gt. 1.e-6) then
+ fac_revp = 1. - exp (- dt / tau_revp)
+ else
+ fac_revp = 1.
+ endif
+
+ do k = ks, ke
if (tz (k) > t_wfr .and. qr (k) > qrmin) then
@@ -1191,19 +1328,19 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac,
! define heat capacity and latent heat coefficient
! -----------------------------------------------------------------------
- lhl (k) = lv00 + d0_vap * tz (k) ! latent heat for liquid water, temp. dependent
- q_liq (k) = ql (k) + qr (k) ! amount of liquid water
+ q_liq (k) = ql (k) + qr (k)
q_sol (k) = qi (k) + qs (k) + qg (k)
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- lcpk (k) = lhl (k) / cvm (k) ! Lv/cv for total air
-
- tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap ! T if all cloud water evaporates
- qpz = qv (k) + ql (k) ! liquid water plus water vapor
- qsat = wqs2 (tin, den (k), dqsdt) ! sat vapor pressure
- dqh = max (ql (k), h_var * max (qpz, qcmin))!if ql = 0 (no cloud) this is h_var*qv
- dqh = min (dqh, 0.2 * qpz) ! new limiter ! if ql = 0 this is min(h_var*qv, 0.2*qv) = h_var*qv, which is no less than 0.01*qv
- dqv = qsat - qv (k) ! use this to prevent super - sat the gird box !saturation deficit
- q_minus = qpz - dqh ! if ql = 0 this is (1 - h_var)*qv
+
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k)
+ tin = (tz (k) * cvm (k) - lv00 * ql (k)) / (1. + (qv (k) + ql (k)) * c1_vap + qr (k) * c1_liq + q_sol (k) * c1_ice)
+
+ qpz = qv (k) + ql (k)
+ qsat = wqs2 (tin, den (k), dqsdt)
+ dqh = max (ql (k), h_var * max (qpz, qcmin))
+ dqh = min (dqh, 0.2 * qpz) ! new limiter
+ dqv = qsat - qv (k) ! use this to prevent super - sat the gird box
+ q_minus = qpz - dqh
q_plus = qpz + dqh
! -----------------------------------------------------------------------
@@ -1215,21 +1352,34 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac,
! rain evaporation
! -----------------------------------------------------------------------
- if (dqv > qvmin .and. qsat > q_minus) then ! if sat vapor pressure is > (1 - h_var)*qv ~= qv
- if (qsat > q_plus) then ! if significantly unsaturated
- dq = qsat - qpz ! sat deficit with cloud water included (evaporate that first)
+ rh_tem = qpz / iqs1 (tin, den (k))
+
+ if (dqv > qvmin .and. qsat > q_minus) then
+ if (qsat > q_plus) then
+ dq = qsat - qpz
else
! -----------------------------------------------------------------------
! q_minus < qsat < q_plus
- ! dq == dqh if qsat == q_plus
+ ! dq == dqh if qsat == q_minus
! -----------------------------------------------------------------------
- dq = 0.25 * (q_minus - qsat) ** 2 / dqh ! 0 for q_minus = q_sat;
+ dq = 0.25 * (qsat - q_minus) ** 2 / dqh
endif
qden = qr (k) * den (k)
t2 = tin * tin
- evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * &
- exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k))
- evap = min (qr (k), dt * evap, dqv / (1. + lcpk (k) * dqsdt))
+ if (use_rhc_revap) then
+ evap = 0.0
+ if (rh_tem < rhc_revap) then
+ evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * &
+ exp (0.725 * log (qden)) * sqrt (denfac (k))) / (crevp (4) * t2 + crevp (5) * qsat * den (k))
+ evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt))
+ endif
+ else
+ evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * &
+ exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k))
+ evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt))
+ endif
+ reevap = reevap + evap * dp (k)
+
! -----------------------------------------------------------------------
! alternative minimum evap in dry environmental air
! sink = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqsdt))
@@ -1238,8 +1388,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac,
qr (k) = qr (k) - evap
qv (k) = qv (k) + evap
q_liq (k) = q_liq (k) - evap
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) - evap * lhl (k) / cvm (k)
+ tz (k) = (cvm (k) * tz (k) - lv00 * evap) / (one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
endif
! -----------------------------------------------------------------------
@@ -1271,15 +1420,10 @@ subroutine linear_prof (km, q, dm, z_var, h_var)
implicit none
integer, intent (in) :: km
-
real, intent (in) :: q (km), h_var
-
real, intent (out) :: dm (km)
-
logical, intent (in) :: z_var
-
real :: dq (km)
-
integer :: k
if (z_var) then
@@ -1327,35 +1471,36 @@ end subroutine linear_prof
! author: shian - jiann lin, gfdl
! =======================================================================
-subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, &
- den, denfac, vts, vtg, vtr, qak, rh_adj, rh_rain, dts, h_var)
+subroutine icloud (ks, ke, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, den, &
+ ccn, cin, denfac, vts, vtg, vtr, qak, rh_adj, rh_rain, dts, h_var, &
+ gsize, cond, dep, reevap, sub, last_step)
implicit none
- integer, intent (in) :: ktop, kbot
-
- real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr
-
- real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak
-
- real, intent (in) :: rh_adj, rh_rain, dts, h_var
-
- real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi
- real, dimension (ktop:kbot) :: cvm, q_liq, q_sol
-
+ logical, intent (in) :: last_step
+ integer, intent (in) :: ks, ke
+ real, intent (in), dimension (ks:ke) :: p1, dp1, den, denfac, vts, vtg, vtr, ccn
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tzk
+ real, intent (inout), dimension (ks:ke) :: qvk, qlk, qrk, qik, qsk, qgk, qak
+ real, intent (inout), dimension (ks:ke) :: cin
+ real, intent (in) :: rh_adj, rh_rain, dts, h_var, gsize
+ real, intent (out) :: cond, dep, reevap, sub
+ ! local:
+ real, dimension (ks:ke) :: icpk, di, qim
+ real, dimension (ks:ke) :: q_liq, q_sol
+ real (kind = r_grid), dimension (ks:ke) :: cvm, te8
+ real (kind = r_grid) :: tz
real :: rdts, fac_g2v, fac_v2g, fac_i2s, fac_imlt
- real :: tz, qv, ql, qr, qi, qs, qg, melt
+ real :: qv, ql, qr, qi, qs, qg, melt
real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci
- real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub
- real :: tc, tsq, dqs0, qden, qim, qsm
+ real :: pgmlt, psmlt, pgfr, psaut
+ real :: tc, dqs0, qden, qsm
real :: dt5, factor, sink, qi_crt
real :: tmp, qsw, qsi, dqsdt, dq
real :: dtmp, qc, q_plus, q_minus
-
integer :: k
dt5 = 0.5 * dts
-
rdts = 1. / dts
! -----------------------------------------------------------------------
@@ -1365,449 +1510,421 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, &
fac_i2s = 1. - exp (- dts / tau_i2s)
fac_g2v = 1. - exp (- dts / tau_g2v)
fac_v2g = 1. - exp (- dts / tau_v2g)
-
fac_imlt = 1. - exp (- dt5 / tau_imlt)
! -----------------------------------------------------------------------
! define heat capacity and latend heat coefficient
! -----------------------------------------------------------------------
- do k = ktop, kbot
- lhi (k) = li00 + dc_ice * tzk (k)
+ do k = ks, ke
q_liq (k) = qlk (k) + qrk (k)
q_sol (k) = qik (k) + qsk (k) + qgk (k)
- cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- icpk (k) = lhi (k) / cvm (k)
+ cvm (k) = one_r8 + qvk (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ te8 (k) = cvm (k) * tzk (k) + lv00 * qvk (k) - li00 * q_sol (k)
+ icpk (k) = (li00 + d1_ice * tzk (k)) / cvm (k)
enddo
! -----------------------------------------------------------------------
- ! sources of cloud ice: pihom, cold rain, and the sat_adj
- ! (initiation plus deposition)
- ! sources of snow: cold rain, auto conversion + accretion (from cloud ice)
- ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion
+ ! similar to lfo 1983: eq. 21 solved implicitly
+ ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4
! -----------------------------------------------------------------------
- do k = ktop, kbot
- if (tzk (k) > tice .and. qik (k) > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! pimlt: instant melting of cloud ice
- ! -----------------------------------------------------------------------
-
- melt = min (qik (k), fac_imlt * (tzk (k) - tice) / icpk (k))
- tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount
- qlk (k) = qlk (k) + tmp
- qrk (k) = qrk (k) + melt - tmp
- qik (k) = qik (k) - melt
- q_liq (k) = q_liq (k) + melt
- q_sol (k) = q_sol (k) - melt
- cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tzk (k) = tzk (k) - melt * lhi (k) / cvm (k)
-
- elseif (tzk (k) < t_wfr .and. qlk (k) > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! pihom: homogeneous freezing of cloud water into cloud ice
- ! this is the 1st occurance of liquid water freezing in the split mp process
- ! -----------------------------------------------------------------------
-
- dtmp = t_wfr - tzk (k)
- factor = min (1., dtmp / dt_fr)
- sink = min (qlk (k) * factor, dtmp / icpk (k))
- qi_crt = qi_gen * min (qi_lim, 0.1 * (tice - tzk (k))) / den (k)
- tmp = min (sink, dim (qi_crt, qik (k)))
- qlk (k) = qlk (k) - sink
- qsk (k) = qsk (k) + sink - tmp
- qik (k) = qik (k) + tmp
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tzk (k) = tzk (k) + sink * lhi (k) / cvm (k)
-
+ do k = ks, ke
+ if (qi0_crt < 0.) then
+ qim (k) = - qi0_crt
+ else
+ qim (k) = qi0_crt / den (k)
endif
enddo
- ! -----------------------------------------------------------------------
- ! vertical subgrid variability
- ! -----------------------------------------------------------------------
+ if (.not. do_warm_rain_mp) then
- call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var)
+ ! -----------------------------------------------------------------------
+ ! sources of cloud ice: pihom, cold rain, and the sat_adj
+ ! (initiation plus deposition)
+ ! sources of snow: cold rain, auto conversion + accretion (from cloud ice)
+ ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ do k = ks, ke
+ if (tzk (k) > tice_mlt .and. qik (k) > qcmin) then
- do k = ktop, kbot
- lhl (k) = lv00 + d0_vap * tzk (k)
- lhi (k) = li00 + dc_ice * tzk (k)
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
- tcpk (k) = lcpk (k) + icpk (k)
- enddo
+ ! -----------------------------------------------------------------------
+ ! pimlt: instant melting of cloud ice
+ ! -----------------------------------------------------------------------
- do k = ktop, kbot
+ melt = min (qik (k), fac_imlt * (tzk (k) - tice_mlt) / icpk (k))
+ tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount
+ qlk (k) = qlk (k) + tmp
+ qrk (k) = qrk (k) + melt - tmp
+ qik (k) = qik (k) - melt
+ q_liq (k) = q_liq (k) + melt
+ q_sol (k) = q_sol (k) - melt
+ elseif (tzk (k) < t_wfr .and. qlk (k) > qcmin) then
+
+ ! -----------------------------------------------------------------------
+ ! pihom: homogeneous freezing of cloud water into cloud ice
+ ! -----------------------------------------------------------------------
+
+ dtmp = t_wfr - tzk (k)
+ factor = min (1., dtmp / dt_fr)
+ sink = min (qlk (k) * factor, dtmp / icpk (k))
+ tmp = min (sink, dim (qim (k), qik (k)))
+ qlk (k) = qlk (k) - sink
+ qsk (k) = qsk (k) + sink - tmp
+ qik (k) = qik (k) + tmp
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ endif
+ enddo
! -----------------------------------------------------------------------
- ! do nothing above p_min
+ ! vertical subgrid variability
! -----------------------------------------------------------------------
- if (p1 (k) < p_min) cycle
+ call linear_prof (ke - ks + 1, qik (ks), di (ks), z_slope_ice, h_var)
- tz = tzk (k)
- qv = qvk (k)
- ql = qlk (k)
- qi = qik (k)
- qr = qrk (k)
- qs = qsk (k)
- qg = qgk (k)
+ ! -----------------------------------------------------------------------
+ ! update capacity heat and latend heat coefficient
+ ! -----------------------------------------------------------------------
- pgacr = 0.
- pgacw = 0.
- tc = tz - tice
+ do k = ks, ke
+ cvm (k) = one_r8 + qvk (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tzk (k) = (te8 (k) - lv00 * qvk (k) + li00 * q_sol (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tzk (k)) / cvm (k)
+ enddo
- if (tc .ge. 0.) then
+ do k = ks, ke
! -----------------------------------------------------------------------
- ! melting of snow
+ ! do nothing above p_min
! -----------------------------------------------------------------------
- dqs0 = ces0 / p1 (k) - qv
-
- if (qs > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! psacw: accretion of cloud water by snow
- ! only rate is used (for snow melt) since tc > 0.
- ! -----------------------------------------------------------------------
+ if (p1 (k) < p_min) cycle
- if (ql > qrmin) then
- factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k)))
- psacw = factor / (1. + dts * factor) * ql ! rate
- else
- psacw = 0.
- endif
+ tz = tzk (k)
+ qv = qvk (k)
+ ql = qlk (k)
+ qi = qik (k)
+ qr = qrk (k)
+ qs = qsk (k)
+ qg = qgk (k)
- ! -----------------------------------------------------------------------
- ! psacr: accretion of rain by melted snow
- ! pracs: accretion of snow by rain
- ! -----------------------------------------------------------------------
+ pgacr = 0.
+ pgacw = 0.
+ tc = tz - tice
- if (qr > qrmin) then
- psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), &
- den (k)), qr * rdts)
- pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k))
- else
- psacr = 0.
- pracs = 0.
- endif
+ if (tc .ge. 0.) then
! -----------------------------------------------------------------------
- ! total snow sink:
- ! psmlt: snow melt (due to rain accretion)
+ ! melting of snow
! -----------------------------------------------------------------------
- psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, &
- den (k), denfac (k)))
- sink = min (qs, dts * (psmlt + pracs), tc / icpk (k))
- qs = qs - sink
- ! sjl, 20170321:
- tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt
- ql = ql + tmp
- qr = qr + sink - tmp
- ! qr = qr + sink
- ! sjl, 20170321:
- q_liq (k) = q_liq (k) + sink
- q_sol (k) = q_sol (k) - sink
- cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz = tz - sink * lhi (k) / cvm (k)
- tc = tz - tice
-
- endif
+ dqs0 = ces0 / p1 (k) - qv ! not sure if this is correct; check again
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ if (qs > qcmin) then
- lhi (k) = li00 + dc_ice * tz
- icpk (k) = lhi (k) / cvm (k)
+ ! -----------------------------------------------------------------------
+ ! psacw: accretion of cloud water by snow
+ ! only rate is used (for snow melt) since tc > 0.
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! melting of graupel
- ! -----------------------------------------------------------------------
+ if (ql > qrmin) then
+ factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k)))
+ psacw = factor / (1. + dts * factor) * ql ! rate
+ else
+ psacw = 0.
+ endif
- if (qg > qcmin .and. tc > 0.) then
+ ! -----------------------------------------------------------------------
+ ! psacr: accretion of rain by melted snow
+ ! pracs: accretion of snow by rain
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
+ if (qr > qrmin) then
+ psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), &
+ den (k)), qr * rdts)
+ pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k))
+ else
+ psacr = 0.
+ pracs = 0.
+ endif
- if (qr > qrmin) &
- pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), rdts * qr)
+ ! -----------------------------------------------------------------------
+ ! total snow sink:
+ ! psmlt: snow melt (due to rain accretion)
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by graupel
- ! -----------------------------------------------------------------------
+ psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, &
+ den (k), denfac (k)))
+ sink = min (qs, dts * (psmlt + pracs), tc / icpk (k))
+ qs = qs - sink
+ tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt
+ ql = ql + tmp
+ qr = qr + sink - tmp
+ q_liq (k) = q_liq (k) + sink
+ q_sol (k) = q_sol (k) - sink
+
+ cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
+ tc = tz - tice
+ icpk (k) = (li00 + d1_ice * tz) / cvm (k)
- qden = qg * den (k)
- if (ql > qrmin) then
- factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
- pgacw = factor / (1. + dts * factor) * ql ! rate
endif
! -----------------------------------------------------------------------
- ! pgmlt: graupel melt
+ ! melting of graupel
! -----------------------------------------------------------------------
- pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k))
- pgmlt = min (max (0., pgmlt), qg, tc / icpk (k))
- qg = qg - pgmlt
- qr = qr + pgmlt
- q_liq (k) = q_liq (k) + pgmlt
- q_sol (k) = q_sol (k) - pgmlt
- cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz = tz - pgmlt * lhi (k) / cvm (k)
-
- endif
+ if (qg > qcmin .and. tc > 0.) then
- else
+ ! -----------------------------------------------------------------------
+ ! pgacr: accretion of rain by graupel
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! cloud ice proc:
- ! -----------------------------------------------------------------------
+ if (qr > qrmin) &
+ pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
+ den (k)), rdts * qr)
- ! -----------------------------------------------------------------------
- ! psaci: accretion of cloud ice by snow
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! pgacw: accretion of cloud water by graupel
+ ! -----------------------------------------------------------------------
- if (qi > 3.e-7) then ! cloud ice sink terms
+ qden = qg * den (k)
+ if (ql > qrmin) then
+ factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
+ pgacw = factor / (1. + dts * factor) * ql ! rate
+ endif
- if (qs > 1.e-7) then
! -----------------------------------------------------------------------
- ! sjl added (following lin eq. 23) the temperature dependency
- ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004
+ ! pgmlt: graupel melt
! -----------------------------------------------------------------------
- factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k)))
- psaci = factor / (1. + factor) * qi
- else
- psaci = 0.
+
+ pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k))
+ pgmlt = min (max (0., pgmlt), qg, tc / icpk (k))
+ qg = qg - pgmlt
+ qr = qr + pgmlt
+ q_liq (k) = q_liq (k) + pgmlt
+ q_sol (k) = q_sol (k) - pgmlt
+ cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
endif
- ! -----------------------------------------------------------------------
- ! pasut: autoconversion: cloud ice -- > snow
- ! -----------------------------------------------------------------------
+ else
! -----------------------------------------------------------------------
- ! similar to lfo 1983: eq. 21 solved implicitly
- ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4
+ ! cloud ice proc:
! -----------------------------------------------------------------------
- if (qi0_crt < 0.) then
- qim = - qi0_crt
- else
- qim = qi0_crt / den (k)
- endif
-
! -----------------------------------------------------------------------
- ! assuming linear subgrid vertical distribution of cloud ice
- ! the mismatch computation following lin et al. 1994, mwr
+ ! psaci: accretion of cloud ice by snow
! -----------------------------------------------------------------------
- if (const_vi) then
- tmp = fac_i2s
- else
- tmp = fac_i2s * exp (0.025 * tc)
- endif
+ if (qi > 3.e-7) then ! cloud ice sink terms
- di (k) = max (di (k), qrmin)
- q_plus = qi + di (k)
- if (q_plus > (qim + qrmin)) then
- if (qim > (qi - di (k))) then
- dq = (0.25 * (q_plus - qim) ** 2) / di (k)
+ if (qs > 1.e-7) then
+ ! -----------------------------------------------------------------------
+ ! sjl added (following lin eq. 23) the temperature dependency
+ ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004
+ ! -----------------------------------------------------------------------
+ factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k)))
+ psaci = factor / (1. + factor) * qi
else
- dq = qi - qim
+ psaci = 0.
endif
- psaut = tmp * dq
- else
- psaut = 0.
- endif
- ! -----------------------------------------------------------------------
- ! sink is no greater than 75% of qi
- ! -----------------------------------------------------------------------
- sink = min (0.75 * qi, psaci + psaut)
- qi = qi - sink
- qs = qs + sink
-
- ! -----------------------------------------------------------------------
- ! pgaci: accretion of cloud ice by graupel
- ! -----------------------------------------------------------------------
- if (qg > 1.e-6) then
! -----------------------------------------------------------------------
- ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k)))
- ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1
+ ! assuming linear subgrid vertical distribution of cloud ice
+ ! the mismatch computation following lin et al. 1994, mwr
! -----------------------------------------------------------------------
- factor = dts * cgaci * sqrt (den (k)) * qg
- pgaci = factor / (1. + factor) * qi
- qi = qi - pgaci
- qg = qg + pgaci
- endif
- endif
+ if (const_vi) then
+ tmp = fac_i2s
+ else
+ tmp = fac_i2s * exp (0.025 * tc)
+ endif
- ! -----------------------------------------------------------------------
- ! cold - rain proc:
- ! -----------------------------------------------------------------------
+ di (k) = max (di (k), qrmin)
+ q_plus = qi + di (k)
+ if (q_plus > (qim (k) + qrmin)) then
+ if (qim (k) > (qi - di (k))) then
+ dq = (0.25 * (q_plus - qim (k)) ** 2) / di (k)
+ else
+ dq = qi - qim (k)
+ endif
+ psaut = tmp * dq
+ else
+ psaut = 0.
+ endif
+ ! -----------------------------------------------------------------------
+ ! sink is no greater than 75% of qi
+ ! -----------------------------------------------------------------------
+ sink = min (0.75 * qi, psaci + psaut)
+ qi = qi - sink
+ qs = qs + sink
- ! -----------------------------------------------------------------------
- ! rain to ice, snow, graupel processes:
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! pgaci: accretion of cloud ice by graupel
+ ! -----------------------------------------------------------------------
- tc = tz - tice
+ if (qg > 1.e-6) then
+ ! -----------------------------------------------------------------------
+ ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k)))
+ ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1
+ ! -----------------------------------------------------------------------
+ factor = dts * cgaci / sqrt (den (k)) * exp (0.875 * log (qg * den (k)))
+ pgaci = factor / (1. + factor) * qi
+ qi = qi - pgaci
+ qg = qg + pgaci
+ endif
- if (qr > 1.e-7 .and. tc < 0.) then
+ endif
! -----------------------------------------------------------------------
- ! * sink * terms to qr: psacr + pgfr
- ! source terms to qs: psacr
- ! source terms to qg: pgfr
+ ! cold - rain proc:
! -----------------------------------------------------------------------
! -----------------------------------------------------------------------
- ! psacr accretion of rain by snow
+ ! rain to ice, snow, graupel processes:
! -----------------------------------------------------------------------
- if (qs > 1.e-7) then ! if snow exists
- psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k))
- else
- psacr = 0.
- endif
+ tc = tz - tice
- ! -----------------------------------------------------------------------
- ! pgfr: rain freezing -- > graupel
- ! -----------------------------------------------------------------------
+ if (qr > 1.e-7 .and. tc < 0.) then
- pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
- exp (1.75 * log (qr * den (k)))
+ ! -----------------------------------------------------------------------
+ ! * sink * terms to qr: psacr + pgfr
+ ! source terms to qs: psacr
+ ! source terms to qg: pgfr
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! total sink to qr
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! psacr accretion of rain by snow
+ ! -----------------------------------------------------------------------
- sink = psacr + pgfr
- factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin)
+ if (qs > 1.e-7) then ! if snow exists
+ psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k))
+ else
+ psacr = 0.
+ endif
- psacr = factor * psacr
- pgfr = factor * pgfr
+ ! -----------------------------------------------------------------------
+ ! pgfr: rain freezing -- > graupel
+ ! -----------------------------------------------------------------------
- sink = psacr + pgfr
- qr = qr - sink
- qs = qs + psacr
- qg = qg + pgfr
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz = tz + sink * lhi (k) / cvm (k)
+ pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
+ exp (1.75 * log (qr * den (k)))
- endif
+ ! -----------------------------------------------------------------------
+ ! total sink to qr
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ sink = psacr + pgfr
+ factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin)
- lhi (k) = li00 + dc_ice * tz
- icpk (k) = lhi (k) / cvm (k)
+ psacr = factor * psacr
+ pgfr = factor * pgfr
- ! -----------------------------------------------------------------------
- ! graupel production terms:
- ! -----------------------------------------------------------------------
+ sink = psacr + pgfr
+ qr = qr - sink
+ qs = qs + psacr
+ qg = qg + pgfr
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
- if (qs > 1.e-7) then
+ cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz) / cvm (k)
+ endif
! -----------------------------------------------------------------------
- ! accretion: snow -- > graupel
+ ! graupel production terms:
! -----------------------------------------------------------------------
- if (qg > qrmin) then
- sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k))
- else
- sink = 0.
- endif
+ if (qs > 1.e-7) then
- ! -----------------------------------------------------------------------
- ! autoconversion snow -- > graupel
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! accretion: snow -- > graupel
+ ! -----------------------------------------------------------------------
- qsm = qs0_crt / den (k)
- if (qs > qsm) then
- factor = dts * 1.e-3 * exp (0.09 * (tz - tice))
- sink = sink + factor / (1. + factor) * (qs - qsm)
- endif
- sink = min (qs, sink)
- qs = qs - sink
- qg = qg + sink
+ if (qg > qrmin) then
+ sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k))
+ else
+ sink = 0.
+ endif
- endif ! snow existed
+ ! -----------------------------------------------------------------------
+ ! autoconversion snow -- > graupel
+ ! -----------------------------------------------------------------------
- if (qg > 1.e-7 .and. tz < tice0) then
+ qsm = qs0_crt / den (k)
+ if (qs > qsm) then
+ factor = dts * 1.e-3 * exp (0.09 * (tz - tice))
+ sink = sink + factor / (1. + factor) * (qs - qsm)
+ endif
+ sink = min (qs, sink)
+ qs = qs - sink
+ qg = qg + sink
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by graupel
- ! -----------------------------------------------------------------------
+ endif ! snow existed
- if (ql > 1.e-6) then
- qden = qg * den (k)
- factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
- pgacw = factor / (1. + factor) * ql
- else
- pgacw = 0.
- endif
+ if (qg > 1.e-7 .and. tz < tice) then
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! pgacw: accretion of cloud water by graupel
+ ! -----------------------------------------------------------------------
- if (qr > 1.e-6) then
- pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), qr)
- else
- pgacr = 0.
- endif
+ if (ql > 1.e-6) then
+ qden = qg * den (k)
+ factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
+ pgacw = factor / (1. + factor) * ql
+ else
+ pgacw = 0.
+ endif
- sink = pgacr + pgacw
- factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qrmin)
- pgacr = factor * pgacr
- pgacw = factor * pgacw
+ ! -----------------------------------------------------------------------
+ ! pgacr: accretion of rain by graupel
+ ! -----------------------------------------------------------------------
- sink = pgacr + pgacw
- qg = qg + sink
- qr = qr - pgacr
- ql = ql - pgacw
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz = tz + sink * lhi (k) / cvm (k)
+ if (qr > 1.e-6) then
+ pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
+ den (k)), qr)
+ else
+ pgacr = 0.
+ endif
- endif
+ sink = pgacr + pgacw
+ factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qrmin)
+ pgacr = factor * pgacr
+ pgacw = factor * pgacw
- endif
+ sink = pgacr + pgacw
+ qg = qg + sink
+ qr = qr - pgacr
+ ql = ql - pgacw
- tzk (k) = tz
- qvk (k) = qv
- qlk (k) = ql
- qik (k) = qi
- qrk (k) = qr
- qsk (k) = qs
- qgk (k) = qg
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / (one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
+ endif
- enddo
+ endif
- ! -----------------------------------------------------------------------
- ! subgrid cloud microphysics
- ! -----------------------------------------------------------------------
+ tzk (k) = tz
+ qvk (k) = qv
+ qlk (k) = ql
+ qik (k) = qi
+ qrk (k) = qr
+ qsk (k) = qs
+ qgk (k) = qg
- call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tzk, qvk, &
- qlk, qrk, qik, qsk, qgk, qak, h_var, rh_rain)
+ enddo
+
+ endif
+
+ call subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tzk, qvk, qlk, &
+ qrk, qik, qsk, qgk, qak, dp1, h_var, rh_rain, te8, ccn, cin, gsize, &
+ cond, dep, reevap, sub, last_step)
end subroutine icloud
@@ -1815,40 +1932,39 @@ end subroutine icloud
! temperature sentive high vertical resolution processes
! =======================================================================
-subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, &
- ql, qr, qi, qs, qg, qa, h_var, rh_rain)
+subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, ql, qr, &
+ qi, qs, qg, qa, dp1, h_var, rh_rain, te8, ccn, cin, gsize, cond, dep, reevap, sub, last_step)
implicit none
- integer, intent (in) :: ktop, kbot
-
- real, intent (in), dimension (ktop:kbot) :: p1, den, denfac
-
- real, intent (in) :: dts, rh_adj, h_var, rh_rain
-
- real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa
-
- real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi
- real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond
-
- real :: fac_v2l, fac_l2v
-
+ integer, intent (in) :: ks, ke
+ real, intent (in) :: dts, rh_adj, h_var, rh_rain, gsize
+ real, intent (in), dimension (ks:ke) :: p1, den, denfac, ccn, dp1
+ real (kind = r_grid), intent (in), dimension (ks:ke) :: te8
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+ real, intent (inout), dimension (ks:ke) :: cin
+ logical, intent (in) :: last_step
+ real, intent (out) :: cond, dep, reevap, sub
+ ! local:
+ real, dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+ real, dimension (ks:ke) :: q_liq, q_sol, q_cond
+ real (kind = r_grid), dimension (ks:ke) :: cvm
real :: pidep, qi_crt
-
+ real :: sigma, gam
! -----------------------------------------------------------------------
! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty
! must not be too large to allow psc
! -----------------------------------------------------------------------
-
- real :: rh, rqi, tin, qsw, qsi, qpz, qstar
- real :: dqsdt, dwsdt, dq, dq0, factor, tmp
+ real :: rh, rqi, tin, qsw, qsi, qpz, qstar, rh_tem
+ real :: dqsdt, dwsdt, dq, dq0, factor, tmp, liq, ice
real :: q_plus, q_minus, dt_evap, dt_pisub
- real :: evap, sink, tc, pisub, q_adj, dtmp
- real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g
-
+ real :: evap, sink, tc, dtmp, qa10, qa100
+ real :: pssub, pgsub, tsq, qden
+ real :: fac_l2v, fac_v2l, fac_g2v, fac_v2g
integer :: k
- if (fast_sat_adj) then
+ if (do_sat_adj) then
dt_evap = 0.5 * dts
else
dt_evap = dts
@@ -1858,9 +1974,8 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, &
! define conversion scalar / factor
! -----------------------------------------------------------------------
- fac_v2l = 1. - exp (- dt_evap / tau_v2l)
fac_l2v = 1. - exp (- dt_evap / tau_l2v)
-
+ fac_v2l = 1. - exp (- dt_evap / tau_v2l)
fac_g2v = 1. - exp (- dts / tau_g2v)
fac_v2g = 1. - exp (- dts / tau_v2g)
@@ -1868,290 +1983,284 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, &
! define heat capacity and latend heat coefficient
! -----------------------------------------------------------------------
- do k = ktop, kbot
- lhl (k) = lv00 + d0_vap * tz (k)
- lhi (k) = li00 + dc_ice * tz (k)
+ do k = ks, ke
q_liq (k) = ql (k) + qr (k)
q_sol (k) = qi (k) + qs (k) + qg (k)
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
- tcpk (k) = lcpk (k) + icpk (k)
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr))
enddo
- do k = ktop, kbot
+ cond = 0
+ dep = 0
+ reevap = 0
+ sub = 0
- if (p1 (k) < p_min) cycle
+ do k = ks, ke
- ! -----------------------------------------------------------------------
- ! instant deposit all water vapor to cloud ice when temperature is super low
- ! -----------------------------------------------------------------------
-
- if (tz (k) < t_min) then
- sink = dim (qv (k), 1.e-7)
- qv (k) = qv (k) - sink
- qi (k) = qi (k) + sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k)
- if (.not. do_qa) qa (k) = qa (k) + 1. ! air fully saturated; 100 % cloud cover
- cycle
- endif
+ if (p1 (k) < p_min) cycle
- ! -----------------------------------------------------------------------
- ! update heat capacity and latend heat coefficient
- ! -----------------------------------------------------------------------
+ if (.not. do_warm_rain_mp) then
- lhl (k) = lv00 + d0_vap * tz (k)
- lhi (k) = li00 + dc_ice * tz (k)
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
- tcpk (k) = lcpk (k) + icpk (k)
- tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr))
+ ! -----------------------------------------------------------------------
+ ! instant deposit all water vapor to cloud ice when temperature is super low
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free
- ! -----------------------------------------------------------------------
+ if (tz (k) < t_min) then
+ sink = dim (qv (k), 1.e-7)
+ dep = dep + sink * dp1 (k)
+ qv (k) = qv (k) - sink
+ qi (k) = qi (k) + sink
+ q_sol (k) = q_sol (k) + sink
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / &
+ (one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
+ if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover
+ cycle
+ endif
- qpz = qv (k) + ql (k) + qi (k)
- tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + &
- qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice)
- if (tin > t_sub + 6.) then
- rh = qpz / iqs1 (tin, den (k))
- if (rh < rh_adj) then ! qpz / rh_adj < qs
- tz (k) = tin
- qv (k) = qpz
- ql (k) = 0.
- qi (k) = 0.
- cycle ! cloud free
+ ! -----------------------------------------------------------------------
+ ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free
+ ! -----------------------------------------------------------------------
+ ! rain water is handled in warm - rain process.
+ qpz = qv (k) + ql (k) + qi (k)
+ tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / &
+ (one_r8 + qpz * c1_vap + qr (k) * c1_liq + (qs (k) + qg (k)) * c1_ice)
+ if (tin > t_sub + 6.) then
+ rh = qpz / iqs1 (tin, den (k))
+ if (rh < rh_adj) then ! qpz / rh_adj < qs
+ reevap = reevap + ql (k) * dp1 (k)
+ sub = sub + qi (k) * dp1 (k)
+ tz (k) = tin
+ qv (k) = qpz
+ ql (k) = 0.
+ qi (k) = 0.
+ cycle ! cloud free
+ endif
endif
+
endif
! -----------------------------------------------------------------------
! cloud water < -- > vapor adjustment:
! -----------------------------------------------------------------------
- qsw = wqs2 (tz (k), den (k), dwsdt)
+ tin = tz (k)
+ rh_tem = qpz / iqs1 (tin, den (k))
+ qsw = wqs2 (tin, den (k), dwsdt)
dq0 = qsw - qv (k)
- if (dq0 > 0.) then
- ! sjl 20170703 added ql factor to prevent the situation of high ql and low rh
- ! factor = min (1., fac_l2v * sqrt (max (0., ql (k)) / 1.e-5) * 10. * dq0 / qsw)
- ! factor = fac_l2v
- ! factor = 1
- factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90%
- evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt))
- else ! condensate all excess vapor into cloud water
- ! -----------------------------------------------------------------------
- ! evap = fac_v2l * dq0 / (1. + tcp3 (k) * dwsdt)
- ! sjl, 20161108
- ! -----------------------------------------------------------------------
- evap = dq0 / (1. + tcp3 (k) * dwsdt)
+ if (use_rhc_cevap) then
+ evap = 0.
+ if (rh_tem .lt. rhc_cevap) then
+ if (dq0 > 0.) then ! evaporation
+ factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90%
+ evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt))
+ reevap = reevap + evap * dp1 (k)
+ elseif (do_cond_timescale) then
+ factor = min (1., fac_v2l * (10. * (- dq0) / qsw))
+ evap = - min (qv (k), factor * (- dq0) / (1. + tcp3 (k) * dwsdt))
+ cond = cond - evap * dp1 (k)
+ else ! condensate all excess vapor into cloud water
+ evap = dq0 / (1. + tcp3 (k) * dwsdt)
+ cond = cond - evap * dp1 (k)
+ endif
+ endif
+ else
+ if (dq0 > 0.) then ! evaporation
+ factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90%
+ evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt))
+ reevap = reevap + evap * dp1 (k)
+ elseif (do_cond_timescale) then
+ factor = min (1., fac_v2l * (10. * (- dq0) / qsw))
+ evap = - min (qv (k), factor * (- dq0) / (1. + tcp3 (k) * dwsdt))
+ cond = cond - evap * dp1 (k)
+ else ! condensate all excess vapor into cloud water
+ evap = dq0 / (1. + tcp3 (k) * dwsdt)
+ cond = cond - evap * dp1 (k)
+ endif
endif
+ ! sjl on jan 23 2018: reversible evap / condensation:
qv (k) = qv (k) + evap
ql (k) = ql (k) - evap
q_liq (k) = q_liq (k) - evap
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) - evap * lhl (k) / cvm (k)
-
- ! -----------------------------------------------------------------------
- ! update heat capacity and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- lhi (k) = li00 + dc_ice * tz (k)
- icpk (k) = lhi (k) / cvm (k)
-
- ! -----------------------------------------------------------------------
- ! enforce complete freezing below - 48 c
- ! -----------------------------------------------------------------------
- dtmp = t_wfr - tz (k) ! [ - 40, - 48]
- if (dtmp > 0. .and. ql (k) > qcmin) then
- sink = min (ql (k), ql (k) * dtmp * 0.125, dtmp / icpk (k))
- ql (k) = ql (k) - sink
- qi (k) = qi (k) + sink
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) + sink * lhi (k) / cvm (k)
- endif
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
! -----------------------------------------------------------------------
! update heat capacity and latend heat coefficient
! -----------------------------------------------------------------------
- lhi (k) = li00 + dc_ice * tz (k)
- icpk (k) = lhi (k) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
- ! -----------------------------------------------------------------------
- ! bigg mechanism
- ! -----------------------------------------------------------------------
+ if (.not. do_warm_rain_mp) then
- if (fast_sat_adj) then
- dt_pisub = 0.5 * dts
- else
- dt_pisub = dts
- tc = tice - tz (k)
- if (ql (k) > qrmin .and. tc > 0.) then
- sink = 3.3333e-10 * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k)
- sink = min (ql (k), tc / icpk (k), sink)
+ ! -----------------------------------------------------------------------
+ ! enforce complete freezing below - 48 c
+ ! -----------------------------------------------------------------------
+
+ dtmp = t_wfr - tz (k) ! [ - 40, - 48]
+ if (dtmp > 0. .and. ql (k) > qcmin) then
+ sink = min (ql (k), ql (k) * dtmp * 0.125, dtmp / icpk (k))
ql (k) = ql (k) - sink
qi (k) = qi (k) + sink
q_liq (k) = q_liq (k) - sink
q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) + sink * lhi (k) / cvm (k)
- endif ! significant ql existed
- endif
-
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- lhl (k) = lv00 + d0_vap * tz (k)
- lhi (k) = li00 + dc_ice * tz (k)
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
- tcpk (k) = lcpk (k) + icpk (k)
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
+ endif
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of ice
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! bigg mechanism
+ ! -----------------------------------------------------------------------
- if (tz (k) < tice) then
- qsi = iqs2 (tz (k), den (k), dqsdt)
- dq = qv (k) - qsi
- sink = dq / (1. + tcpk (k) * dqsdt)
- if (qi (k) > qrmin) then
- ! eq 9, hong et al. 2004, mwr
- ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8)
- pidep = dt_pisub * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) &
- / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4)
+ if (do_sat_adj) then
+ dt_pisub = 0.5 * dts
else
- pidep = 0.
- endif
- if (dq > 0.) then ! vapor - > ice
- tmp = tice - tz (k)
- ! 20160912: the following should produce more ice at higher altitude
- ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (k)
- qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (k)
- sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k))
- else ! ice -- > vapor
- pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2)
- sink = max (pidep, sink, - qi (k))
+ dt_pisub = dts
+ tc = tice - tz (k)
+ if (ql (k) > qrmin .and. tc > 0.1) then
+ sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2
+ sink = min (ql (k), tc / icpk (k), sink)
+ ql (k) = ql (k) - sink
+ qi (k) = qi (k) + sink
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ endif ! significant ql existed
endif
- qv (k) = qv (k) - sink
- qi (k) = qi (k) + sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k)
- endif
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! update capacity heat and latend heat coefficient
+ ! -----------------------------------------------------------------------
- lhl (k) = lv00 + d0_vap * tz (k)
- lhi (k) = li00 + dc_ice * tz (k)
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
- tcpk (k) = lcpk (k) + icpk (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of snow
- ! this process happens for all temp rage
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! sublimation / deposition of ice
+ ! -----------------------------------------------------------------------
- if (qs (k) > qrmin) then
- qsi = iqs2 (tz (k), den (k), dqsdt)
- qden = qs (k) * den (k)
- tmp = exp (0.65625 * log (qden))
- tsq = tz (k) * tz (k)
- dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt)
- pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * &
- sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k))
- pssub = (qsi - qv (k)) * dts * pssub
- if (pssub > 0.) then ! qs -- > qv, sublimation
- pssub = min (pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k))
- else
- if (tz (k) > tice) then
- pssub = 0. ! no deposition
+ if (tz (k) < tice) then
+ qsi = iqs2 (tz (k), den (k), dqsdt)
+ dq = qv (k) - qsi
+ sink = dq / (1. + tcpk (k) * dqsdt)
+ if (qi (k) > qrmin) then
+ if (.not. prog_ccn) then
+ if (inflag .eq. 1) &
+ ! hong et al., 2004
+ cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k)))
+ if (inflag .eq. 2) &
+ ! meyers et al., 1992
+ cin (k) = exp (-2.80 + 0.262 * (tice - tz (k))) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 3) &
+ ! meyers et al., 1992
+ cin (k) = exp (-0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 4) &
+ ! cooper, 1986
+ cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 5) &
+ ! flecther, 1962
+ cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.0 ! convert from L^-1 to m^-3
+ endif
+ pidep = dt_pisub * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) &
+ / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4)
else
- pssub = max (pssub, dq, (tz (k) - tice) / tcpk (k))
+ pidep = 0.
+ endif
+ if (dq > 0.) then ! vapor - > ice
+ tmp = tice - tz (k)
+ ! 20160912: the following should produce more ice at higher altitude
+ ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (k)
+ qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (k)
+ sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k))
+ dep = dep + sink * dp1 (k)
+ else ! ice -- > vapor
+ pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2)
+ sink = max (pidep, sink, - qi (k))
+ sub = sub - sink * dp1 (k)
endif
+ qv (k) = qv (k) - sink
+ qi (k) = qi (k) + sink
+ q_sol (k) = q_sol (k) + sink
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
endif
- qs (k) = qs (k) - pssub
- qv (k) = qv (k) + pssub
- q_sol (k) = q_sol (k) - pssub
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k)
- endif
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! update capacity heat and latend heat coefficient
+ ! -----------------------------------------------------------------------
- lhl (k) = lv00 + d0_vap * tz (k)
- lhi (k) = li00 + dc_ice * tz (k)
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
- tcpk (k) = lcpk (k) + icpk (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
- ! -----------------------------------------------------------------------
- ! simplified 2 - way grapuel sublimation - deposition mechanism
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! sublimation / deposition of snow
+ ! this process happens for all temp rage
+ ! -----------------------------------------------------------------------
- if (qg (k) > qrmin) then
- qsi = iqs2 (tz (k), den (k), dqsdt)
- dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt)
- pgsub = (qv (k) / qsi - 1.) * qg (k)
- if (pgsub > 0.) then ! deposition
- if (tz (k) > tice) then
- pgsub = 0. ! no deposition
+ if (qs (k) > qrmin) then
+ qsi = iqs2 (tz (k), den (k), dqsdt)
+ qden = qs (k) * den (k)
+ tmp = exp (0.65625 * log (qden))
+ tsq = tz (k) * tz (k)
+ dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt)
+ pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * &
+ sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k))
+ pssub = (qsi - qv (k)) * dts * pssub
+ if (pssub > 0.) then ! qs -- > qv, sublimation
+ pssub = min (pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k))
+ sub = sub + pssub * dp1 (k)
else
- pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), &
- (tice - tz (k)) / tcpk (k))
+ if (tz (k) > tice) then
+ pssub = 0. ! no deposition
+ else
+ pssub = max (pssub, dq, (tz (k) - tice) / tcpk (k))
+ endif
+ dep = dep - pssub * dp1 (k)
endif
- else ! submilation
- pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1)
+ qs (k) = qs (k) - pssub
+ qv (k) = qv (k) + pssub
+ q_sol (k) = q_sol (k) - pssub
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
endif
- qg (k) = qg (k) + pgsub
- qv (k) = qv (k) - pgsub
- q_sol (k) = q_sol (k) + pgsub
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k)
- endif
-
-#ifdef USE_MIN_EVAP
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
- lhl (k) = lv00 + d0_vap * tz (k)
- lcpk (k) = lhl (k) / cvm (k)
+ ! -----------------------------------------------------------------------
+ ! sublimation / deposition of graupel
+ ! this process happens for all temp rage
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! * minimum evap of rain in dry environmental air
- ! -----------------------------------------------------------------------
+ if (qg (k) > qrmin) then
+ qsi = iqs2 (tz (k), den (k), dqsdt)
+ qden = qg (k) * den (k)
+ tmp = exp (0.6875 * log (qden))
+ tsq = tz (k) * tz (k)
+ dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt)
+ pgsub = cgsub (1) * tsq * (cgsub (2) * sqrt (qden) + cgsub (3) * tmp / &
+ sqrt (sqrt (den (k)))) / (cgsub (4) * tsq + cgsub (5) * qsi * den (k))
+ pgsub = (qsi - qv (k)) * dts * pgsub
+ if (pgsub > 0.) then ! qs -- > qv, sublimation
+ pgsub = min (pgsub * min (1., dim (tz (k), t_sub) * 0.2), qg (k))
+ sub = sub + pgsub * dp1 (k)
+ else
+ if (tz (k) > tice) then
+ pgsub = 0. ! no deposition
+ else
+ pgsub = max (pgsub, dq, (tz (k) - tice) / tcpk (k))
+ endif
+ dep = dep - pgsub * dp1 (k)
+ endif
+ qg (k) = qg (k) - pgsub
+ qv (k) = qv (k) + pgsub
+ q_sol (k) = q_sol (k) - pgsub
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
+ endif
- if (qr (k) > qcmin) then
- qsw = wqs2 (tz (k), den (k), dqsdt)
- sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt))
- qv (k) = qv (k) + sink
- qr (k) = qr (k) - sink
- q_liq (k) = q_liq (k) - sink
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) - sink * lhl (k) / cvm (k)
endif
-#endif
-
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- lhl (k) = lv00 + d0_vap * tz (k)
- cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap
- lcpk (k) = lhl (k) / cvm (k)
! -----------------------------------------------------------------------
! compute cloud fraction
@@ -2161,30 +2270,37 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, &
! combine water species
! -----------------------------------------------------------------------
- if (do_qa) cycle
+ if (.not. (do_qa .and. last_step)) cycle
+ ice = q_sol (k)
if (rad_snow) then
- q_sol (k) = qi (k) + qs (k)
+ if (rad_graupel) then
+ q_sol (k) = qi (k) + qs (k) + qg (k)
+ else
+ q_sol (k) = qi (k) + qs (k)
+ endif
else
q_sol (k) = qi (k)
endif
+ liq = q_liq (k)
if (rad_rain) then
q_liq (k) = ql (k) + qr (k)
else
q_liq (k) = ql (k)
endif
- q_cond (k) = q_liq (k) + q_sol (k)
- qpz = qv (k) + q_cond (k) ! qpz is conserved
+ q_cond (k) = q_liq (k) + q_sol (k)
+ qpz = qv (k) + q_cond (k)
! -----------------------------------------------------------------------
! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity
! -----------------------------------------------------------------------
-
- tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature
- ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + &
- ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap)
-
+ ! tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature
+ !! tin = (tz (k) * cvm (i) + li00 * q_sol (k) - lv00 * q_cond (k)) / &
+ !! (one_r8 + (qv (k) + q_cond (k)) * c1_vap)
+ ice = ice - q_sol (k)
+ liq = liq - q_liq (k)
+ tin = (te8 (k) - lv00 * qpz + li00 * ice) / (one_r8 + qpz * c1_vap + liq * c1_liq + ice * c1_ice)
! -----------------------------------------------------------------------
! determine saturated specific humidity
! -----------------------------------------------------------------------
@@ -2215,16 +2331,116 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, &
! binary cloud scheme
! -----------------------------------------------------------------------
- if (qpz > qrmin) then
- ! partial cloudiness by pdf:
- dq = max (qcmin, h_var * qpz)
- q_plus = qpz + dq ! cloud free if qstar > q_plus
- q_minus = qpz - dq
- if (qstar < q_minus) then
- qa (k) = qa (k) + 1. ! air fully saturated; 100 % cloud cover
- elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then
- qa (k) = qa (k) + (q_plus - qstar) / (dq + dq) ! partial cloud cover
- ! qa (k) = sqrt (qa (k) + (q_plus - qstar) / (dq + dq))
+ ! -----------------------------------------------------------------------
+ ! partial cloudiness by pdf:
+ ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the
+ ! binary cloud scheme; qa = 0.5 if qstar == qpz
+ ! -----------------------------------------------------------------------
+
+ qpz = cld_fac * qpz
+ rh = qpz / qstar
+
+ ! -----------------------------------------------------------------------
+ ! icloud_f = 0: bug - fixed
+ ! icloud_f = 1: old fvgfs gfdl) mp implementation
+ ! icloud_f = 2: binary cloud scheme (0 / 1)
+ ! icloud_f = 3: revision of icloud = 0
+ ! -----------------------------------------------------------------------
+
+ if (use_xr_cloud) then ! xu and randall cloud scheme (1996)
+ if (rh >= 1.0) then
+ qa (k) = 1.0
+ elseif (rh > rh_thres .and. q_cond (k) > 1.e-6) then
+ qa (k) = rh ** xr_a * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / &
+ max (1.e-5, (max (1.e-10, 1.0 - rh) * qstar) ** xr_c)))
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ qa (k) = 0.0
+ endif
+ elseif (use_park_cloud) then ! park et al. 2016 (mon. wea. review)
+ if (q_cond (k) > 1.e-6) then
+ qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * max (0.0, q_cond (k) * 1000.) ** 1.07 + &
+ 4.82 * (gsize / 1000. - 50.) * max (0.0, q_cond (k) * 1000.) ** 0.94)
+ qa (k) = qa (k) * (0.92 / 0.96 * q_liq (k) / q_cond (k) + 1.0 / 0.96 * q_sol (k) / q_cond (k))
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ qa (k) = 0.0
+ endif
+ elseif (use_gi_cloud) then ! gultepe and isaac (2007)
+ sigma = 0.28 + max (0.0, q_cond (k) * 1000.) ** 0.49
+ gam = max (0.0, q_cond (k) * 1000.) / sigma
+ if (gam < 0.18) then
+ qa10 = 0.
+ elseif (gam > 2.0) then
+ qa10 = 1.0
+ else
+ qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3
+ qa10 = max (0.0, min (1., qa10))
+ endif
+ if (gam < 0.12) then
+ qa100 = 0.
+ elseif (gam > 1.85) then
+ qa100 = 1.0
+ else
+ qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3
+ qa100 = max (0.0, min (1., qa100))
+ endif
+ qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10)
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ if (rh > rh_thres .and. qpz > 1.e-6) then
+
+ dq = h_var * qpz
+ if (do_cld_adj) then
+ q_plus = qpz + dq * f_dq_p * min(1.0, max(0.0, (p1 (k) - 200.e2) / (1000.e2 - 200.e2)))
+ else
+ q_plus = qpz + dq * f_dq_p
+ endif
+ q_minus = qpz - dq * f_dq_m
+
+ if (icloud_f .eq. 2) then
+ if (qstar < qpz) then
+ qa (k) = 1.
+ else
+ qa (k) = 0.
+ endif
+ elseif (icloud_f .eq. 3) then
+ if (qstar < qpz) then
+ qa (k) = 1.
+ else
+ if (qstar < q_plus) then
+ qa (k) = (q_plus - qstar) / (dq * f_dq_p)
+ else
+ qa (k) = 0.
+ endif
+ ! impose minimum cloudiness if substantial q_cond (k) exist
+ if (q_cond (k) > 1.e-6) then
+ qa (k) = max (cld_min, qa (k))
+ endif
+ qa (k) = min (1., qa (k))
+ endif
+ else
+ if (qstar < q_minus) then
+ qa (k) = 1.
+ else
+ if (qstar < q_plus) then
+ if (icloud_f .eq. 0) then
+ qa (k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m)
+ else
+ qa (k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * (1. - q_cond (k)))
+ endif
+ else
+ qa (k) = 0.
+ endif
+ ! impose minimum cloudiness if substantial q_cond (k) exist
+ if (q_cond (k) > 1.e-6) then
+ qa (k) = max (cld_min, qa (k))
+ endif
+ qa (k) = min (1., qa (k))
+ endif
+ endif
+ else
+ qa (k) = 0.
endif
endif
@@ -2330,35 +2546,30 @@ end subroutine revap_rac1
! consider cloud ice, snow, and graupel's melting during fall
! =======================================================================
-subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
- den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1)
+subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
+ den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1, dte)
implicit none
- integer, intent (in) :: ktop, kbot
-
+ integer, intent (in) :: ks, ke
real, intent (in) :: dtm ! time step (s)
-
- real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz
-
- real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1
-
+ real, intent (in), dimension (ks:ke) :: vtg, vts, vti, den, dp, dz
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qg, qs, qi, m1_sol, w1
+ real (kind = r_grid), intent (inout) :: dte
real, intent (out) :: r1, g1, s1, i1
-
- real, dimension (ktop:kbot + 1) :: ze, zt
-
+ ! local:
+ real, dimension (ks:ke + 1) :: ze, zt
real :: qsat, dqsdt, dt5, evap, dtime
real :: factor, frac
real :: tmp, precip, tc, sink
-
- real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi
- real, dimension (ktop:kbot) :: m1, dm
-
+ real, dimension (ks:ke) :: lcpk, icpk, cvm, q_liq, q_sol
+ real, dimension (ks:ke) :: m1, dm
+ real (kind = r_grid), dimension (ks:ke) :: te1, te2
real :: zs = 0.
real :: fac_imlt
integer :: k, k0, m
-
logical :: no_fall
dt5 = 0.5 * dtm
@@ -2368,23 +2579,21 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
! define heat capacity and latend heat coefficient
! -----------------------------------------------------------------------
- do k = ktop, kbot
+ do k = ks, ke
m1_sol (k) = 0.
- lhl (k) = lv00 + d0_vap * tz (k)
- lhi (k) = li00 + dc_ice * tz (k)
q_liq (k) = ql (k) + qr (k)
q_sol (k) = qi (k) + qs (k) + qg (k)
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- lcpk (k) = lhl (k) / cvm (k)
- icpk (k) = lhi (k) / cvm (k)
+ cvm (k) = 1. + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
enddo
! -----------------------------------------------------------------------
! find significant melting level
! -----------------------------------------------------------------------
- k0 = kbot
- do k = ktop, kbot - 1
+ k0 = ke
+ do k = ks, ke - 1
if (tz (k) > tice) then
k0 = k
exit
@@ -2395,7 +2604,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
! melting of cloud_ice (before fall) :
! -----------------------------------------------------------------------
- do k = k0, kbot
+ do k = k0, ke
tc = tz (k) - tice
if (qi (k) > qcmin .and. tc > 0.) then
sink = min (qi (k), fac_imlt * tc / icpk (k))
@@ -2405,8 +2614,9 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
qi (k) = qi (k) - sink
q_liq (k) = q_liq (k) + sink
q_sol (k) = q_sol (k) - sink
- cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
- tz (k) = tz (k) - sink * lhi (k) / cvm (k)
+ tz (k) = tz (k) * cvm (k) - li00 * sink
+ cvm (k) = 1. + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = tz (k) / cvm (k)
tc = tz (k) - tice
endif
enddo
@@ -2415,51 +2625,49 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
! turn off melting when cloud microphysics time step is small
! -----------------------------------------------------------------------
- if (dtm < 60.) k0 = kbot
-
! sjl, turn off melting of falling cloud ice, snow and graupel
- k0 = kbot
+ ! if (dtm < 60.) k0 = ke
+ k0 = ke
! sjl, turn off melting of falling cloud ice, snow and graupel
- ze (kbot + 1) = zs
- do k = kbot, ktop, - 1
+ ze (ke + 1) = zs
+ do k = ke, ks, - 1
ze (k) = ze (k + 1) - dz (k) ! dz < 0
enddo
- zt (ktop) = ze (ktop)
+ zt (ks) = ze (ks)
! -----------------------------------------------------------------------
! update capacity heat and latend heat coefficient
! -----------------------------------------------------------------------
- do k = k0, kbot
- lhi (k) = li00 + dc_ice * tz (k)
- icpk (k) = lhi (k) / cvm (k)
+ do k = k0, ke
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
enddo
! -----------------------------------------------------------------------
- ! melting of falling cloud ice into rain
+ ! melting of falling cloud ice into cloud water and rain
! -----------------------------------------------------------------------
- call check_column (ktop, kbot, qi, no_fall)
+ call check_column (ks, ke, qi, no_fall)
if (vi_fac < 1.e-5 .or. no_fall) then
i1 = 0.
else
- do k = ktop + 1, kbot
+ do k = ks + 1, ke
zt (k) = ze (k) - dt5 * (vti (k - 1) + vti (k))
enddo
- zt (kbot + 1) = zs - dtm * vti (kbot)
+ zt (ke + 1) = zs - dtm * vti (ke)
- do k = ktop, kbot
+ do k = ks, ke
if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
enddo
- if (k0 < kbot) then
- do k = kbot - 1, k0, - 1
+ if (k0 < ke) then
+ do k = ke - 1, k0, - 1
if (qi (k) > qrmin) then
- do m = k + 1, kbot
+ do m = k + 1, ke
if (zt (k + 1) >= ze (m)) exit
if (zt (k) < ze (m + 1) .and. tz (m) > tice) then
dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt))
@@ -2467,8 +2675,9 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
tmp = min (sink, dim (ql_mlt, ql (m)))
ql (m) = ql (m) + tmp
qr (m) = qr (m) - tmp + sink
- tz (m) = tz (m) - sink * icpk (m)
qi (k) = qi (k) - sink * dp (m) / dp (k)
+ tz (m) = (tz (m) * cvm (m) - li00 * sink) / &
+ (1. + qv (m) * c1_vap + (ql (m) + qr (m)) * c1_liq + (qi (m) + qs (m) + qg (m)) * c1_ice)
endif
enddo
endif
@@ -2476,22 +2685,45 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
endif
if (do_sedi_w) then
- do k = ktop, kbot
+ do k = ks, ke
dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k))
enddo
endif
- if (use_ppm) then
- call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof)
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
+ if (use_ppm_ice) then
+ call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof)
else
- call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol)
+ call implicit_fall (dtm, ks, ke, ze, vti, dp, qi, i1, m1_sol)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
endif
if (do_sedi_w) then
- w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop))
- do k = ktop + 1, kbot
- w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) &
- / (dm (k) + m1_sol (k - 1) - m1_sol (k))
+ w1 (ks) = w1 (ks) + m1_sol (ks) * vti (ks) / dm (ks)
+ do k = ks + 1, ke
+ w1 (k) = (dm (k) * w1 (k) + m1_sol (k - 1) * (w1 (k - 1) - vti (k - 1)) + m1_sol (k) * vti (k)) &
+ / (dm (k) + m1_sol (k - 1))
enddo
endif
@@ -2503,25 +2735,25 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
r1 = 0.
- call check_column (ktop, kbot, qs, no_fall)
+ call check_column (ks, ke, qs, no_fall)
if (no_fall) then
s1 = 0.
else
- do k = ktop + 1, kbot
+ do k = ks + 1, ke
zt (k) = ze (k) - dt5 * (vts (k - 1) + vts (k))
enddo
- zt (kbot + 1) = zs - dtm * vts (kbot)
+ zt (ke + 1) = zs - dtm * vts (ke)
- do k = ktop, kbot
+ do k = ks, ke
if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
enddo
- if (k0 < kbot) then
- do k = kbot - 1, k0, - 1
+ if (k0 < ke) then
+ do k = ke - 1, k0, - 1
if (qs (k) > qrmin) then
- do m = k + 1, kbot
+ do m = k + 1, ke
if (zt (k + 1) >= ze (m)) exit
dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k)))
if (zt (k) < ze (m + 1) .and. tz (m) > tice) then
@@ -2543,26 +2775,49 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
endif
if (do_sedi_w) then
- do k = ktop, kbot
+ do k = ks, ke
dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k))
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
if (use_ppm) then
- call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof)
+ call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qs, s1, m1, mono_prof)
else
- call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1)
+ call implicit_fall (dtm, ks, ke, ze, vts, dp, qs, s1, m1)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
endif
- do k = ktop, kbot
+ do k = ks, ke
m1_sol (k) = m1_sol (k) + m1 (k)
enddo
if (do_sedi_w) then
- w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop))
- do k = ktop + 1, kbot
- w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) &
- / (dm (k) + m1 (k - 1) - m1 (k))
+ w1 (ks) = w1 (ks) + m1 (ks) * vts (ks) / dm (ks)
+ do k = ks + 1, ke
+ w1 (k) = (dm (k) * w1 (k) + m1 (k - 1) * (w1 (k - 1) - vts (k - 1)) + m1 (k) * vts (k)) &
+ / (dm (k) + m1 (k - 1))
enddo
endif
@@ -2572,25 +2827,25 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
! melting of falling graupel into rain
! ----------------------------------------------
- call check_column (ktop, kbot, qg, no_fall)
+ call check_column (ks, ke, qg, no_fall)
if (no_fall) then
g1 = 0.
else
- do k = ktop + 1, kbot
+ do k = ks + 1, ke
zt (k) = ze (k) - dt5 * (vtg (k - 1) + vtg (k))
enddo
- zt (kbot + 1) = zs - dtm * vtg (kbot)
+ zt (ke + 1) = zs - dtm * vtg (ke)
- do k = ktop, kbot
+ do k = ks, ke
if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
enddo
- if (k0 < kbot) then
- do k = kbot - 1, k0, - 1
+ if (k0 < ke) then
+ do k = ke - 1, k0, - 1
if (qg (k) > qrmin) then
- do m = k + 1, kbot
+ do m = k + 1, ke
if (zt (k + 1) >= ze (m)) exit
dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k))
if (zt (k) < ze (m + 1) .and. tz (m) > tice) then
@@ -2611,26 +2866,49 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
endif
if (do_sedi_w) then
- do k = ktop, kbot
+ do k = ks, ke
dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k))
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
if (use_ppm) then
- call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof)
+ call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qg, g1, m1, mono_prof)
else
- call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1)
+ call implicit_fall (dtm, ks, ke, ze, vtg, dp, qg, g1, m1)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
endif
- do k = ktop, kbot
+ do k = ks, ke
m1_sol (k) = m1_sol (k) + m1 (k)
enddo
if (do_sedi_w) then
- w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop))
- do k = ktop + 1, kbot
- w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) &
- / (dm (k) + m1 (k - 1) - m1 (k))
+ w1 (ks) = w1 (ks) + m1 (ks) * vtg (ks) / dm (ks)
+ do k = ks + 1, ke
+ w1 (k) = (dm (k) * w1 (k) + m1 (k - 1) * (w1 (k - 1) - vtg (k - 1)) + m1 (k) * vtg (k)) &
+ / (dm (k) + m1 (k - 1))
enddo
endif
@@ -2642,21 +2920,18 @@ end subroutine terminal_fall
! check if water species large enough to fall
! =======================================================================
-subroutine check_column (ktop, kbot, q, no_fall)
+subroutine check_column (ks, ke, q, no_fall)
implicit none
- integer, intent (in) :: ktop, kbot
-
- real, intent (in) :: q (ktop:kbot)
-
+ integer, intent (in) :: ks, ke
+ real, intent (in) :: q (ks:ke)
logical, intent (out) :: no_fall
-
integer :: k
no_fall = .true.
- do k = ktop, kbot
+ do k = ks, ke
if (q (k) > qrmin) then
no_fall = .false.
exit
@@ -2670,29 +2945,21 @@ end subroutine check_column
! developed by sj lin, 2016
! =======================================================================
-subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1)
+subroutine implicit_fall (dt, ks, ke, ze, vt, dp, q, precip, m1)
implicit none
- integer, intent (in) :: ktop, kbot
-
+ integer, intent (in) :: ks, ke
real, intent (in) :: dt
-
- real, intent (in), dimension (ktop:kbot + 1) :: ze
-
- real, intent (in), dimension (ktop:kbot) :: vt, dp
-
- real, intent (inout), dimension (ktop:kbot) :: q
-
- real, intent (out), dimension (ktop:kbot) :: m1
-
+ real, intent (in), dimension (ks:ke + 1) :: ze
+ real, intent (in), dimension (ks:ke) :: vt, dp
+ real, intent (inout), dimension (ks:ke) :: q
+ real, intent (out), dimension (ks:ke) :: m1
real, intent (out) :: precip
-
- real, dimension (ktop:kbot) :: dz, qm, dd
-
+ real, dimension (ks:ke) :: dz, qm, dd
integer :: k
- do k = ktop, kbot
+ do k = ks, ke
dz (k) = ze (k) - ze (k + 1)
dd (k) = dt * vt (k)
q (k) = q (k) * dp (k)
@@ -2702,8 +2969,8 @@ subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1)
! sedimentation: non - vectorizable loop
! -----------------------------------------------------------------------
- qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop))
- do k = ktop + 1, kbot
+ qm (ks) = q (ks) / (dz (ks) + dd (ks))
+ do k = ks + 1, ke
qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k))
enddo
@@ -2711,7 +2978,7 @@ subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1)
! qm is density at this stage
! -----------------------------------------------------------------------
- do k = ktop, kbot
+ do k = ks, ke
qm (k) = qm (k) * dz (k)
enddo
@@ -2719,17 +2986,17 @@ subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1)
! output mass fluxes: non - vectorizable loop
! -----------------------------------------------------------------------
- m1 (ktop) = q (ktop) - qm (ktop)
- do k = ktop + 1, kbot
+ m1 (ks) = q (ks) - qm (ks)
+ do k = ks + 1, ke
m1 (k) = m1 (k - 1) + q (k) - qm (k)
enddo
- precip = m1 (kbot)
+ precip = m1 (ke)
! -----------------------------------------------------------------------
! update:
! -----------------------------------------------------------------------
- do k = ktop, kbot
+ do k = ks, ke
q (k) = qm (k) / dp (k)
enddo
@@ -2737,43 +3004,34 @@ end subroutine implicit_fall
! =======================================================================
! lagrangian scheme
-! developed by sj lin, ????
+! developed by sj lin, around 2006
! =======================================================================
-subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono)
+subroutine lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, q, precip, m1, mono)
implicit none
- integer, intent (in) :: ktop, kbot
-
+ integer, intent (in) :: ks, ke
real, intent (in) :: zs
-
logical, intent (in) :: mono
-
- real, intent (in), dimension (ktop:kbot + 1) :: ze, zt
-
- real, intent (in), dimension (ktop:kbot) :: dp
+ real, intent (in), dimension (ks:ke + 1) :: ze, zt
+ real, intent (in), dimension (ks:ke) :: dp
! m1: flux
- real, intent (inout), dimension (ktop:kbot) :: q, m1
-
+ real, intent (inout), dimension (ks:ke) :: q, m1
real, intent (out) :: precip
+ real, dimension (ks:ke) :: qm, dz
- real, dimension (ktop:kbot) :: qm, dz
-
- real :: a4 (4, ktop:kbot)
-
+ real :: a4 (4, ks:ke)
real :: pl, pr, delz, esl
-
integer :: k, k0, n, m
-
real, parameter :: r3 = 1. / 3., r23 = 2. / 3.
! -----------------------------------------------------------------------
! density:
! -----------------------------------------------------------------------
- do k = ktop, kbot
+ do k = ks, ke
dz (k) = zt (k) - zt (k + 1) ! note: dz is positive
q (k) = q (k) * dp (k)
a4 (1, k) = q (k) / dz (k)
@@ -2784,11 +3042,11 @@ subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono)
! construct vertical profile with zt as coordinate
! -----------------------------------------------------------------------
- call cs_profile (a4 (1, ktop), dz (ktop), kbot - ktop + 1, mono)
+ call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1, mono)
- k0 = ktop
- do k = ktop, kbot
- do n = k0, kbot
+ k0 = ks
+ do k = ks, ke
+ do n = k0, ke
if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then
pl = (zt (n) - ze (k)) / dz (n)
if (zt (n + 1) <= ze (k + 1)) then
@@ -2802,8 +3060,8 @@ subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono)
else
qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + &
a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl))))
- if (n < kbot) then
- do m = n + 1, kbot
+ if (n < ke) then
+ do m = n + 1, ke
! locate the bottom edge: ze (k + 1)
if (ze (k + 1) < zt (m + 1)) then
qm (k) = qm (k) + q (m)
@@ -2824,16 +3082,16 @@ subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono)
555 continue
enddo
- m1 (ktop) = q (ktop) - qm (ktop)
- do k = ktop + 1, kbot
+ m1 (ks) = q (ks) - qm (ks)
+ do k = ks + 1, ke
m1 (k) = m1 (k - 1) + q (k) - qm (k)
enddo
- precip = m1 (kbot)
+ precip = m1 (ke)
! convert back to * dry * mixing ratio:
! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) .
- do k = ktop, kbot
+ do k = ks, ke
q (k) = qm (k) / dp (k)
enddo
@@ -2844,15 +3102,10 @@ subroutine cs_profile (a4, del, km, do_mono)
implicit none
integer, intent (in) :: km ! vertical dimension
-
real, intent (in) :: del (km)
-
logical, intent (in) :: do_mono
-
real, intent (inout) :: a4 (4, km)
-
real, parameter :: qp_min = 1.e-6
-
real :: gam (km)
real :: q (km + 1)
real :: d4, bet, a_bot, grat, pmp, lac
@@ -3056,14 +3309,15 @@ end subroutine cs_limiters
! calculation of vertical fall speed
! =======================================================================
-subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
+subroutine fall_speed (ks, ke, den, qs, qi, qg, ql, tk, vts, vti, vtg)
implicit none
- integer, intent (in) :: ktop, kbot
+ integer, intent (in) :: ks, ke
- real, intent (in), dimension (ktop:kbot) :: den, qs, qi, qg, ql, tk
- real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg
+ real (kind = r_grid), intent (in), dimension (ks:ke) :: tk
+ real, intent (in), dimension (ks:ke) :: den, qs, qi, qg, ql
+ real, intent (out), dimension (ks:ke) :: vts, vti, vtg
! fall velocity constants:
@@ -3081,12 +3335,12 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
real, parameter :: vcons = 6.6280504
real, parameter :: vcong = 87.2382675
- real, parameter :: vconh = vcong * sqrt (rhoh / rhog)
+ real, parameter :: vconh = vcong * sqrt (rhoh / rhog) ! 132.087495104005
real, parameter :: norms = 942477796.076938
real, parameter :: normg = 5026548245.74367
- real, parameter :: normh = pi * rhoh * rnzh
+ real, parameter :: normh = pi * rhoh * rnzh ! 115233618.533674
- real, dimension (ktop:kbot) :: qden, tc, rhof
+ real, dimension (ks:ke) :: qden, tc, rhof
real :: vi0
@@ -3101,7 +3355,7 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
! much smaller than sfcrho over high mountains
! -----------------------------------------------------------------------
- do k = ktop, kbot
+ do k = ks, ke
rhof (k) = sqrt (min (10., sfcrho / den (k)))
enddo
@@ -3116,13 +3370,19 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
! use deng and mace (2008, grl), which gives smaller fall speed than hd90 formula
! -----------------------------------------------------------------------
vi0 = 0.01 * vi_fac
- do k = ktop, kbot
+ do k = ks, ke
if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi
vti (k) = vf_min
else
tc (k) = tk (k) - tice
- vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee
- vti (k) = vi0 * exp (log_10 * vti (k))
+ if (hd_icefall) then
+ ! heymsfield and donner, 1990, jas
+ vti (k) = vi_fac * 3.29 * (qi (k) * den (k)) ** 0.16
+ else
+ ! deng and mace, 2008, grl
+ vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee
+ vti (k) = vi0 * exp (log_10 * vti (k))
+ endif
vti (k) = min (vi_max, max (vf_min, vti (k)))
endif
enddo
@@ -3135,7 +3395,7 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
if (const_vs) then
vts (:) = vs_fac ! 1. ifs_2016
else
- do k = ktop, kbot
+ do k = ks, ke
if (qs (k) < ths) then
vts (k) = vf_min
else
@@ -3153,7 +3413,7 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
vtg (:) = vg_fac ! 2.
else
if (do_hail) then
- do k = ktop, kbot
+ do k = ks, ke
if (qg (k) < thg) then
vtg (k) = vf_min
else
@@ -3162,7 +3422,7 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg)
endif
enddo
else
- do k = ktop, kbot
+ do k = ks, ke
if (qg (k) < thg) then
vtg (k) = vf_min
else
@@ -3194,9 +3454,8 @@ subroutine setupm
gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, &
gam625 = 184.860962, gam680 = 496.604067
- ! density / slope parameters now moved up to module level
-
real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /)
+
real den_rc
integer :: i, k
@@ -3220,11 +3479,11 @@ subroutine setupm
tcond = 2.36e-2
visk = 1.259e-5
- hlts = 2.8336e6
- hltc = 2.5e6
- hltf = 3.336e5
+ hlts = hlv + hlf
+ hltc = hlv
+ hltf = hlf
- ch2o = 4.1855e3
+ ch2o = c_liq
ri50 = 1.e-4
pisq = pie * pie
@@ -3331,7 +3590,7 @@ subroutine setupm
cgmlt (4) = cgsub (3)
cgmlt (5) = ch2o / hltf
- es0 = 6.107799961e2 ! ~6.1 mb
+ es0 = e00
ces0 = eps * es0
end subroutine setupm
@@ -3340,53 +3599,21 @@ end subroutine setupm
! initialization of gfdl cloud microphysics
! =======================================================================
-!subroutine gfdl_cloud_microphys_init (id, jd, kd, axes, time)
-subroutine gfdl_cloud_microphys_init (me, master, nlunit, input_nml_file, logunit, fn_nml)
+subroutine gfdl_cld_mp_init (input_nml_file, logunit)
implicit none
- integer, intent (in) :: me
- integer, intent (in) :: master
- integer, intent (in) :: nlunit
- integer, intent (in) :: logunit
-
- character (len = 64), intent (in) :: fn_nml
character (len = *), intent (in) :: input_nml_file (:)
+ integer, intent (in) :: logunit
- integer :: ios
logical :: exists
- ! integer, intent (in) :: id, jd, kd
- ! integer, intent (in) :: axes (4)
- ! type (time_type), intent (in) :: time
-
- ! integer :: unit, io, ierr, k, logunit
- ! logical :: flag
- ! real :: tmp, q1, q2
-
- ! master = (mpp_pe () .eq.mpp_root_pe ())
-
-#ifdef INTERNAL_FILE_NML
- read (input_nml_file, nml = gfdl_cloud_microphysics_nml, iostat = ios)
-#else
- inquire (file = trim (fn_nml), exist = exists)
- if (.not. exists) then
- write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist'
- call mpp_error (fatal, 'gfdl - mp :: namelist file: ' // trim (fn_nml) // ' does not exist')
- else
- open (unit = nlunit, file = fn_nml, readonly, status = 'old', iostat = ios)
- endif
- rewind (nlunit)
- read (nlunit, nml = gfdl_cloud_microphysics_nml, iostat = ios)
- close (nlunit)
-#endif
+ read (input_nml_file, nml = gfdl_mp_nml)
! write version number and namelist to log file
- if (me == master) then
- write (logunit, *) " ================================================================== "
- write (logunit, *) "gfdl_cloud_microphys_mod"
- write (logunit, nml = gfdl_cloud_microphysics_nml)
- endif
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "gfdl_mp_mod"
+ write (logunit, nml = gfdl_mp_nml)
if (do_setup) then
call setup_con
@@ -3394,43 +3621,24 @@ subroutine gfdl_cloud_microphys_init (me, master, nlunit, input_nml_file, loguni
do_setup = .false.
endif
+ g2 = 0.5 * grav
log_10 = log (10.)
- tice0 = tice - 0.01
- t_wfr = tice - 40.0 ! supercooled water can exist down to - 48 c, which is the "absolute"
-
- ! if (master) write (logunit, nml = gfdl_cloud_microphys_nml)
-
- ! if (master) write (*, *) 'prec_lin diagnostics initialized.', id_prec
-
- ! call qsmith_init
-
- ! testing the water vapor tables
-
- ! if (mp_debug .and. master) then
- ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys'
- ! tmp = tice - 90.
- ! do k = 1, 25
- ! q1 = wqsat_moist (tmp, 0., 1.e5)
- ! q2 = qs1d_m (tmp, 0., 1.e5)
- ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2
- ! tmp = tmp + 5.
- ! enddo
- ! endif
-
- ! if (master) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.'
-
- ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine)
+ if (do_warm_rain_mp) then
+ t_wfr = t_min
+ else
+ t_wfr = t_ice - 40.0
+ endif
module_is_initialized = .true.
-end subroutine gfdl_cloud_microphys_init
+end subroutine gfdl_cld_mp_init
! =======================================================================
! end of gfdl cloud microphysics
! =======================================================================
-subroutine gfdl_cloud_microphys_end
+subroutine gfdl_cld_mp_end
implicit none
@@ -3445,7 +3653,7 @@ subroutine gfdl_cloud_microphys_end
tables_are_initialized = .false.
-end subroutine gfdl_cloud_microphys_end
+end subroutine gfdl_cld_mp_end
! =======================================================================
! qsmith table initialization
@@ -3457,8 +3665,6 @@ subroutine setup_con
! master = (mpp_pe () .eq.mpp_root_pe ())
- rgrav = 1. / grav
-
if (.not. qsmith_tables_initialized) call qsmith_init
qsmith_tables_initialized = .true.
@@ -3545,17 +3751,6 @@ subroutine qsmith_init
if (.not. tables_are_initialized) then
- ! master = (mpp_pe () .eq. mpp_root_pe ())
- ! if (master) print *, ' gfdl mp: initializing qs tables'
-
- ! debug code
- ! print *, mpp_pe (), allocated (table), allocated (table2), &
- ! allocated (table3), allocated (tablew), allocated (des), &
- ! allocated (des2), allocated (des3), allocated (desw)
- ! end debug code
-
- ! generate es table (dt = 0.1 deg. c)
-
allocate (table (length))
allocate (table2 (length))
allocate (table3 (length))
@@ -3625,11 +3820,8 @@ real function wqs2 (ta, den, dqdt)
! input "den" can be either dry or moist air density
real, intent (in) :: ta, den
-
real, intent (out) :: dqdt
-
real :: es, ap1, tmin
-
integer :: it
tmin = table_ice - 160.
@@ -3647,6 +3839,43 @@ real function wqs2 (ta, den, dqdt)
end function wqs2
+! =======================================================================
+! compute the gradient of saturated specific humidity for table ii
+! it is the same as "wqs2", but written as vector function
+! =======================================================================
+
+subroutine wqs2_vect (is, ie, ta, den, wqsat, dqdt)
+
+ implicit none
+
+ ! pure water phase; universal dry / moist formular using air density
+ ! input "den" can be either dry or moist air density
+
+ integer, intent (in) :: is, ie
+
+ real, intent (in), dimension (is:ie) :: ta, den
+
+ real, intent (out), dimension (is:ie) :: wqsat, dqdt
+
+ real :: es, ap1, tmin
+
+ integer :: i, it
+
+ tmin = t_ice - 160.
+
+ do i = is, ie
+ ap1 = 10. * dim (ta (i), tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = tablew (it) + (ap1 - it) * desw (it)
+ wqsat (i) = es / (rvgas * ta (i) * den (i))
+ it = ap1 - 0.5
+ ! finite diff, del_t = 0.1:
+ dqdt (i) = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta (i) * den (i))
+ enddo
+
+end subroutine wqs2_vect
+
! =======================================================================
! compute wet buld temperature
! =======================================================================
@@ -3710,12 +3939,10 @@ real function iqs2 (ta, den, dqdt)
! water - ice phase; universal dry / moist formular using air density
! input "den" can be either dry or moist air density
- real, intent (in) :: ta, den
-
+ real (kind = r_grid), intent (in) :: ta
+ real, intent (in) :: den
real, intent (out) :: dqdt
-
- real :: es, ap1, tmin
-
+ real (kind = r_grid) :: tmin, es, ap1
integer :: it
tmin = table_ice - 160.
@@ -3997,8 +4224,8 @@ subroutine qs_tablew (n)
integer, intent (in) :: n
- real :: delt = 0.1
- real :: tmin, tem, fac0, fac1, fac2
+ real (kind = r_grid) :: delt = 0.1
+ real (kind = r_grid) :: tmin, tem, fac0, fac1, fac2
integer :: i
@@ -4029,8 +4256,8 @@ subroutine qs_table2 (n)
integer, intent (in) :: n
- real :: delt = 0.1
- real :: tmin, tem0, tem1, fac0, fac1, fac2
+ real (kind = r_grid) :: delt = 0.1
+ real (kind = r_grid) :: tmin, tem0, tem1, fac0, fac1, fac2
integer :: i, i0, i1
@@ -4079,9 +4306,9 @@ subroutine qs_table3 (n)
integer, intent (in) :: n
- real :: delt = 0.1
- real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e
- real :: tem0, tem1
+ real (kind = r_grid) :: delt = 0.1
+ real (kind = r_grid) :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e
+ real (kind = r_grid) :: tem0, tem1
integer :: i, i0, i1
@@ -4099,9 +4326,9 @@ subroutine qs_table3 (n)
! see smithsonian meteorological tables page 350.
! -----------------------------------------------------------------------
aa = - 9.09718 * (table_ice / tem - 1.)
- b = - 3.56654 * alog10 (table_ice / tem)
+ b = - 3.56654 * log10 (table_ice / tem)
c = 0.876793 * (1. - tem / table_ice)
- e = alog10 (esbasi)
+ e = log10 (esbasi)
table3 (i) = 0.1 * 10 ** (aa + b + c + e)
else
! -----------------------------------------------------------------------
@@ -4109,10 +4336,10 @@ subroutine qs_table3 (n)
! see smithsonian meteorological tables page 350.
! -----------------------------------------------------------------------
aa = - 7.90298 * (tbasw / tem - 1.)
- b = 5.02808 * alog10 (tbasw / tem)
+ b = 5.02808 * log10 (tbasw / tem)
c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.)
d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.)
- e = alog10 (esbasw)
+ e = log10 (esbasw)
table3 (i) = 0.1 * 10 ** (aa + b + c + d + e)
endif
enddo
@@ -4165,10 +4392,10 @@ subroutine qs_table (n)
integer, intent (in) :: n
- real :: delt = 0.1
- real :: tmin, tem, esh20
- real :: wice, wh2o, fac0, fac1, fac2
- real :: esupc (200)
+ real (kind = r_grid) :: delt = 0.1
+ real (kind = r_grid) :: tmin, tem, esh20
+ real (kind = r_grid) :: wice, wh2o, fac0, fac1, fac2
+ real (kind = r_grid) :: esupc (200)
integer :: i
@@ -4274,17 +4501,17 @@ end subroutine qsmith
! this is designed for 6 - class micro - physics schemes
! =======================================================================
-subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg)
+subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg, cond)
implicit none
- integer, intent (in) :: ktop, kbot
+ integer, intent (in) :: ks, ke
+ real, intent (in), dimension (ks:ke) :: dp
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: pt
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (out) :: cond
- real, intent (in), dimension (ktop:kbot) :: dp
-
- real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg
-
- real, dimension (ktop:kbot) :: lcpk, icpk
+ real, dimension (ks:ke) :: lcpk, icpk
real :: dq, cvm
@@ -4294,13 +4521,15 @@ subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg)
! define heat capacity and latent heat coefficient
! -----------------------------------------------------------------------
- do k = ktop, kbot
- cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice
- lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm
- icpk (k) = (li00 + dc_ice * pt (k)) / cvm
+ do k = ks, ke
+ cvm = 1. + qv (k) * c1_vap + (qr (k) + ql (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ lcpk (k) = (lv00 + d1_vap * pt (k)) / cvm
+ icpk (k) = (li00 + d1_ice * pt (k)) / cvm
enddo
- do k = ktop, kbot
+ cond = 0
+
+ do k = ks, ke
! -----------------------------------------------------------------------
! ice phase:
@@ -4334,6 +4563,7 @@ subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg)
endif
! if cloud water < 0, borrow from water vapor
if (ql (k) < 0.) then
+ cond = cond - ql (k) * dp (k)
qv (k) = qv (k) + ql (k)
pt (k) = pt (k) - ql (k) * lcpk (k) ! heating
ql (k) = 0.
@@ -4345,7 +4575,7 @@ subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg)
! fix water vapor; borrow from below
! -----------------------------------------------------------------------
- do k = ktop, kbot - 1
+ do k = ks, ke - 1
if (qv (k) < 0.) then
qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1)
qv (k) = 0.
@@ -4356,102 +4586,12 @@ subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg)
! bottom layer; borrow from above
! -----------------------------------------------------------------------
- if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then
- dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1))
- qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1)
- qv (kbot) = qv (kbot) + dq / dp (kbot)
+ if (qv (ke) < 0. .and. qv (ke - 1) > 0.) then
+ dq = min (- qv (ke) * dp (ke), qv (ke - 1) * dp (ke - 1))
+ qv (ke - 1) = qv (ke - 1) - dq / dp (ke - 1)
+ qv (ke) = qv (ke) + dq / dp (ke)
endif
end subroutine neg_adj
-! =======================================================================
-! compute global sum
-! quick local sum algorithm
-! =======================================================================
-
-!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode)
-!
-! use mpp_mod, only: mpp_sum
-!
-! implicit none
-!
-! integer, intent (in) :: ifirst, ilast, jfirst, jlast
-! integer, intent (in) :: mode ! if == 1 divided by area
-!
-! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area
-!
-! integer :: i, j
-!
-! real :: gsum
-!
-! if (global_area < 0.) then
-! global_area = 0.
-! do j = jfirst, jlast
-! do i = ifirst, ilast
-! global_area = global_area + area (i, j)
-! enddo
-! enddo
-! call mpp_sum (global_area)
-! endif
-!
-! gsum = 0.
-! do j = jfirst, jlast
-! do i = ifirst, ilast
-! gsum = gsum + p (i, j) * area (i, j)
-! enddo
-! enddo
-! call mpp_sum (gsum)
-!
-! if (mode == 1) then
-! g_sum = gsum / global_area
-! else
-! g_sum = gsum
-! endif
-!
-!end function g_sum
-
-! =======================================================================
-! interpolate to a prescribed height
-! =======================================================================
-
-subroutine interpolate_z (is, ie, km, zl, hgt, a3, a2)
-
- implicit none
-
- integer, intent (in) :: is, ie, km
-
- real, intent (in), dimension (is:ie, km) :: a3
-
- real, intent (in), dimension (is:ie, km + 1) :: hgt ! hgt (k) > hgt (k + 1)
-
- real, intent (in) :: zl
-
- real, intent (out), dimension (is:ie) :: a2
-
- real, dimension (km) :: zm ! middle layer height
-
- integer :: i, k
-
- !$omp parallel do default (none) shared (is, ie, km, hgt, zl, a2, a3) private (zm)
-
- do i = is, ie
- do k = 1, km
- zm (k) = 0.5 * (hgt (i, k) + hgt (i, k + 1))
- enddo
- if (zl >= zm (1)) then
- a2 (i) = a3 (i, 1)
- elseif (zl <= zm (km)) then
- a2 (i) = a3 (i, km)
- else
- do k = 1, km - 1
- if (zl <= zm (k) .and. zl >= zm (k + 1)) then
- a2 (i) = a3 (i, k) + (a3 (i, k + 1) - a3 (i, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1))
- exit
- endif
- enddo
- endif
- enddo
-
-end subroutine interpolate_z
-
-end module gfdl_cloud_microphys_mod
+end module gfdl_cld_mp_mod
diff --git a/model/gfdl_mp.F90 b/model/gfdl_mp.F90
index 7c22f1321..f9b8b9fd7 100644
--- a/model/gfdl_mp.F90
+++ b/model/gfdl_mp.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -25,133 +25,159 @@
! bears little to no similarity to the original lin mp in zetac.
! therefore, it is best to be called gfdl micro - physics (gfdl mp) .
! developer: shian - jiann lin, linjiong zhou
-! revision: inline gfdl cloud microphysics, 9 / 8 / 2017
! =======================================================================
module gfdl_mp_mod
- ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, &
- ! mpp_clock_begin, mpp_clock_end, clock_routine, &
- ! input_nml_file
- ! use time_manager_mod, only: time_type
- ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8
- ! use fms_mod, only: write_version_number, open_namelist_file, &
- ! check_nml_error, file_exist, close_file
use fv_arrays_mod, only: r_grid
+ use fv_mp_mod, only : is_master
implicit none
private
- public gfdl_mp_driver, gfdl_mp_init, gfdl_mp_end, wqs1, do_hail, wqs2, iqs1, iqs2, qsmith_init, c_liq
+ public gfdl_mp_driver, gfdl_mp_init, gfdl_mp_end
+ public wqs1, wqs2, iqs1, iqs2, mpdrv, sedi_heat, warm_rain, revap_racc, &
+ linear_prof, icloud, subgrid_z_proc, terminal_fall, check_column, implicit_fall, &
+ lagrangian_fall_ppm, cs_profile, cs_limiters, fall_speed, setupm, setup_con, &
+ qsmith_init, qs_tablew, qs_table2, qs_table3, qs_table, neg_adj, acr3d, smlt, gmlt, &
+ wet_bulb, qsmith, qs_blend, es3_table1d, es2_table1d, esw_table1d, es2_table, &
+ esw_table, d_sat, qs1d_m, wqsat_moist, wqsat2_moist, qs1d_moist, revap_rac1, &
+ wqs2_vect, rhow, rhor, rhos, rhog, rhoh, rnzr, rnzs, rnzg, rnzh, rvgas, rdgas, &
+ grav, hlv, hlf, cp_air, cp_vap, cv_air, cv_vap, c_ice, c_liq, dc_vap, dc_ice, &
+ t_ice, t_wfr, e00, pi, zvir, rgrav
real :: missing_value = - 1.e10
logical :: module_is_initialized = .false.
logical :: qsmith_tables_initialized = .false.
- character (len = 17) :: mod_name = 'gfdl_mp'
-
real, parameter :: grav = 9.80665 ! gfs: acceleration due to gravity
real, parameter :: rdgas = 287.05 ! gfs: gas constant for dry air
real, parameter :: rvgas = 461.50 ! gfs: gas constant for water vapor
- real, parameter :: cp_air = 1004.6 ! gfs: heat capacity of dry air at constant pressure
+ real, parameter :: cp_air = 1.0046e3 ! gfs: heat capacity of dry air at constant pressure
real, parameter :: hlv = 2.5e6 ! gfs: latent heat of evaporation
real, parameter :: hlf = 3.3358e5 ! gfs: latent heat of fusion
real, parameter :: pi = 3.1415926535897931 ! gfs: ratio of circle circumference to diameter
+
! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure
real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0, heat capacity of water vapore at constnat pressure
- ! real, parameter :: cv_air = 717.56 ! satoh value
+ ! real, parameter :: cv_air = 717.56 ! satoh value, heat capacity of dry air at constant volume
real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume
- ! real, parameter :: cv_vap = 1410.0 ! emanuel value
+ ! real, parameter :: cv_vap = 1410.0 ! emanuel value, heat capacity of water vapor at constant volume
real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5, heat capacity of water vapor at constant volume
-#ifdef TEST_ICE0
- real, parameter :: c_ice = 1972. ! gfdl: heat capacity of ice at - 15 deg c
- real, parameter :: c_liq = 4.1855e+3 ! gfs: heat capacity of water at 15 c
- ! c_liq - c_ice = 2213
-#else
- real, parameter :: c_ice = 2106. ! heat capacity of ice at 0. deg c
- ! ifs documentation:
- real, parameter :: c_liq = 4218. ! c_liq - c_ice = 2112
- ! emanual's book:
- ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c
-#endif
+ ! http: // www.engineeringtoolbox.com / ice - thermal - properties - d_576.html
+ ! c_ice = 2050.0 at 0 deg c
+ ! c_ice = 2000.0 at - 10 deg c
+ ! c_ice = 1943.0 at - 20 deg c
+ ! c_ice = 1882.0 at - 30 deg c
+ ! c_ice = 1818.0 at - 40 deg c
+
+ ! https: // www.engineeringtoolbox.com / specific - heat - capacity - water - d_660.html
+ ! c_liq = 4219.9 at 0.01 deg c
+ ! c_liq = 4195.5 at 10 deg c
+ ! c_liq = 4184.4 at 20 deg c
+ ! c_liq = 4180.1 at 30 deg c
+ ! c_liq = 4179.6 at 40 deg c
+
+ ! the following two are from emanuel's book "atmospheric convection"
+ ! real, parameter :: c_ice = 2.106e3 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice)
+ ! real, parameter :: c_liq = 4.190e3 ! heat capacity of water at 0 deg c
+ ! real, parameter :: c_ice = 1.972e3 ! gfdl: heat capacity of ice at - 15 deg c
+ ! real, parameter :: c_liq = 4.1855e3 ! gfdl: heat capacity of water at 15 deg c
+ ! real, parameter :: c_ice = 2.106e3 ! gfs: heat capacity of ice at 0 deg c
+ ! real, parameter :: c_liq = 4.1855e3 ! gfs: heat capacity of liquid at 15 deg c
+ real, parameter :: c_ice = 2.106e3 ! ifs: heat capacity of ice at 0 deg c
+ real, parameter :: c_liq = 4.218e3 ! ifs: heat capacity of water at 0 deg c
real, parameter :: eps = rdgas / rvgas ! 0.6219934995
real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077338443
+ real, parameter :: dc_vap = cp_vap - c_liq ! - 2.372e3, isobaric heating / cooling
+ real, parameter :: dc_ice = c_liq - c_ice ! 2.112e3, isobaric heating / colling
+
real, parameter :: t_ice = 273.16 ! freezing temperature
real, parameter :: table_ice = 273.16 ! freezing point for qs table
+ real :: t_wfr ! complete freezing temperature
- ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c
real (kind = r_grid), parameter :: e00 = 611.21 ! ifs: saturation vapor pressure at 0 deg c
-
- real, parameter :: dc_vap = cp_vap - c_liq ! - 2339.5, isobaric heating / cooling
- real, parameter :: dc_ice = c_liq - c_ice ! 2213.5, isobaric heating / colling
+ ! real (kind = r_grid), parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c
real, parameter :: hlv0 = hlv ! gfs: evaporation latent heat coefficient at 0 deg c
- ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2
+ ! real, parameter :: hlv0 = 2.501e6 ! emanuel value
real, parameter :: hlf0 = hlf ! gfs: fussion latent heat coefficient at 0 deg c
- ! real, parameter :: hlf0 = 3.337e5 ! emanuel
+ ! real, parameter :: hlf0 = 3.337e5 ! emanuel value
- real, parameter :: lv0 = hlv0 - dc_vap * t_ice! 3.13905782e6, evaporation latent heat coefficient at 0 deg k
- real, parameter :: li0 = hlf0 - dc_ice * t_ice! - 2.7105966e5, fussion latend heat coefficient at 0 deg k
+ real, parameter :: lv0 = hlv0 - dc_vap * t_ice ! 3.14893552e6, evaporation latent heat coefficient at 0 deg k
+ real, parameter :: li0 = hlf0 - dc_ice * t_ice ! - 2.2691392e5, fussion latend heat coefficient at 0 deg k
- ! real (kind = r_grid), parameter :: d2ice = dc_vap + dc_ice ! - 126, isobaric heating / cooling
- real (kind = r_grid), parameter :: d2ice = cp_vap - c_ice
- ! d2ice = cp_vap - c_ice
- real (kind = r_grid), parameter :: li2 = lv0 + li0 ! 2.86799816e6, sublimation latent heat coefficient at 0 deg k
+ real (kind = r_grid), parameter :: d2ice = cp_vap - c_ice ! - 260.0, isobaric heating / cooling
+ real (kind = r_grid), parameter :: li2 = lv0 + li0 ! 2.9220216e6, sublimation latent heat coefficient at 0 deg k
- real, parameter :: qrmin = 1.e-8 ! min value for ???
+ real, parameter :: qrmin = 1.e-8 ! min value for cloud condensates
real, parameter :: qvmin = 1.e-20 ! min value for water vapor (treated as zero)
real, parameter :: qcmin = 1.e-12 ! min value for cloud condensates
real, parameter :: vr_min = 1.e-3 ! min fall speed for rain
real, parameter :: vf_min = 1.e-5 ! min fall speed for cloud ice, snow, graupel
- real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height
+ real, parameter :: dz_min = 1.e-2 ! used for correcting flipped height
real, parameter :: sfcrho = 1.2 ! surface air density
- ! intercept parameters
+ real, parameter :: rnzr = 8.0e6 ! lin et al. 1983
+ real, parameter :: rnzs = 3.0e6 ! lin et al. 1983
+ real, parameter :: rnzg = 4.0e6 ! rutledge and hobbs 1984
+ ! lmh, 20170929
+ real, parameter :: rnzh = 4.0e4 ! lin et al. 1983
- real, parameter :: rnzr = 8.0e6 ! lin83
- real, parameter :: rnzs = 3.0e6 ! lin83
- real, parameter :: rnzg = 4.0e6 ! rh84
- real, parameter :: rnzh = 4.0e4 ! lin83 --- lmh 29 sep 17
+ real, parameter :: rhow = 1.0e3 ! density of cloud water
+ real, parameter :: rhor = 1.0e3 ! lin et al. 1983
+ real, parameter :: rhos = 0.1e3 ! lin et al. 1983
+ real, parameter :: rhog = 0.4e3 ! rutledge and hobbs 1984
+ ! lmh, 20170929
+ real, parameter :: rhoh = 0.917e3 ! lin et al. 1983
- ! density parameters
-
- real, parameter :: rhor = 1.e3 ! density of rain water, lin83
- real, parameter :: rhos = 0.1e3 ! lin83 (snow density; 1 / 10 of water)
- real, parameter :: rhog = 0.4e3 ! rh84 (graupel density)
- real, parameter :: rhoh = 0.917e3 ! lin83 --- lmh 29 sep 17
+ real, parameter :: rgrav = 1. / grav
real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw ! constants for accretions
real :: acco (3, 4) ! constants for accretions
+ ! constants for sublimation / deposition, freezing / melting, condensation / evaporation
real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5)
real :: es0, ces0
- real :: pie, rgrav, fac_rc
+ real :: pie, fac_rc
real :: c_air, c_vap
real :: lat2, lcp, icp, tcp ! used in bigg mechanism and wet bulk
real :: d0_vap ! the same as dc_vap, except that cp_vap can be cp_vap or cv_vap
real (kind = r_grid) :: lv00, li00, li20
- ! scaled constants:
real (kind = r_grid) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice
real (kind = r_grid), parameter :: one_r8 = 1.
- integer :: ntimes = 1 ! cloud microphysics sub cycles
+ real, allocatable :: table (:), table2 (:), table3 (:), tablew (:)
+ real, allocatable :: des (:), des2 (:), des3 (:), desw (:)
+
+ logical :: tables_are_initialized = .false.
+
+ real, parameter :: dt_fr = 8. ! homogeneous freezing of all cloud water at t_wfr - dt_fr
+ ! minimum temperature water can exist (moore & molinero nov. 2011, nature)
+ ! dt_fr can be considered as the error bar
- ! cloud microphysics switchers
+ real, parameter :: p0_min = 100. ! minimum pressure (pascal) for mp to operate
+ real :: p_min
+
+ ! -----------------------------------------------------------------------
+ ! namelist parameters
+ ! -----------------------------------------------------------------------
+
+ integer :: ntimes = 1 ! cloud microphysics sub cycles
integer :: icloud_f = 0 ! cloud scheme
integer :: irain_f = 0 ! cloud water to rain auto conversion scheme
- logical :: de_ice = .false. ! to prevent excessive build - up of cloud ice from external sources
logical :: sedi_transport = .true. ! transport of momentum in sedimentation
logical :: do_sedi_w = .true. ! transport of vertical momentum during sedimentation
logical :: do_sedi_heat = .true. ! transport of heat in sedimentation
@@ -165,43 +191,18 @@ module gfdl_mp_mod
logical :: disp_heat = .false. ! dissipative heating due to sedimentation
logical :: do_cond_timescale = .false. ! whether to apply a timescale to condensation
- real, allocatable :: table (:), table2 (:), table3 (:), tablew (:)
- real, allocatable :: des (:), des2 (:), des3 (:), desw (:)
-
- logical :: tables_are_initialized = .false.
-
- ! logical :: master
- ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, &
- ! id_ice, id_prec, id_cond, id_var, id_droplets
- ! integer :: gfdl_mp_clock ! clock for timing of driver routine
-
- real, parameter :: dt_fr = 8. ! homogeneous freezing of all cloud water at t_wfr - dt_fr
- ! minimum temperature water can exist (moore & molinero nov. 2011, nature)
- ! dt_fr can be considered as the error bar
-
- real, parameter :: p0_min = 100. ! minimum pressure (pascal) for mp to operate
- real :: p_min
-
- ! -----------------------------------------------------------------------
- ! namelist parameters
- ! -----------------------------------------------------------------------
-
real :: cld_fac = 1.0 ! multiplication factor for cloud fraction
real :: cld_min = 0.05 ! minimum cloud fraction
real :: tice = 273.16 ! set tice = 165. to trun off ice - phase phys (kessler emulator)
+ real :: tice_mlt = 273.16 ! set ice melting temperature to 268.0 based on observation (kay et al., 2016, jc)
- ! real :: t_min = 178. ! min temp to freeze - dry all water vapor
- ! sjl 20181123
- real :: t_min = 170. ! min temp to freeze - dry all water vapor
+ real :: t_min = 178. ! min temp to freeze - dry all water vapor
real :: t_sub = 184. ! min temp for sublimation of cloud ice
-
- ! relative humidity increment
+ real :: mp_time = 150. ! maximum micro - physics time step (sec)
real :: rh_inc = 0.25 ! rh increment for complete evaporation of cloud water and cloud ice
- real :: rh_inr = 0.1 ! rh increment for minimum evaporation of rain (not used---originally for "alternative minimum evaporation")
- real :: rh_ins = 0.1 ! rh increment for sublimation of snow (not used)
-
- ! conversion time scale
+ 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. ! rain freezing during fast_sat
real :: tau_smlt = 900. ! snow melting
@@ -213,18 +214,15 @@ module gfdl_mp_mod
real :: tau_l2v = 300. ! cloud water to water vapor (evaporation)
real :: tau_g2v = 900. ! grapuel sublimation
real :: tau_v2g = 21600. ! grapuel deposition -- make it a slow process
-
- ! horizontal subgrid variability
+ real :: tau_revp = 0. ! rain evaporation
real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land
real :: dw_ocean = 0.10 ! base value for ocean
- ! prescribed ccn
-
real :: ccn_o = 90. ! ccn over ocean (cm^ - 3)
real :: ccn_l = 270. ! ccn over land (cm^ - 3)
- real :: rthresh = 10.0e-6 ! critical cloud drop radius (micro m)
+ real :: rthresh = 10.0e-6 ! critical cloud drop radius (micron)
! -----------------------------------------------------------------------
! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33
@@ -243,17 +241,18 @@ module gfdl_mp_mod
real :: ql_mlt = 2.0e-3 ! max value of cloud water allowed from melted cloud ice
real :: qs_mlt = 1.0e-6 ! max cloud water due to snow melt
- real :: ql_gen = 1.0e-3 ! max cloud water generation during remapping step if fast_sat_adj = .t.
+ real :: ql_gen = 1.0e-3 ! max cloud water generation during remapping step if do_sat_adj = .t.
real :: qi_gen = 1.82e-6 ! max cloud ice generation during remapping step
! cloud condensate upper bounds: "safety valves" for ql & qi
real :: ql0_max = 2.0e-3 ! max cloud water value (auto converted to rain)
- real :: qi0_max = 1.0e-4 ! max cloud ice value (by other sources)
+ real :: qi0_max = 1.0e-4 ! max cloud ice value (by other sources) (not used)
+
real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (was 1.e-4)
! qi0_crt if negative, its magnitude is used as the mixing ration threshold; otherwise, used as density
- real :: qr0_crt = 1.0e-4 ! rain to snow or graupel / hail threshold (not used)
- ! lfo used * mixing ratio * = 1.e-4 (hail in lfo)
+ real :: qr0_crt = 1.0e-4 ! rain to snow or graupel / hail threshold
+ ! lin et al. (1983) used * mixing ratio * = 1.e-4 (hail)
real :: qs0_crt = 1.0e-3 ! snow to graupel density threshold (0.6e-3 in purdue lin scheme)
real :: c_paut = 0.55 ! autoconversion cloud water to rain (use 0.5 to reduce autoconversion)
@@ -264,46 +263,64 @@ module gfdl_mp_mod
! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow)
- real :: alin = 842.0 ! "a" in lin1983
- real :: clin = 4.8 ! "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs)
-
- ! fall velocity tuning constants:
+ real :: alin = 842.0 ! "a" in lin et al. (1983)
+ real :: clin = 4.8 ! "c" in lin et al. (1983), 4.8 -- > 6. (to ehance ql -- > qs)
logical :: const_vi = .false. ! if .t. the constants are specified by v * _fac
logical :: const_vs = .false. ! if .t. the constants are specified by v * _fac
logical :: const_vg = .false. ! if .t. the constants are specified by v * _fac
logical :: const_vr = .false. ! if .t. the constants are specified by v * _fac
- ! good values:
-
- real :: vi_fac = 1. ! if const_vi: 1 / 3
- real :: vs_fac = 1. ! if const_vs: 1.
- real :: vg_fac = 1. ! if const_vg: 2.
- real :: vr_fac = 1. ! if const_vr: 4.
-
- ! upper bounds of fall speed (with variable speed option)
+ real :: vi_fac = 1. ! ifs: if const_vi: 1 / 3
+ real :: vs_fac = 1. ! ifs: if const_vs: 1.
+ real :: vg_fac = 1. ! ifs: if const_vg: 2.
+ real :: vr_fac = 1. ! ifs: if const_vr: 4.
real :: vi_max = 0.5 ! max fall speed for ice
real :: vs_max = 5.0 ! max fall speed for snow
real :: vg_max = 8.0 ! max fall speed for graupel
real :: vr_max = 12. ! max fall speed for rain
- ! cloud microphysics switchers
+ real :: xr_a = 0.25 ! p value in xu and randall, 1996
+ real :: xr_b = 100. ! alpha_0 value in xu and randall, 1996
+ real :: xr_c = 0.49 ! gamma value in xu and randall, 1996
+
+ real :: te_err = 1.e-14 ! 64bit: 1.e-14, 32bit: 1.e-7
- ! this should be removed with the inline code
- logical :: fast_sat_adj = .false. ! has fast saturation adjustments
+ logical :: do_sat_adj = .false. ! has fast saturation adjustments
logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions
logical :: z_slope_ice = .false. ! use linear mono slope for autocconversions
logical :: use_ccn = .false. ! must be true when prog_ccn is false
logical :: use_ppm = .false. ! use ppm fall scheme
logical :: use_ppm_ice = .false. ! use ppm fall scheme for cloud ice
logical :: mono_prof = .true. ! perform terminal fall with mono ppm scheme
- logical :: mp_print = .false. ! cloud microphysics debugging printout
logical :: do_hail = .false. ! use hail parameters instead of graupel
-
- ! real :: global_area = - 1.
-
- real :: g2, log_10, tice0, t_wfr
+ logical :: hd_icefall = .false. ! use heymsfield and donner, 1990's fall speed of cloud ice
+ logical :: use_xr_cloud = .false. ! use xu and randall, 1996's cloud diagnosis
+ logical :: use_park_cloud = .false. ! park et al. 2016
+ logical :: use_gi_cloud = .false. ! gultepe and isaac (2007, grl)
+ logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation
+ logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation
+ logical :: consv_checker = .false. ! turn on energy and water conservation checker
+ logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only
+ ! turn off to save time, turn on only in c48 64bit
+
+ real :: g2, log_10
+
+ real :: rh_thres = 0.75
+ real :: rhc_cevap = 0.85 ! cloud water
+ real :: rhc_revap = 0.85 ! cloud water
+
+ real :: f_dq_p = 1.0
+ real :: f_dq_m = 1.0
+ logical :: do_cld_adj = .false.
+
+ integer :: inflag = 1 ! ice nucleation scheme
+ ! 1: hong et al., 2004
+ ! 2: meyers et al., 1992
+ ! 3: meyers et al., 1992
+ ! 4: cooper, 1986
+ ! 5: flecther, 1962
! -----------------------------------------------------------------------
! namelist
@@ -313,14 +330,33 @@ module gfdl_mp_mod
t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, &
vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, &
vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, &
- qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
+ qi0_crt, do_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
+ const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, &
+ tau_g2v, tau_v2g, sat_adj0, tau_imlt, tau_v2l, tau_l2v, &
+ tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, &
+ z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, &
+ rad_snow, rad_graupel, rad_rain, cld_fac, cld_min, use_ppm, use_ppm_ice, mono_prof, &
+ do_sedi_heat, sedi_transport, do_sedi_w, icloud_f, irain_f, &
+ ntimes, disp_heat, do_hail, use_xr_cloud, xr_a, xr_b, xr_c, tau_revp, tice_mlt, hd_icefall, &
+ do_cond_timescale, mp_time, consv_checker, te_err, use_park_cloud, &
+ use_gi_cloud, use_rhc_cevap, use_rhc_revap, inflag, do_warm_rain_mp, &
+ rh_thres, f_dq_p, f_dq_m, do_cld_adj
+
+ public &
+ t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, &
+ vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, &
+ vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, &
+ qi0_crt, do_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, &
const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, &
tau_g2v, tau_v2g, sat_adj0, tau_imlt, tau_v2l, tau_l2v, &
tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, &
z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, &
rad_snow, rad_graupel, rad_rain, cld_fac, cld_min, use_ppm, use_ppm_ice, mono_prof, &
- do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print, &
- ntimes, disp_heat, do_hail, do_cond_timescale
+ do_sedi_heat, sedi_transport, do_sedi_w, icloud_f, irain_f, &
+ ntimes, disp_heat, do_hail, use_xr_cloud, xr_a, xr_b, xr_c, tau_revp, tice_mlt, hd_icefall, &
+ do_cond_timescale, mp_time, consv_checker, te_err, use_park_cloud, &
+ use_gi_cloud, use_rhc_cevap, use_rhc_revap, inflag, do_warm_rain_mp, &
+ rh_thres, f_dq_p, f_dq_m, do_cld_adj
contains
@@ -328,16 +364,17 @@ module gfdl_mp_mod
! the driver of the gfdl cloud microphysics
! -----------------------------------------------------------------------
-subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qn, &
+subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, &
pt, w, ua, va, dz, delp, gsize, dts, hs, rain, snow, ice, &
- graupel, hydrostatic, phys_hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, &
- te, last_step)
+ graupel, hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, &
+ te, condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
implicit none
- logical, intent (in) :: hydrostatic, phys_hydrostatic
+ logical, intent (in) :: hydrostatic
logical, intent (in) :: last_step
logical, intent (in) :: consv_te
+ logical, intent (in) :: do_inline_mp
integer, intent (in) :: is, ie ! physics window
integer, intent (in) :: ks, ke ! vertical dimension
@@ -347,22 +384,22 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qn, &
real, intent (in), dimension (is:ie) :: hs, gsize
real, intent (in), dimension (is:ie, ks:ke) :: dz
- real, intent (in), dimension (is:ie, ks:ke) :: qn
+ real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
real, intent (inout), dimension (is:ie, ks:ke) :: delp
real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
real, intent (inout), dimension (is:ie, ks:ke) :: pt, ua, va, w
- real, intent (inout), dimension (is:ie, ks:ke) :: q_con, cappa
+ real, intent (inout), dimension (is:, ks:) :: q_con, cappa
real, intent (inout), dimension (is:ie) :: rain, snow, ice, graupel
+ real, intent (inout), dimension (is:ie) :: condensation, deposition
+ real, intent (inout), dimension (is:ie) :: evaporation, sublimation
- real, intent (out), dimension (is:ie, ks:ke) :: te
+ real, intent (inout), dimension (is:ie, ks:ke) :: te
! logical :: used
real, dimension (is:ie) :: w_var
- real, dimension (is:ie, ks:ke) :: vt_r, vt_s, vt_g, vt_i, qn2
+ real, dimension (is:ie, ks:ke) :: vt_r, vt_s, vt_g, vt_i
real, dimension (is:ie, ks:ke) :: m2_rain, m2_sol
- ! call mpp_clock_begin (gfdl_mp_clock)
-
if (last_step) then
p_min = p0_min ! final clean - up
else
@@ -373,10 +410,10 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qn, &
! define heat capacity of dry air and water vapor based on hydrostatical property
! -----------------------------------------------------------------------
- if (hydrostatic .or. phys_hydrostatic) then
+ if (hydrostatic) then
c_air = cp_air
c_vap = cp_vap
- if (hydrostatic) do_sedi_w = .false.
+ do_sedi_w = .false.
else
c_air = cv_air
c_vap = cv_vap
@@ -413,12 +450,10 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qn, &
! -----------------------------------------------------------------------
call mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, qg, &
- qa, qn, dz, is, ie, ks, ke, dts, &
+ qa, qnl, qni, dz, is, ie, ks, ke, dts, &
rain, snow, graupel, ice, m2_rain, m2_sol, gsize, hs, &
- w_var, vt_r, vt_s, vt_g, vt_i, qn2, q_con, cappa, consv_te, te, &
- last_step)
-
- ! call mpp_clock_end (gfdl_mp_clock)
+ w_var, vt_r, vt_s, vt_g, vt_i, q_con, cappa, consv_te, te, &
+ condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
end subroutine gfdl_mp_driver
@@ -438,31 +473,34 @@ end subroutine gfdl_mp_driver
! -----------------------------------------------------------------------
subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
- qg, qa, qn, dz, is, ie, ks, ke, dt_in, &
+ qg, qa, qnl, qni, dz, is, ie, ks, ke, dt_in, &
rain, snow, graupel, ice, m2_rain, m2_sol, gsize, hs, &
- w_var, vt_r, vt_s, vt_g, vt_i, qn2, q_con, cappa, consv_te, te, &
- last_step)
+ w_var, vt_r, vt_s, vt_g, vt_i, q_con, cappa, consv_te, te, &
+ condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
implicit none
logical, intent (in) :: hydrostatic
logical, intent (in) :: last_step
logical, intent (in) :: consv_te
+ logical, intent (in) :: do_inline_mp
integer, intent (in) :: is, ie, ks, ke
real, intent (in) :: dt_in
real, intent (in), dimension (is:ie) :: gsize
real, intent (in), dimension (is:ie) :: hs
real, intent (in), dimension (is:ie, ks:ke) :: dz
- real, intent (in), dimension (is:ie, ks:ke) :: qn
+ real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
real, intent (inout), dimension (is:ie, ks:ke) :: delp
real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
real, intent (inout), dimension (is:ie, ks:ke) :: pt, ua, va, w
- real, intent (inout), dimension (is:ie, ks:ke) :: q_con, cappa
+ real, intent (inout), dimension (is:, ks:) :: q_con, cappa
real, intent (inout), dimension (is:ie) :: rain, snow, ice, graupel
+ real, intent (inout), dimension (is:ie) :: condensation, deposition
+ real, intent (inout), dimension (is:ie) :: evaporation, sublimation
real, intent (out), dimension (is:ie) :: w_var
- real, intent (out), dimension (is:ie, ks:ke) :: vt_r, vt_s, vt_g, vt_i, qn2
+ real, intent (out), dimension (is:ie, ks:ke) :: vt_r, vt_s, vt_g, vt_i
real, intent (out), dimension (is:ie, ks:ke) :: m2_rain, m2_sol
real, intent (out), dimension (is:ie, ks:ke) :: te
! local:
@@ -471,9 +509,15 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
real, dimension (ks:ke) :: vtiz, vtsz, vtgz, vtrz
real, dimension (ks:ke) :: dp1, dz1
real, dimension (ks:ke) :: den, p1, denfac
- real, dimension (ks:ke) :: ccn, c_praut, m1_rain, m1_sol, m1
+ real, dimension (ks:ke) :: ccn, cin, c_praut, m1_rain, m1_sol, m1
real, dimension (ks:ke) :: u0, v0, u1, v1, w1
+ real (kind = r_grid), dimension (is:ie, ks:ke) :: te_beg, te_end, tw_beg, tw_end
+ real (kind = r_grid), dimension (is:ie, ks:ke) :: te_beg_0, te_end_0, tw_beg_0, tw_end_0
+ real (kind = r_grid), dimension (is:ie) :: te_b_beg, te_b_end, tw_b_beg, tw_b_end, dte, te_loss
+ real (kind = r_grid), dimension (is:ie) :: te_b_beg_0, te_b_end_0, tw_b_beg_0, tw_b_end_0
+ real (kind = r_grid), dimension (ks:ke) :: te1, te2
+
real :: cpaut, rh_adj, rh_rain
real :: r1, s1, i1, g1, rdt, ccn0
real :: dt_rain
@@ -481,17 +525,23 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
real (kind = r_grid), dimension (ks:ke) :: dp0, tz, cvm
real (kind = r_grid) :: con_r8, c8
real :: convt
- real :: dts
+ real :: dts, q_cond
+ real :: cond, dep, reevap, sub
integer :: i, k, n
+
+ ntimes = max (ntimes, int (dt_in / min (dt_in, mp_time)))
dts = dt_in / real (ntimes)
dt_rain = dts * 0.5
rdt = one_r8 / dts
+ dte = 0.0
+
! convert to mm / day
convt = 86400. * rdt * rgrav
+ cond = 0.0
! -----------------------------------------------------------------------
! use local variables
@@ -500,11 +550,41 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
do i = is, ie
do k = ks, ke
+ if (do_inline_mp) then
#ifdef MOIST_CAPPA
- tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - (ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k))))
+ tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - (ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k))))
#else
- tz (k) = pt (i, k) / (1. + zvir * qv (i, k))
+ tz (k) = pt (i, k) / (1. + zvir * qv (i, k))
#endif
+ else
+ tz (k) = pt (i, k)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = ql (i, k) + qr (i, k)
+ q_sol (k) = qi (i, k) + qs (i, k) + qg (i, k)
+ cvm (k) = c_air * (1.0 - qv (i, k) - q_liq (k) - q_sol (k)) + &
+ qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_beg_0 (i, k) = cvm (k) * tz (k) + lv00 * c_air * qv (i, k) - li00 * c_air * q_sol (k)
+ if (hydrostatic) then
+ te_beg_0 (i, k) = te_beg_0 (i, k) + 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2)
+ else
+ te_beg_0 (i, k) = te_beg_0 (i, k) + 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 + w (i, k) ** 2)
+ endif
+ te_beg_0 (i, k) = rgrav * te_beg_0 (i, k) * delp (i, k) * gsize (i) ** 2.0
+ tw_beg_0 (i, k) = rgrav * (qv (i, k) + q_liq (k) + q_sol (k)) * delp (i, k) * gsize (i) ** 2.0
+ enddo
+ te_b_beg_0 (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_beg_0 (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
+ endif
+
+ do k = ks, ke
dp0 (k) = delp (i, k)
! -----------------------------------------------------------------------
! convert moist mixing ratios to dry mixing ratios
@@ -518,10 +598,10 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
! save moist ratios for te:
q_liq (k) = qlz (k) + qrz (k)
q_sol (k) = qiz (k) + qsz (k) + qgz (k)
- q_con (i, k) = q_liq (k) + q_sol (k)
+ q_cond = q_liq (k) + q_sol (k)
qaz (k) = 0.
dz1 (k) = dz (i, k)
- con_r8 = one_r8 - (qvz (k) + q_con (i, k))
+ con_r8 = one_r8 - (qvz (k) + q_cond)
! dp1 is dry mass (no change during mp)
dp1 (k) = dp0 (k) * con_r8
con_r8 = one_r8 / con_r8
@@ -542,7 +622,9 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
m1 (k) = 0.
u0 (k) = ua (i, k)
v0 (k) = va (i, k)
- w1 (k) = w (i, k)
+ if (.not. hydrostatic) then
+ w1 (k) = w (i, k)
+ endif
u1 (k) = u0 (k)
v1 (k) = v0 (k)
denfac (k) = sqrt (sfcrho / den (k))
@@ -562,8 +644,9 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
#ifdef MOIST_CAPPA
q_liq (k) = ql (i, k) + qr (i, k)
q_sol (k) = qi (i, k) + qs (i, k) + qg (i, k)
- q_con (i, k) = q_liq (k) + q_sol (k)
- cvm (k) = (one_r8 - (qv (i, k) + q_con (i, k))) * c_air + qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ q_cond = q_liq (k) + q_sol (k)
+ cvm (k) = (one_r8 - (qv (i, k) + q_cond)) * c_air + &
+ qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
te (i, k) = - cvm (k) * tz (k) * delp (i, k)
#else
te (i, k) = - c_air * tz (k) * delp (i, k)
@@ -572,6 +655,28 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
endif
endif
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ cvm (k) = c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_beg (i, k) = cvm (k) * tz (k) + lv00 * c_air * qvz (k) - li00 * c_air * q_sol (k)
+ if (hydrostatic) then
+ te_beg (i, k) = te_beg (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2)
+ else
+ te_beg (i, k) = te_beg (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2 + w1 (k) ** 2)
+ endif
+ te_beg (i, k) = rgrav * te_beg (i, k) * dp1 (k) * gsize (i) ** 2.0
+ tw_beg (i, k) = rgrav * (qvz (k) + q_liq (k) + q_sol (k)) * dp1 (k) * gsize (i) ** 2.0
+ enddo
+ te_b_beg (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_beg (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
+ endif
+
! -----------------------------------------------------------------------
! calculate cloud condensation nuclei (ccn)
! the following is based on klein eq. 15
@@ -581,23 +686,19 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
if (prog_ccn) then
do k = ks, ke
- ! convert # / cc to # / m^3
- ccn (k) = qn (i, k) * 1.e6
+ ! convert # / cm^3 to # / m^3
+ ccn (k) = max (10.0, qnl (i, k)) * 1.e6
+ cin (k) = max (10.0, qni (i, k)) * 1.e6
+ ccn (k) = ccn (k) / den (k)
c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.)
enddo
- use_ccn = .false.
else
- ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6
- if (use_ccn) then
- ! -----------------------------------------------------------------------
- ! ccn is formulted as ccn = ccn_surface * (den / den_surface)
- ! -----------------------------------------------------------------------
- ccn0 = ccn0 * rdgas * tz (ke) / p1 (ke)
- endif
- tmp = cpaut * (ccn0 * rhor) ** (- 1. / 3.)
+ ! convert # / cm^3 to # / m^3
+ ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + &
+ ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6
do k = ks, ke
- c_praut (k) = tmp
- ccn (k) = ccn0
+ ccn (k) = ccn0 / den (k)
+ c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.)
enddo
endif
@@ -619,14 +720,16 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
! -----------------------------------------------------------------------
rh_adj = 1. - h_var - rh_inc
- rh_rain = max (0.6, rh_adj - rh_inr) ! rh_inr = 0.2
+ rh_rain = max (0.35, rh_adj - rh_inr) ! rh_inr = 0.25
! -----------------------------------------------------------------------
! fix all negative water species
! -----------------------------------------------------------------------
if (fix_negative) &
- call neg_adj (ks, ke, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz)
+ call neg_adj (ks, ke, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz, cond)
+
+ condensation (i) = condensation (i) + cond * convt * ntimes
m2_rain (i, :) = 0.
m2_sol (i, :) = 0.
@@ -638,8 +741,9 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
! -----------------------------------------------------------------------
call warm_rain (dt_rain, ks, ke, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, &
- qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var)
+ qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var, reevap, dte (i))
+ evaporation (i) = evaporation (i) + reevap * convt
rain (i) = rain (i) + r1 * convt
do k = ks, ke
@@ -654,28 +758,53 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
call fall_speed (ks, ke, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz)
call terminal_fall (dts, ks, ke, tz, qvz, qlz, qrz, qgz, qsz, qiz, &
- dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1)
+ dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1, dte (i))
rain (i) = rain (i) + r1 * convt ! from melted snow & ice that reached the ground
snow (i) = snow (i) + s1 * convt
graupel (i) = graupel (i) + g1 * convt
ice (i) = ice (i) + i1 * convt
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qvz (k) * c1_vap + (qlz (k) + qrz (k)) * c1_liq + (qiz (k) + qsz (k) + qgz (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp1 (k)
+ enddo
+ endif
+
! -----------------------------------------------------------------------
! heat transportation during sedimentation
! -----------------------------------------------------------------------
- if (do_sedi_heat) &
+ if (do_sedi_heat) then
call sedi_heat (ks, ke, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, &
- qsz, qgz, c_ice)
+ qsz, qgz, c_ice)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qvz (k) * c1_vap + (qlz (k) + qrz (k)) * c1_liq + (qiz (k) + qsz (k) + qgz (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp1 (k)
+ enddo
+ dte (i) = dte (i) + sum (te1) - sum (te2)
+ endif
! -----------------------------------------------------------------------
! time - split warm rain processes: 2nd pass
! -----------------------------------------------------------------------
call warm_rain (dt_rain, ks, ke, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, &
- qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var)
+ qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var, reevap, dte (i))
+ evaporation (i) = evaporation (i) + reevap * convt
rain (i) = rain (i) + r1 * convt
do k = ks, ke
@@ -688,8 +817,14 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
! ice - phase microphysics
! -----------------------------------------------------------------------
- call icloud (ks, ke, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, &
- denfac, vtsz, vtgz, vtrz, qaz, rh_adj, rh_rain, dts, h_var, last_step)
+ call icloud (ks, ke, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, ccn, &
+ cin, denfac, vtsz, vtgz, vtrz, qaz, rh_adj, rh_rain, dts, h_var, gsize (i), &
+ cond, dep, reevap, sub, last_step)
+
+ condensation (i) = condensation (i) + cond * convt
+ deposition (i) = deposition (i) + dep * convt
+ evaporation (i) = evaporation (i) + reevap * convt
+ sublimation (i) = sublimation (i) + sub * convt
enddo
@@ -726,9 +861,9 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
do k = ks, ke
#ifdef MOIST_CAPPA
c8 = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice
- tz (k) = tz (k) + 0.5 * (w (i, k) ** 2 - w1 (k) * w1 (k)) / c8
+ tz (k) = tz (k) + 0.5 * (w (i, k) ** 2 - w1 (k) ** 2) / c8
#else
- tz (k) = tz (k) + 0.5 * (w (i, k) ** 2 - w1 (k) * w1 (k)) / c_air
+ tz (k) = tz (k) + 0.5 * (w (i, k) ** 2 - w1 (k) ** 2) / c_air
#endif
enddo
endif
@@ -738,6 +873,30 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ cvm (k) = c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_end (i, k) = cvm (k) * tz (k) + lv00 * c_air * qvz (k) - li00 * c_air * q_sol (k)
+ if (hydrostatic) then
+ te_end (i, k) = te_end (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2)
+ else
+ te_end (i, k) = te_end (i, k) + 0.5 * (u1 (k) ** 2 + v1 (k) ** 2 + w1 (k) ** 2)
+ endif
+ te_end (i, k) = rgrav * te_end (i, k) * dp1 (k) * gsize (i) ** 2.0
+ tw_end (i, k) = rgrav * (qvz (k) + q_liq (k) + q_sol (k)) * dp1 (k) * gsize (i) ** 2.0
+ enddo
+ te_b_end (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_end (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
+ ! total energy loss due to sedimentation and its heating
+ te_loss (i) = dte (i) * gsize (i) ** 2.0
+ endif
+
! -----------------------------------------------------------------------
! update moist air mass (actually hydrostatic pressure)
! convert to dry mixing ratios
@@ -764,17 +923,43 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
qg (i, k) = qgz (k)
q_liq (k) = qlz (k) + qrz (k)
q_sol (k) = qiz (k) + qsz (k) + qgz (k)
- q_con (i, k) = q_liq (k) + q_sol (k)
- cvm (k) = (one_r8 - (qvz (k) + q_con (i, k))) * c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ q_cond = q_liq (k) + q_sol (k)
+ cvm (k) = (one_r8 - (qvz (k) + q_cond)) * c_air + qvz (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+#ifdef MOIST_CAPPA
+ q_con (i, k) = q_cond
tmp = rdgas * (1. + zvir * qvz (k))
cappa (i, k) = tmp / (tmp + cvm (k))
+#endif
+ if (do_inline_mp) then
#ifdef MOIST_CAPPA
- pt (i, k) = tz (k) * (1. + zvir * qvz (k)) * (1. - q_con (i, k))
+ pt (i, k) = tz (k) * (1. + zvir * qvz (k)) * (1. - q_cond)
#else
- pt (i, k) = tz (k) * (1. + zvir * qvz (k))
+ pt (i, k) = tz (k) * (1. + zvir * qvz (k))
#endif
+ else
+ pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * cvm (k) / cp_air
+ endif
enddo
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ q_liq (k) = ql (i, k) + qr (i, k)
+ q_sol (k) = qi (i, k) + qs (i, k) + qg (i, k)
+ cvm (k) = c_air * (1.0 - qv (i, k) - q_liq (k) - q_sol (k)) + &
+ qv (i, k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ te_end_0 (i, k) = cvm (k) * tz (k) + lv00 * c_air * qv (i, k) - li00 * c_air * q_sol (k)
+ te_end_0 (i, k) = te_end_0 (i, k) + 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 + w (i, k) ** 2)
+ te_end_0 (i, k) = rgrav * te_end_0 (i, k) * delp (i, k) * gsize (i) ** 2.0
+ tw_end_0 (i, k) = rgrav * (qv (i, k) + q_liq (k) + q_sol (k)) * delp (i, k) * gsize (i) ** 2.0
+ enddo
+ te_b_end_0 (i) = (dte (i) - li00 * c_air * (ice (i) + snow (i) + graupel (i)) * dt_in / 86400) * gsize (i) ** 2.0
+ tw_b_end_0 (i) = (rain (i) + ice (i) + snow (i) + graupel (i)) * dt_in / 86400 * gsize (i) ** 2.0
+ endif
+
! -----------------------------------------------------------------------
! fix energy conservation
! -----------------------------------------------------------------------
@@ -805,6 +990,24 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
enddo
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ if (abs (sum (te_end) + sum (te_b_end) - sum (te_beg) - sum (te_b_beg)) / (sum (te_beg) + sum (te_b_beg)) .gt. te_err) then
+ print *, "gfdl_mp te: ", sum (te_beg) / sum (gsize ** 2) + sum (te_b_beg) / sum (gsize ** 2), &
+ sum (te_end) / sum (gsize ** 2) + sum (te_b_end) / sum (gsize ** 2), &
+ (sum (te_end) + sum (te_b_end) - sum (te_beg) - sum (te_b_beg)) / (sum (te_beg) + sum (te_b_beg))
+ endif
+ if (abs (sum (tw_end) + sum (tw_b_end) - sum (tw_beg) - sum (tw_b_beg)) / (sum (tw_beg) + sum (tw_b_beg)) .gt. te_err) then
+ print *, "gfdl_mp tw: ", sum (tw_beg) / sum (gsize ** 2) + sum (tw_b_beg) / sum (gsize ** 2), &
+ sum (tw_end) / sum (gsize ** 2) + sum (tw_b_end) / sum (gsize ** 2), &
+ (sum (tw_end) + sum (tw_b_end) - sum (tw_beg) - sum (tw_b_beg)) / (sum (tw_beg) + sum (tw_b_beg))
+ endif
+ ! print *, "gfdl_mp te loss (%) : ", sum (te_loss) / (sum (te_beg) + sum (te_b_beg)) * 100.0
+ endif
+
end subroutine mpdrv
! -----------------------------------------------------------------------
@@ -847,7 +1050,7 @@ end subroutine sedi_heat
! -----------------------------------------------------------------------
subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
- den, denfac, ccn, c_praut, rh_rain, vtr, r1, m1_rain, w1, h_var)
+ den, denfac, ccn, c_praut, rh_rain, vtr, r1, m1_rain, w1, h_var, reevap, dte)
implicit none
@@ -859,7 +1062,9 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
real, intent (inout), dimension (ks:ke) :: vtr, qv, ql, qr, qi, qs, qg, m1_rain, w1
+ real (kind = r_grid), intent (inout) :: dte
real, intent (out) :: r1
+ real, intent (out) :: reevap
real, parameter :: so3 = 7. / 3.
! fall velocity constants:
real, parameter :: vconr = 2503.23638966667
@@ -867,8 +1072,9 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
real, parameter :: thr = 1.e-8
real, dimension (ks:ke) :: dl, dm
+ real (kind = r_grid), dimension (ks:ke) :: te1, te2
real, dimension (ks:ke + 1) :: ze, zt
- real :: sink, dq, qc0, qc
+ real :: sink, dq, qc
real :: qden
real :: zs = 0.
real :: dt5
@@ -886,6 +1092,8 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
call check_column (ks, ke, qr, no_fall)
+ reevap = 0
+
if (no_fall) then
vtr (:) = vf_min
r1 = 0.
@@ -919,7 +1127,7 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
! evaporation and accretion of rain for the first 1 / 2 time step
! -----------------------------------------------------------------------
- call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var)
+ call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
if (do_sedi_w) then
do k = ks, ke
@@ -927,6 +1135,17 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
! -----------------------------------------------------------------------
! mass flux induced by falling rain
! -----------------------------------------------------------------------
@@ -946,6 +1165,18 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
call implicit_fall (dt, ks, ke, ze, vtr, dp, qr, r1, m1_rain)
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+ endif
+
! -----------------------------------------------------------------------
! vertical velocity transportation during sedimentation
! -----------------------------------------------------------------------
@@ -959,18 +1190,43 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
! -----------------------------------------------------------------------
! heat exchanges during sedimentation
! -----------------------------------------------------------------------
- if (do_sedi_heat) &
+ if (do_sedi_heat) then
call sedi_heat (ks, ke, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+ endif
+
! -----------------------------------------------------------------------
! evaporation and accretion of rain for the remaing 1 / 2 time step
! -----------------------------------------------------------------------
- call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var)
+ call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
endif
@@ -987,16 +1243,8 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
! -----------------------------------------------------------------------
do k = ks, ke
- qc0 = fac_rc * ccn (k)
+ qc = fac_rc * ccn (k)
if (tz (k) > t_wfr) then
- if (use_ccn) then
- ! -----------------------------------------------------------------------
- ! ccn is formulted as ccn = ccn_surface * (den / den_surface)
- ! -----------------------------------------------------------------------
- qc = qc0
- else
- qc = qc0 / den (k)
- endif
dq = ql (k) - qc
if (dq > 0.) then
sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))))
@@ -1015,20 +1263,12 @@ subroutine warm_rain (dt, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var)
do k = ks, ke
- qc0 = fac_rc * ccn (k)
+ qc = fac_rc * ccn (k)
if (tz (k) > t_wfr + dt_fr) then
dl (k) = min (max (1.e-6, dl (k)), 0.5 * ql (k))
! --------------------------------------------------------------------
! as in klein's gfdl am2 stratiform scheme (with subgrid variations)
! --------------------------------------------------------------------
- if (use_ccn) then
- ! --------------------------------------------------------------------
- ! ccn is formulted as ccn = ccn_surface * (den / den_surface)
- ! --------------------------------------------------------------------
- qc = qc0
- else
- qc = qc0 / den (k)
- endif
dq = 0.5 * (ql (k) + dl (k) - qc)
! --------------------------------------------------------------------
! dq = dl if qc == q_minus = ql - dl
@@ -1052,24 +1292,32 @@ end subroutine warm_rain
! evaporation of rain
! -----------------------------------------------------------------------
-subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var)
+subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
implicit none
integer, intent (in) :: ks, ke
real, intent (in) :: dt ! time step (s)
real, intent (in) :: rh_rain, h_var
- real, intent (in), dimension (ks:ke) :: den, denfac
+ real, intent (in), dimension (ks:ke) :: den, denfac, dp
real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg
+ real, intent (out) :: reevap
! local:
real (kind = r_grid), dimension (ks:ke) :: cvm
real, dimension (ks:ke) :: q_liq, q_sol, lcpk
real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink
real :: qpz, dq, dqh, tin
+ real :: fac_revp, rh_tem
integer :: k
+ if (tau_revp .gt. 1.e-6) then
+ fac_revp = 1. - exp (- dt / tau_revp)
+ else
+ fac_revp = 1.
+ endif
+
do k = ks, ke
if (tz (k) > t_wfr .and. qr (k) > qrmin) then
@@ -1084,7 +1332,7 @@ subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_r
cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k)
tin = (tz (k) * cvm (k) - lv00 * ql (k)) / (1. + (qv (k) + ql (k)) * c1_vap + qr (k) * c1_liq + q_sol (k) * c1_ice)
- !
+
qpz = qv (k) + ql (k)
qsat = wqs2 (tin, den (k), dqsdt)
dqh = max (ql (k), h_var * max (qpz, qcmin))
@@ -1102,7 +1350,9 @@ subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_r
! rain evaporation
! -----------------------------------------------------------------------
- if (dqv > 0. .and. qsat > q_minus) then
+ rh_tem = qpz / iqs1 (tin, den (k))
+
+ if (dqv > qvmin .and. qsat > q_minus) then
if (qsat > q_plus) then
dq = qsat - qpz
else
@@ -1114,14 +1364,24 @@ subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_r
endif
qden = qr (k) * den (k)
t2 = tin * tin
- evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * &
- exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k))
- evap = min (qr (k), dt * evap, dqv / (1. + lcpk (k) * dqsdt))
+ if (use_rhc_revap) then
+ evap = 0.0
+ if (rh_tem < rhc_revap) then
+ evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * &
+ exp (0.725 * log (qden)) * sqrt (denfac (k))) / (crevp (4) * t2 + crevp (5) * qsat * den (k))
+ evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt))
+ endif
+ else
+ evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * &
+ exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k))
+ evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt))
+ endif
+ reevap = reevap + evap * dp (k)
+
! -----------------------------------------------------------------------
! alternative minimum evap in dry environmental air
- ! sjl 20180831:
- sink = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqsdt))
- evap = max (evap, sink)
+ ! sink = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqsdt))
+ ! evap = max (evap, sink)
! -----------------------------------------------------------------------
qr (k) = qr (k) - evap
qv (k) = qv (k) + evap
@@ -1134,7 +1394,7 @@ subroutine revap_racc (ks, ke, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_r
! -----------------------------------------------------------------------
! if (qr (k) > qrmin .and. ql (k) > 1.e-7 .and. qsat < q_plus) then
- if (qr (k) > 1.e-6 .and. ql (k) > 2.e-6 .and. qsat < q_minus) then
+ if (qr (k) > qrmin .and. ql (k) > 1.e-6 .and. qsat < q_minus) then
sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k)))
sink = sink / (1. + sink) * ql (k)
ql (k) = ql (k) - sink
@@ -1209,19 +1469,22 @@ end subroutine linear_prof
! author: shian - jiann lin, gfdl
! =======================================================================
-subroutine icloud (ks, ke, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, &
- den, denfac, vts, vtg, vtr, qak, rh_adj, rh_rain, dts, h_var, last_step)
+subroutine icloud (ks, ke, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, den, &
+ ccn, cin, denfac, vts, vtg, vtr, qak, rh_adj, rh_rain, dts, h_var, &
+ gsize, cond, dep, reevap, sub, last_step)
implicit none
logical, intent (in) :: last_step
integer, intent (in) :: ks, ke
- real, intent (in), dimension (ks:ke) :: p1, dp1, den, denfac, vts, vtg, vtr
+ real, intent (in), dimension (ks:ke) :: p1, dp1, den, denfac, vts, vtg, vtr, ccn
real (kind = r_grid), intent (inout), dimension (ks:ke) :: tzk
real, intent (inout), dimension (ks:ke) :: qvk, qlk, qrk, qik, qsk, qgk, qak
- real, intent (in) :: rh_adj, rh_rain, dts, h_var
+ real, intent (inout), dimension (ks:ke) :: cin
+ real, intent (in) :: rh_adj, rh_rain, dts, h_var, gsize
+ real, intent (out) :: cond, dep, reevap, sub
! local:
- real, dimension (ks:ke) :: icpk, di
+ real, dimension (ks:ke) :: icpk, di, qim
real, dimension (ks:ke) :: q_liq, q_sol
real (kind = r_grid), dimension (ks:ke) :: cvm, te8
real (kind = r_grid) :: tz
@@ -1229,7 +1492,7 @@ subroutine icloud (ks, ke, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, &
real :: qv, ql, qr, qi, qs, qg, melt
real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci
real :: pgmlt, psmlt, pgfr, psaut
- real :: tc, dqs0, qden, qim, qsm
+ real :: tc, dqs0, qden, qsm
real :: dt5, factor, sink, qi_crt
real :: tmp, qsw, qsi, dqsdt, dq
real :: dtmp, qc, q_plus, q_minus
@@ -1260,415 +1523,406 @@ subroutine icloud (ks, ke, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, &
enddo
! -----------------------------------------------------------------------
- ! sources of cloud ice: pihom, cold rain, and the sat_adj
- ! (initiation plus deposition)
- ! sources of snow: cold rain, auto conversion + accretion (from cloud ice)
- ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion
+ ! similar to lfo 1983: eq. 21 solved implicitly
+ ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4
! -----------------------------------------------------------------------
do k = ks, ke
- if (tzk (k) > tice .and. qik (k) > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! pimlt: instant melting of cloud ice
- ! -----------------------------------------------------------------------
-
- melt = min (qik (k), fac_imlt * (tzk (k) - tice) / icpk (k))
- tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount
- qlk (k) = qlk (k) + tmp
- qrk (k) = qrk (k) + melt - tmp
- qik (k) = qik (k) - melt
- q_liq (k) = q_liq (k) + melt
- q_sol (k) = q_sol (k) - melt
- elseif (tzk (k) < t_wfr .and. qlk (k) > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! pihom: homogeneous freezing of cloud water into cloud ice
- ! -----------------------------------------------------------------------
-
- dtmp = t_wfr - tzk (k)
- factor = min (1., dtmp / dt_fr)
- sink = min (qlk (k) * factor, dtmp / icpk (k))
- qi_crt = qi_gen * min (qi_lim, 0.1 * (tice - tzk (k))) / den (k)
- tmp = min (sink, dim (qi_crt, qik (k)))
- qlk (k) = qlk (k) - sink
- qsk (k) = qsk (k) + sink - tmp
- qik (k) = qik (k) + tmp
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
+ if (qi0_crt < 0.) then
+ qim (k) = - qi0_crt
+ else
+ qim (k) = qi0_crt / den (k)
endif
enddo
- ! -----------------------------------------------------------------------
- ! vertical subgrid variability
- ! -----------------------------------------------------------------------
-
- call linear_prof (ke - ks + 1, qik (ks), di (ks), z_slope_ice, h_var)
-
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- cvm (k) = one_r8 + qvk (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tzk (k) = (te8 (k) - lv00 * qvk (k) + li00 * q_sol (k)) / cvm (k)
- icpk (k) = (li00 + d1_ice * tzk (k)) / cvm (k)
- enddo
-
- do k = ks, ke
+ if (.not. do_warm_rain_mp) then
! -----------------------------------------------------------------------
- ! do nothing above p_min
+ ! sources of cloud ice: pihom, cold rain, and the sat_adj
+ ! (initiation plus deposition)
+ ! sources of snow: cold rain, auto conversion + accretion (from cloud ice)
+ ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion
! -----------------------------------------------------------------------
- if (p1 (k) < p_min) cycle
-
- tz = tzk (k)
- qv = qvk (k)
- ql = qlk (k)
- qi = qik (k)
- qr = qrk (k)
- qs = qsk (k)
- qg = qgk (k)
-
- pgacr = 0.
- pgacw = 0.
- tc = tz - tice
-
- if (tc .ge. 0.) then
-
- ! -----------------------------------------------------------------------
- ! melting of snow
- ! -----------------------------------------------------------------------
-
- dqs0 = ces0 / p1 (k) - qv ! not sure if this is correct; check again
-
- if (qs > qcmin) then
+ do k = ks, ke
+ if (tzk (k) > tice_mlt .and. qik (k) > qcmin) then
! -----------------------------------------------------------------------
- ! psacw: accretion of cloud water by snow
- ! only rate is used (for snow melt) since tc > 0.
+ ! pimlt: instant melting of cloud ice
! -----------------------------------------------------------------------
- if (ql > qrmin) then
- factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k)))
- psacw = factor / (1. + dts * factor) * ql ! rate
- else
- psacw = 0.
- endif
+ melt = min (qik (k), fac_imlt * (tzk (k) - tice_mlt) / icpk (k))
+ tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount
+ qlk (k) = qlk (k) + tmp
+ qrk (k) = qrk (k) + melt - tmp
+ qik (k) = qik (k) - melt
+ q_liq (k) = q_liq (k) + melt
+ q_sol (k) = q_sol (k) - melt
+ elseif (tzk (k) < t_wfr .and. qlk (k) > qcmin) then
! -----------------------------------------------------------------------
- ! psacr: accretion of rain by melted snow
- ! pracs: accretion of snow by rain
+ ! pihom: homogeneous freezing of cloud water into cloud ice
! -----------------------------------------------------------------------
- if (qr > qrmin) then
- psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), &
- den (k)), qr * rdts)
- pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k))
- else
- psacr = 0.
- pracs = 0.
- endif
-
- ! -----------------------------------------------------------------------
- ! total snow sink:
- ! psmlt: snow melt (due to rain accretion)
- ! -----------------------------------------------------------------------
+ dtmp = t_wfr - tzk (k)
+ factor = min (1., dtmp / dt_fr)
+ sink = min (qlk (k) * factor, dtmp / icpk (k))
+ tmp = min (sink, dim (qim (k), qik (k)))
+ qlk (k) = qlk (k) - sink
+ qsk (k) = qsk (k) + sink - tmp
+ qik (k) = qik (k) + tmp
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ endif
+ enddo
- psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, &
- den (k), denfac (k)))
- sink = min (qs, dts * (psmlt + pracs), tc / icpk (k))
- qs = qs - sink
+ ! -----------------------------------------------------------------------
+ ! vertical subgrid variability
+ ! -----------------------------------------------------------------------
- ! melt all snow if t > 12 c
- if (qs > qcmin .and. tz > tice + 12.) then
- sink = sink + qs
- qs = 0.
- endif
+ call linear_prof (ke - ks + 1, qik (ks), di (ks), z_slope_ice, h_var)
- tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt
- ql = ql + tmp
- qr = qr + sink - tmp
- q_liq (k) = q_liq (k) + sink
- q_sol (k) = q_sol (k) - sink
+ ! -----------------------------------------------------------------------
+ ! update capacity heat and latend heat coefficient
+ ! -----------------------------------------------------------------------
- cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
- tc = tz - tice
- icpk (k) = (li00 + d1_ice * tz) / cvm (k)
+ do k = ks, ke
+ cvm (k) = one_r8 + qvk (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tzk (k) = (te8 (k) - lv00 * qvk (k) + li00 * q_sol (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tzk (k)) / cvm (k)
+ enddo
- endif
+ do k = ks, ke
! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
+ ! do nothing above p_min
! -----------------------------------------------------------------------
+ if (p1 (k) < p_min) cycle
- ! -----------------------------------------------------------------------
- ! melting of graupel
- ! -----------------------------------------------------------------------
+ tz = tzk (k)
+ qv = qvk (k)
+ ql = qlk (k)
+ qi = qik (k)
+ qr = qrk (k)
+ qs = qsk (k)
+ qg = qgk (k)
- if (qg > qcmin .and. tc > 0.) then
-
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
+ pgacr = 0.
+ pgacw = 0.
+ tc = tz - tice
- if (qr > qrmin) &
- pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), rdts * qr)
+ if (tc .ge. 0.) then
! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by graupel
+ ! melting of snow
! -----------------------------------------------------------------------
- qden = qg * den (k)
- if (ql > qrmin) then
- factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
- pgacw = factor / (1. + dts * factor) * ql ! rate
- endif
+ dqs0 = ces0 / p1 (k) - qv ! not sure if this is correct; check again
- ! -----------------------------------------------------------------------
- ! pgmlt: graupel melt
- ! -----------------------------------------------------------------------
+ if (qs > qcmin) then
- pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k))
- pgmlt = min (max (0., pgmlt), qg, tc / icpk (k))
- qg = qg - pgmlt
- qr = qr + pgmlt
- q_liq (k) = q_liq (k) + pgmlt
- q_sol (k) = q_sol (k) - pgmlt
- cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
- endif
+ ! -----------------------------------------------------------------------
+ ! psacw: accretion of cloud water by snow
+ ! only rate is used (for snow melt) since tc > 0.
+ ! -----------------------------------------------------------------------
- else
+ if (ql > qrmin) then
+ factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k)))
+ psacw = factor / (1. + dts * factor) * ql ! rate
+ else
+ psacw = 0.
+ endif
- ! -----------------------------------------------------------------------
- ! cloud ice proc:
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! psacr: accretion of rain by melted snow
+ ! pracs: accretion of snow by rain
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! psaci: accretion of cloud ice by snow
- ! -----------------------------------------------------------------------
+ if (qr > qrmin) then
+ psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), &
+ den (k)), qr * rdts)
+ pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k))
+ else
+ psacr = 0.
+ pracs = 0.
+ endif
- if (qi > 1.e-6) then ! cloud ice sink terms
- if (qs > 1.e-6) then
! -----------------------------------------------------------------------
- ! sjl added (following lin eq. 23) the temperature dependency
- ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004
+ ! total snow sink:
+ ! psmlt: snow melt (due to rain accretion)
! -----------------------------------------------------------------------
- factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k)))
- psaci = factor / (1. + factor) * qi
- else
- psaci = 0.
+
+ psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, &
+ den (k), denfac (k)))
+ sink = min (qs, dts * (psmlt + pracs), tc / icpk (k))
+ qs = qs - sink
+ tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt
+ ql = ql + tmp
+ qr = qr + sink - tmp
+ q_liq (k) = q_liq (k) + sink
+ q_sol (k) = q_sol (k) - sink
+
+ cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
+ tc = tz - tice
+ icpk (k) = (li00 + d1_ice * tz) / cvm (k)
+
endif
! -----------------------------------------------------------------------
- ! pasut: autoconversion: cloud ice -- > snow
+ ! melting of graupel
! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! similar to lfo 1983: eq. 21 solved implicitly
- ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4
- ! -----------------------------------------------------------------------
+ if (qg > qcmin .and. tc > 0.) then
- if (qi0_crt < 0.) then
- qim = - qi0_crt
- else
- qim = qi0_crt / den (k)
- endif
+ ! -----------------------------------------------------------------------
+ ! pgacr: accretion of rain by graupel
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! assuming linear subgrid vertical distribution of cloud ice
- ! the mismatch computation following lin et al. 1994, mwr
- ! -----------------------------------------------------------------------
+ if (qr > qrmin) &
+ pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
+ den (k)), rdts * qr)
- if (const_vi) then
- tmp = fac_i2s
- else
- tmp = fac_i2s * exp (0.025 * tc)
- endif
+ ! -----------------------------------------------------------------------
+ ! pgacw: accretion of cloud water by graupel
+ ! -----------------------------------------------------------------------
- di (k) = max (di (k), qrmin)
- q_plus = qi + di (k)
- if (q_plus > (qim + qrmin)) then
- if (qim > (qi - di (k))) then
- dq = (0.25 * (q_plus - qim) ** 2) / di (k)
- else
- dq = qi - qim
+ qden = qg * den (k)
+ if (ql > qrmin) then
+ factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
+ pgacw = factor / (1. + dts * factor) * ql ! rate
endif
- psaut = tmp * dq
- else
- psaut = 0.
+
+ ! -----------------------------------------------------------------------
+ ! pgmlt: graupel melt
+ ! -----------------------------------------------------------------------
+
+ pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k))
+ pgmlt = min (max (0., pgmlt), qg, tc / icpk (k))
+ qg = qg - pgmlt
+ qr = qr + pgmlt
+ q_liq (k) = q_liq (k) + pgmlt
+ q_sol (k) = q_sol (k) - pgmlt
+ cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
endif
+
+ else
+
! -----------------------------------------------------------------------
- ! sink is no greater than 75% of qi
+ ! cloud ice proc:
! -----------------------------------------------------------------------
- sink = min (0.75 * qi, psaci + psaut)
- qi = qi - sink
- qs = qs + sink
! -----------------------------------------------------------------------
- ! pgaci: accretion of cloud ice by graupel
+ ! psaci: accretion of cloud ice by snow
! -----------------------------------------------------------------------
- if (qg > 3.e-6) then
+ if (qi > 3.e-7) then ! cloud ice sink terms
+
+ if (qs > 1.e-7) then
+ ! -----------------------------------------------------------------------
+ ! sjl added (following lin eq. 23) the temperature dependency
+ ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004
+ ! -----------------------------------------------------------------------
+ factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k)))
+ psaci = factor / (1. + factor) * qi
+ else
+ psaci = 0.
+ endif
+
! -----------------------------------------------------------------------
- ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k)))
- ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1
+ ! assuming linear subgrid vertical distribution of cloud ice
+ ! the mismatch computation following lin et al. 1994, mwr
! -----------------------------------------------------------------------
- factor = dts * cgaci * sqrt (den (k)) * qg
- pgaci = factor / (1. + factor) * qi
- qi = qi - pgaci
- qg = qg + pgaci
- endif
- endif
+ if (const_vi) then
+ tmp = fac_i2s
+ else
+ tmp = fac_i2s * exp (0.025 * tc)
+ endif
- ! -----------------------------------------------------------------------
- ! cold - rain proc:
- ! -----------------------------------------------------------------------
+ di (k) = max (di (k), qrmin)
+ q_plus = qi + di (k)
+ if (q_plus > (qim (k) + qrmin)) then
+ if (qim (k) > (qi - di (k))) then
+ dq = (0.25 * (q_plus - qim (k)) ** 2) / di (k)
+ else
+ dq = qi - qim (k)
+ endif
+ psaut = tmp * dq
+ else
+ psaut = 0.
+ endif
+ ! -----------------------------------------------------------------------
+ ! sink is no greater than 75% of qi
+ ! -----------------------------------------------------------------------
+ sink = min (0.75 * qi, psaci + psaut)
+ qi = qi - sink
+ qs = qs + sink
- ! -----------------------------------------------------------------------
- ! rain to ice, snow, graupel processes:
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! pgaci: accretion of cloud ice by graupel
+ ! -----------------------------------------------------------------------
- tc = tz - tice
+ if (qg > 1.e-6) then
+ ! -----------------------------------------------------------------------
+ ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k)))
+ ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1
+ ! -----------------------------------------------------------------------
+ factor = dts * cgaci / sqrt (den (k)) * exp (0.875 * log (qg * den (k)))
+ pgaci = factor / (1. + factor) * qi
+ qi = qi - pgaci
+ qg = qg + pgaci
+ endif
- if (qr > 1.e-6 .and. tc < 0.) then
+ endif
! -----------------------------------------------------------------------
- ! * sink * terms to qr: psacr + pgfr
- ! source terms to qs: psacr
- ! source terms to qg: pgfr
+ ! cold - rain proc:
! -----------------------------------------------------------------------
! -----------------------------------------------------------------------
- ! psacr accretion of rain by snow
+ ! rain to ice, snow, graupel processes:
! -----------------------------------------------------------------------
- if (qs > 1.e-6) then ! if snow exists
- psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k))
- else
- psacr = 0.
- endif
+ tc = tz - tice
- ! -----------------------------------------------------------------------
- ! pgfr: rain freezing -- > graupel
- ! -----------------------------------------------------------------------
+ if (qr > 1.e-7 .and. tc < 0.) then
- pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
- exp (1.75 * log (qr * den (k)))
+ ! -----------------------------------------------------------------------
+ ! * sink * terms to qr: psacr + pgfr
+ ! source terms to qs: psacr
+ ! source terms to qg: pgfr
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! total sink to qr
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! psacr accretion of rain by snow
+ ! -----------------------------------------------------------------------
- sink = psacr + pgfr
- factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin)
+ if (qs > 1.e-7) then ! if snow exists
+ psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k))
+ else
+ psacr = 0.
+ endif
- psacr = factor * psacr
- pgfr = factor * pgfr
+ ! -----------------------------------------------------------------------
+ ! pgfr: rain freezing -- > graupel
+ ! -----------------------------------------------------------------------
- sink = psacr + pgfr
- qr = qr - sink
- qs = qs + psacr
- qg = qg + pgfr
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
+ pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
+ exp (1.75 * log (qr * den (k)))
- cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
- icpk (k) = (li00 + d1_ice * tz) / cvm (k)
- endif
+ ! -----------------------------------------------------------------------
+ ! total sink to qr
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! graupel production terms:
- ! -----------------------------------------------------------------------
+ sink = psacr + pgfr
+ factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin)
- if (qs > 3.e-6) then
+ psacr = factor * psacr
+ pgfr = factor * pgfr
- ! -----------------------------------------------------------------------
- ! accretion: snow -- > graupel
- ! -----------------------------------------------------------------------
+ sink = psacr + pgfr
+ qr = qr - sink
+ qs = qs + psacr
+ qg = qg + pgfr
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
- if (qg > qrmin) then
- sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k))
- else
- sink = 0.
+ cvm (k) = one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz) / cvm (k)
endif
! -----------------------------------------------------------------------
- ! autoconversion snow -- > graupel
+ ! graupel production terms:
! -----------------------------------------------------------------------
- qsm = qs0_crt / den (k)
- if (qs > qsm) then
- factor = dts * 1.e-3 * exp (0.09 * (tz - tice))
- sink = sink + factor / (1. + factor) * (qs - qsm)
- endif
- sink = min (qs, sink)
- qs = qs - sink
- qg = qg + sink
+ if (qs > 1.e-7) then
- endif ! snow existed
+ ! -----------------------------------------------------------------------
+ ! accretion: snow -- > graupel
+ ! -----------------------------------------------------------------------
- if (qg > 1.e-6 .and. tz < tice0) then
+ if (qg > qrmin) then
+ sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k))
+ else
+ sink = 0.
+ endif
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by graupel
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! autoconversion snow -- > graupel
+ ! -----------------------------------------------------------------------
- if (ql > 1.e-6) then
- qden = qg * den (k)
- factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
- pgacw = factor / (1. + factor) * ql
- else
- pgacw = 0.
- endif
+ qsm = qs0_crt / den (k)
+ if (qs > qsm) then
+ factor = dts * 1.e-3 * exp (0.09 * (tz - tice))
+ sink = sink + factor / (1. + factor) * (qs - qsm)
+ endif
+ sink = min (qs, sink)
+ qs = qs - sink
+ qg = qg + sink
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
+ endif ! snow existed
- if (qr > 1.e-6) then
- pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), qr)
- else
- pgacr = 0.
- endif
+ if (qg > 1.e-7 .and. tz < tice) then
+
+ ! -----------------------------------------------------------------------
+ ! pgacw: accretion of cloud water by graupel
+ ! -----------------------------------------------------------------------
- sink = pgacr + pgacw
- factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qrmin)
- pgacr = factor * pgacr
- pgacw = factor * pgacw
+ if (ql > 1.e-6) then
+ qden = qg * den (k)
+ factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
+ pgacw = factor / (1. + factor) * ql
+ else
+ pgacw = 0.
+ endif
- sink = pgacr + pgacw
- qg = qg + sink
- qr = qr - pgacr
- ql = ql - pgacw
+ ! -----------------------------------------------------------------------
+ ! pgacr: accretion of rain by graupel
+ ! -----------------------------------------------------------------------
+
+ if (qr > 1.e-6) then
+ pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
+ den (k)), qr)
+ else
+ pgacr = 0.
+ endif
+
+ sink = pgacr + pgacw
+ factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qrmin)
+ pgacr = factor * pgacr
+ pgacw = factor * pgacw
+
+ sink = pgacr + pgacw
+ qg = qg + sink
+ qr = qr - pgacr
+ ql = ql - pgacw
+
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / (one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
+ endif
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- tz = (te8 (k) - lv00 * qv + li00 * q_sol (k)) / (one_r8 + qv * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
endif
- endif
+ tzk (k) = tz
+ qvk (k) = qv
+ qlk (k) = ql
+ qik (k) = qi
+ qrk (k) = qr
+ qsk (k) = qs
+ qgk (k) = qg
- tzk (k) = tz
- qvk (k) = qv
- qlk (k) = ql
- qik (k) = qi
- qrk (k) = qr
- qsk (k) = qs
- qgk (k) = qg
+ enddo
- enddo
+ endif
- call subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tzk, qvk, &
- qlk, qrk, qik, qsk, qgk, qak, h_var, rh_rain, te8, last_step)
+ call subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tzk, qvk, qlk, &
+ qrk, qik, qsk, qgk, qak, dp1, h_var, rh_rain, te8, ccn, cin, gsize, &
+ cond, dep, reevap, sub, last_step)
end subroutine icloud
@@ -1676,41 +1930,50 @@ end subroutine icloud
! temperature sentive high vertical resolution processes
! =======================================================================
-subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
- ql, qr, qi, qs, qg, qa, h_var, rh_rain, te8, last_step)
+subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, ql, qr, &
+ qi, qs, qg, qa, dp1, h_var, rh_rain, te8, ccn, cin, gsize, cond, dep, reevap, sub, last_step)
implicit none
integer, intent (in) :: ks, ke
- real, intent (in) :: dts, rh_adj, h_var, rh_rain
- real, intent (in), dimension (ks:ke) :: p1, den, denfac
+ real, intent (in) :: dts, rh_adj, h_var, rh_rain, gsize
+ real, intent (in), dimension (ks:ke) :: p1, den, denfac, ccn, dp1
real (kind = r_grid), intent (in), dimension (ks:ke) :: te8
real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+ real, intent (inout), dimension (ks:ke) :: cin
logical, intent (in) :: last_step
+ real, intent (out) :: cond, dep, reevap, sub
! local:
real, dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
real, dimension (ks:ke) :: q_liq, q_sol, q_cond
real (kind = r_grid), dimension (ks:ke) :: cvm
real :: pidep, qi_crt
+ real :: sigma, gam
! -----------------------------------------------------------------------
! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty
! must not be too large to allow psc
! -----------------------------------------------------------------------
- real :: rh, rqi, tin, qsw, qsi, qpz, qstar
+ real :: rh, rqi, tin, qsw, qsi, qpz, qstar, rh_tem
real :: dqsdt, dwsdt, dq, dq0, factor, tmp, liq, ice
- real :: q_plus, q_minus
- real :: evap, sink, tc, dtmp
+ real :: q_plus, q_minus, dt_evap, dt_pisub
+ real :: evap, sink, tc, dtmp, qa10, qa100
real :: pssub, pgsub, tsq, qden
real :: fac_l2v, fac_v2l, fac_g2v, fac_v2g
integer :: k
+ if (do_sat_adj) then
+ dt_evap = 0.5 * dts
+ else
+ dt_evap = dts
+ endif
+
! -----------------------------------------------------------------------
! define conversion scalar / factor
! -----------------------------------------------------------------------
- fac_l2v = 1. - exp (- dts / tau_l2v)
- fac_v2l = 1. - exp (- dts / tau_v2l)
+ fac_l2v = 1. - exp (- dt_evap / tau_l2v)
+ fac_v2l = 1. - exp (- dt_evap / tau_v2l)
fac_g2v = 1. - exp (- dts / tau_g2v)
fac_v2g = 1. - exp (- dts / tau_v2g)
@@ -1727,40 +1990,53 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr))
enddo
+ cond = 0
+ dep = 0
+ reevap = 0
+ sub = 0
+
do k = ks, ke
if (p1 (k) < p_min) cycle
- ! -----------------------------------------------------------------------
- ! instant deposit all water vapor to cloud ice when temperature is super low
- ! -----------------------------------------------------------------------
+ if (.not. do_warm_rain_mp) then
- if (tz (k) < t_min) then
- sink = dim (qv (k), 1.e-7)
- qv (k) = qv (k) - sink
- qi (k) = qi (k) + sink
- q_sol (k) = q_sol (k) + sink
- tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / (one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
- if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover
- cycle
- endif
+ ! -----------------------------------------------------------------------
+ ! instant deposit all water vapor to cloud ice when temperature is super low
+ ! -----------------------------------------------------------------------
- ! -----------------------------------------------------------------------
- ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free
- ! -----------------------------------------------------------------------
- ! rain water is handled in warm - rain process.
- qpz = qv (k) + ql (k) + qi (k) + qs (k)
- tin = (te8 (k) - lv00 * qpz + li00 * qg (k)) / (one_r8 + qpz * c1_vap + qr (k) * c1_liq + qg (k) * c1_ice)
- if (tin > t_sub + 6.) then
- rh = qpz / iqs1 (tin, den (k))
- if (rh < rh_adj) then ! qpz / rh_adj < qs
- tz (k) = tin
- qv (k) = qpz
- ql (k) = 0.
- qi (k) = 0.
- qs (k) = 0.
- cycle ! cloud free
+ if (tz (k) < t_min) then
+ sink = dim (qv (k), 1.e-7)
+ dep = dep + sink * dp1 (k)
+ qv (k) = qv (k) - sink
+ qi (k) = qi (k) + sink
+ q_sol (k) = q_sol (k) + sink
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / &
+ (one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice)
+ if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover
+ cycle
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free
+ ! -----------------------------------------------------------------------
+ ! rain water is handled in warm - rain process.
+ qpz = qv (k) + ql (k) + qi (k)
+ tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / &
+ (one_r8 + qpz * c1_vap + qr (k) * c1_liq + (qs (k) + qg (k)) * c1_ice)
+ if (tin > t_sub + 6.) then
+ rh = qpz / iqs1 (tin, den (k))
+ if (rh < rh_adj) then ! qpz / rh_adj < qs
+ reevap = reevap + ql (k) * dp1 (k)
+ sub = sub + qi (k) * dp1 (k)
+ tz (k) = tin
+ qv (k) = qpz
+ ql (k) = 0.
+ qi (k) = 0.
+ cycle ! cloud free
+ endif
endif
+
endif
! -----------------------------------------------------------------------
@@ -1768,16 +2044,38 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
! -----------------------------------------------------------------------
tin = tz (k)
+ rh_tem = qpz / iqs1 (tin, den (k))
qsw = wqs2 (tin, den (k), dwsdt)
dq0 = qsw - qv (k)
- if (dq0 > 0.) then ! evaporation
- factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90%
- evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt))
- elseif (do_cond_timescale) then
- factor = min ( 1., fac_v2l * ( 10. * (-dq0) / qsw ))
- evap = - min ( qv (k), factor * -dq0 / (1. + tcp3 (k) * dwsdt))
- else ! condensate all excess vapor into cloud water
- evap = dq0 / (1. + tcp3 (k) * dwsdt)
+ if (use_rhc_cevap) then
+ evap = 0.
+ if (rh_tem .lt. rhc_cevap) then
+ if (dq0 > 0.) then ! evaporation
+ factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90%
+ evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt))
+ reevap = reevap + evap * dp1 (k)
+ elseif (do_cond_timescale) then
+ factor = min (1., fac_v2l * (10. * (- dq0) / qsw))
+ evap = - min (qv (k), factor * (- dq0) / (1. + tcp3 (k) * dwsdt))
+ cond = cond - evap * dp1 (k)
+ else ! condensate all excess vapor into cloud water
+ evap = dq0 / (1. + tcp3 (k) * dwsdt)
+ cond = cond - evap * dp1 (k)
+ endif
+ endif
+ else
+ if (dq0 > 0.) then ! evaporation
+ factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90%
+ evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt))
+ reevap = reevap + evap * dp1 (k)
+ elseif (do_cond_timescale) then
+ factor = min (1., fac_v2l * (10. * (- dq0) / qsw))
+ evap = - min (qv (k), factor * (- dq0) / (1. + tcp3 (k) * dwsdt))
+ cond = cond - evap * dp1 (k)
+ else ! condensate all excess vapor into cloud water
+ evap = dq0 / (1. + tcp3 (k) * dwsdt)
+ cond = cond - evap * dp1 (k)
+ endif
endif
! sjl on jan 23 2018: reversible evap / condensation:
qv (k) = qv (k) + evap
@@ -1793,153 +2091,174 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
- ! -----------------------------------------------------------------------
- ! enforce complete freezing below - 48 c
- ! -----------------------------------------------------------------------
-
- dtmp = t_wfr - tz (k) ! [ - 40, - 48]
- if (dtmp > 0. .and. ql (k) > qcmin) then
- sink = min (ql (k), ql (k) * dtmp * 0.125, dtmp / icpk (k))
- ql (k) = ql (k) - sink
- qi (k) = qi (k) + sink
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
- icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
- endif
-
- ! -----------------------------------------------------------------------
- ! bigg mechanism
- ! -----------------------------------------------------------------------
-
- tc = tice - tz (k)
- if (ql (k) > qrmin .and. tc > 0.1) then
- sink = 3.3333e-10 * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k)
- sink = min (ql (k), tc / icpk (k), sink)
- ql (k) = ql (k) - sink
- qi (k) = qi (k) + sink
- q_liq (k) = q_liq (k) - sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
- endif ! significant ql existed
+ if (.not. do_warm_rain_mp) then
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! enforce complete freezing below - 48 c
+ ! -----------------------------------------------------------------------
- tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
+ dtmp = t_wfr - tz (k) ! [ - 40, - 48]
+ if (dtmp > 0. .and. ql (k) > qcmin) then
+ sink = min (ql (k), ql (k) * dtmp * 0.125, dtmp / icpk (k))
+ ql (k) = ql (k) - sink
+ qi (k) = qi (k) + sink
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
+ endif
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of ice
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! bigg mechanism
+ ! -----------------------------------------------------------------------
- if (tz (k) < tice) then
- qsi = iqs2 (tz (k), den (k), dqsdt)
- dq = qv (k) - qsi
- sink = dq / (1. + tcpk (k) * dqsdt)
- if (qi (k) > qrmin) then
- ! eq 9, hong et al. 2004, mwr
- ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8)
- pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) &
- / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4)
+ if (do_sat_adj) then
+ dt_pisub = 0.5 * dts
else
- pidep = 0.
- endif
- if (dq > 0.) then ! vapor - > ice
- tmp = tice - tz (k)
- ! 20160912: the following should produce more ice at higher altitude
- ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (k)
- qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (k)
- sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k))
- else ! ice -- > vapor
- pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2)
- sink = max (pidep, sink, - qi (k))
+ dt_pisub = dts
+ tc = tice - tz (k)
+ if (ql (k) > qrmin .and. tc > 0.1) then
+ sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2
+ sink = min (ql (k), tc / icpk (k), sink)
+ ql (k) = ql (k) - sink
+ qi (k) = qi (k) + sink
+ q_liq (k) = q_liq (k) - sink
+ q_sol (k) = q_sol (k) + sink
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ endif ! significant ql existed
endif
- qv (k) = qv (k) - sink
- qi (k) = qi (k) + sink
- q_sol (k) = q_sol (k) + sink
- cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
- endif
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! update capacity heat and latend heat coefficient
+ ! -----------------------------------------------------------------------
- tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of snow
- ! this process happens for all temp rage
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! sublimation / deposition of ice
+ ! -----------------------------------------------------------------------
- if (qs (k) > qrmin) then
- qsi = iqs2 (tz (k), den (k), dqsdt)
- qden = qs (k) * den (k)
- tmp = exp (0.65625 * log (qden))
- tsq = tz (k) * tz (k)
- dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt)
- pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * &
- sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k))
- pssub = (qsi - qv (k)) * dts * pssub
- if (pssub > 0.) then ! qs -- > qv, sublimation
- pssub = min (pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k))
- else
- if (tz (k) > tice) then
- pssub = 0. ! no deposition
+ if (tz (k) < tice) then
+ qsi = iqs2 (tz (k), den (k), dqsdt)
+ dq = qv (k) - qsi
+ sink = dq / (1. + tcpk (k) * dqsdt)
+ if (qi (k) > qrmin) then
+ if (.not. prog_ccn) then
+ if (inflag .eq. 1) &
+ ! hong et al., 2004
+ cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k)))
+ if (inflag .eq. 2) &
+ ! meyers et al., 1992
+ cin (k) = exp (-2.80 + 0.262 * (tice - tz (k))) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 3) &
+ ! meyers et al., 1992
+ cin (k) = exp (-0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 4) &
+ ! cooper, 1986
+ cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0 ! convert from L^-1 to m^-3
+ if (inflag .eq. 5) &
+ ! flecther, 1962
+ cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.0 ! convert from L^-1 to m^-3
+ endif
+ pidep = dt_pisub * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) &
+ / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4)
else
- pssub = max (pssub, dq, (tz (k) - tice) / tcpk (k))
+ pidep = 0.
endif
+ if (dq > 0.) then ! vapor - > ice
+ tmp = tice - tz (k)
+ ! 20160912: the following should produce more ice at higher altitude
+ ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (k)
+ qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (k)
+ sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k))
+ dep = dep + sink * dp1 (k)
+ else ! ice -- > vapor
+ pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2)
+ sink = max (pidep, sink, - qi (k))
+ sub = sub - sink * dp1 (k)
+ endif
+ qv (k) = qv (k) - sink
+ qi (k) = qi (k) + sink
+ q_sol (k) = q_sol (k) + sink
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
endif
- ! *******************************
- ! evap all snow if tz (k) > 12. c
- !s ******************************
- if (tz (k) > tice + 12.) then
- tmp = qs (k) - pssub
- if (tmp > 0.) pssub = pssub + tmp
- endif
+ ! -----------------------------------------------------------------------
+ ! update capacity heat and latend heat coefficient
+ ! -----------------------------------------------------------------------
- qs (k) = qs (k) - pssub
- qv (k) = qv (k) + pssub
- q_sol (k) = q_sol (k) - pssub
- cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
- endif
- ! -----------------------------------------------------------------------
- ! simplified 2 - way grapuel sublimation - deposition mechanism
- ! -----------------------------------------------------------------------
- if (qg (k) > qrmin) then
- qsi = iqs2 (tz (k), den (k), dqsdt)
- dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt)
- pgsub = (qv (k) / qsi - 1.) * qg (k)
- if (pgsub > 0.) then ! deposition
- if (tz (k) > tice .or. qg (k) < 1.e-6) then
- pgsub = 0. ! no deposition
+ ! -----------------------------------------------------------------------
+ ! sublimation / deposition of snow
+ ! this process happens for all temp rage
+ ! -----------------------------------------------------------------------
+
+ if (qs (k) > qrmin) then
+ qsi = iqs2 (tz (k), den (k), dqsdt)
+ qden = qs (k) * den (k)
+ tmp = exp (0.65625 * log (qden))
+ tsq = tz (k) * tz (k)
+ dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt)
+ pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * &
+ sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k))
+ pssub = (qsi - qv (k)) * dts * pssub
+ if (pssub > 0.) then ! qs -- > qv, sublimation
+ pssub = min (pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k))
+ sub = sub + pssub * dp1 (k)
else
- pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), &
- (tice - tz (k)) / tcpk (k))
+ if (tz (k) > tice) then
+ pssub = 0. ! no deposition
+ else
+ pssub = max (pssub, dq, (tz (k) - tice) / tcpk (k))
+ endif
+ dep = dep - pssub * dp1 (k)
endif
- else ! submilation
- pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1)
+ qs (k) = qs (k) - pssub
+ qv (k) = qv (k) + pssub
+ q_sol (k) = q_sol (k) - pssub
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
endif
- qg (k) = qg (k) + pgsub
- qv (k) = qv (k) - pgsub
- q_sol (k) = q_sol (k) + pgsub
- cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
- tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
- endif
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
+ ! -----------------------------------------------------------------------
+ ! sublimation / deposition of graupel
+ ! this process happens for all temp rage
+ ! -----------------------------------------------------------------------
+
+ if (qg (k) > qrmin) then
+ qsi = iqs2 (tz (k), den (k), dqsdt)
+ qden = qg (k) * den (k)
+ tmp = exp (0.6875 * log (qden))
+ tsq = tz (k) * tz (k)
+ dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt)
+ pgsub = cgsub (1) * tsq * (cgsub (2) * sqrt (qden) + cgsub (3) * tmp / &
+ sqrt (sqrt (den (k)))) / (cgsub (4) * tsq + cgsub (5) * qsi * den (k))
+ pgsub = (qsi - qv (k)) * dts * pgsub
+ if (pgsub > 0.) then ! qs -- > qv, sublimation
+ pgsub = min (pgsub * min (1., dim (tz (k), t_sub) * 0.2), qg (k))
+ sub = sub + pgsub * dp1 (k)
+ else
+ if (tz (k) > tice) then
+ pgsub = 0. ! no deposition
+ else
+ pgsub = max (pgsub, dq, (tz (k) - tice) / tcpk (k))
+ endif
+ dep = dep - pgsub * dp1 (k)
+ endif
+ qg (k) = qg (k) - pgsub
+ qv (k) = qv (k) + pgsub
+ q_sol (k) = q_sol (k) - pgsub
+ cvm (k) = one_r8 + qv (k) * c1_vap + q_liq (k) * c1_liq + q_sol (k) * c1_ice
+ tz (k) = (te8 (k) - lv00 * qv (k) + li00 * q_sol (k)) / cvm (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
+ endif
- ! lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k)
- ! icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
+ endif
! -----------------------------------------------------------------------
! compute cloud fraction
@@ -2010,7 +2329,6 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
! binary cloud scheme
! -----------------------------------------------------------------------
-
! -----------------------------------------------------------------------
! partial cloudiness by pdf:
! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the
@@ -2024,42 +2342,104 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
! icloud_f = 0: bug - fixed
! icloud_f = 1: old fvgfs gfdl) mp implementation
! icloud_f = 2: binary cloud scheme (0 / 1)
+ ! icloud_f = 3: revision of icloud = 0
! -----------------------------------------------------------------------
- if (rh > 0.80 .and. qpz > 1.e-6) then
-
- dq = h_var * qpz
- q_plus = qpz + dq
- q_minus = qpz - dq
+ if (use_xr_cloud) then ! xu and randall cloud scheme (1996)
+ if (rh >= 1.0) then
+ qa (k) = 1.0
+ elseif (rh > rh_thres .and. q_cond (k) > 1.e-6) then
+ qa (k) = rh ** xr_a * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / &
+ max (1.e-5, (max (1.e-10, 1.0 - rh) * qstar) ** xr_c)))
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ qa (k) = 0.0
+ endif
+ elseif (use_park_cloud) then ! park et al. 2016 (mon. wea. review)
+ if (q_cond (k) > 1.e-6) then
+ qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * max (0.0, q_cond (k) * 1000.) ** 1.07 + &
+ 4.82 * (gsize / 1000. - 50.) * max (0.0, q_cond (k) * 1000.) ** 0.94)
+ qa (k) = qa (k) * (0.92 / 0.96 * q_liq (k) / q_cond (k) + 1.0 / 0.96 * q_sol (k) / q_cond (k))
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ qa (k) = 0.0
+ endif
+ elseif (use_gi_cloud) then ! gultepe and isaac (2007)
+ sigma = 0.28 + max (0.0, q_cond (k) * 1000.) ** 0.49
+ gam = max (0.0, q_cond (k) * 1000.) / sigma
+ if (gam < 0.18) then
+ qa10 = 0.
+ elseif (gam > 2.0) then
+ qa10 = 1.0
+ else
+ qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3
+ qa10 = max (0.0, min (1., qa10))
+ endif
+ if (gam < 0.12) then
+ qa100 = 0.
+ elseif (gam > 1.85) then
+ qa100 = 1.0
+ else
+ qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3
+ qa100 = max (0.0, min (1., qa100))
+ endif
+ qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10)
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ if (rh > rh_thres .and. qpz > 1.e-6) then
- if (icloud_f == 2) then
- if (qstar < qpz) then
- qa (k) = 1.
+ dq = h_var * qpz
+ if (do_cld_adj) then
+ q_plus = qpz + dq * f_dq_p * min(1.0, max(0.0, (p1 (k) - 200.e2) / (1000.e2 - 200.e2)))
else
- qa (k) = 0.
+ q_plus = qpz + dq * f_dq_p
endif
- else
- if (qstar < q_minus) then
- qa (k) = 1.
- else
- if (qstar < q_plus) then
- if (icloud_f == 0) then
- qa (k) = (q_plus - qstar) / (dq + dq)
- else
- qa (k) = (q_plus - qstar) / (2. * dq * (1. - q_cond (k)))
- endif
+ q_minus = qpz - dq * f_dq_m
+
+ if (icloud_f .eq. 2) then
+ if (qstar < qpz) then
+ qa (k) = 1.
else
qa (k) = 0.
endif
- ! impose minimum cloudiness if substantial q_cond (k) exist
- if (q_cond (k) > 1.e-6) then
- qa (k) = max (cld_min, qa (k))
+ elseif (icloud_f .eq. 3) then
+ if (qstar < qpz) then
+ qa (k) = 1.
+ else
+ if (qstar < q_plus) then
+ qa (k) = (q_plus - qstar) / (dq * f_dq_p)
+ else
+ qa (k) = 0.
+ endif
+ ! impose minimum cloudiness if substantial q_cond (k) exist
+ if (q_cond (k) > 1.e-6) then
+ qa (k) = max (cld_min, qa (k))
+ endif
+ qa (k) = min (1., qa (k))
+ endif
+ else
+ if (qstar < q_minus) then
+ qa (k) = 1.
+ else
+ if (qstar < q_plus) then
+ if (icloud_f .eq. 0) then
+ qa (k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m)
+ else
+ qa (k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * (1. - q_cond (k)))
+ endif
+ else
+ qa (k) = 0.
+ endif
+ ! impose minimum cloudiness if substantial q_cond (k) exist
+ if (q_cond (k) > 1.e-6) then
+ qa (k) = max (cld_min, qa (k))
+ endif
+ qa (k) = min (1., qa (k))
endif
- qa (k) = min (1., qa (k))
endif
+ else
+ qa (k) = 0.
endif
- else
- qa (k) = 0.
endif
enddo
@@ -2067,28 +2447,123 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, &
end subroutine subgrid_z_proc
! =======================================================================
-! compute terminal fall speed
-! consider cloud ice, snow, and graupel's melting during fall
+! rain evaporation
! =======================================================================
-subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
- den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1)
+subroutine revap_rac1 (hydrostatic, is, ie, dt, tz, qv, ql, qr, qi, qs, qg, den, hvar)
implicit none
- integer, intent (in) :: ks, ke
- real, intent (in) :: dtm ! time step (s)
- real, intent (in), dimension (ks:ke) :: vtg, vts, vti, den, dp, dz
- real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
- real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qg, qs, qi, m1_sol, w1
- real, intent (out) :: r1, g1, s1, i1
- ! local:
- real, dimension (ks:ke + 1) :: ze, zt
- real :: qsat, dqsdt, dt5, evap, dtime
- real :: factor, frac
+ logical, intent (in) :: hydrostatic
+
+ integer, intent (in) :: is, ie
+
+ real, intent (in) :: dt ! time step (s)
+
+ real, intent (in), dimension (is:ie) :: den, hvar, qi, qs, qg
+
+ real, intent (inout), dimension (is:ie) :: tz, qv, qr, ql
+
+ real, dimension (is:ie) :: lcp2, denfac, q_liq, q_sol, cvm, lhl
+
+ real :: dqv, qsat, dqsdt, evap, qden, q_plus, q_minus, sink
+ real :: tin, t2, qpz, dq, dqh
+
+ integer :: i
+
+ ! -----------------------------------------------------------------------
+ ! define latend heat coefficient
+ ! -----------------------------------------------------------------------
+
+ do i = is, ie
+ lhl (i) = lv00 + d0_vap * tz (i)
+ q_liq (i) = ql (i) + qr (i)
+ q_sol (i) = qi (i) + qs (i) + qg (i)
+ cvm (i) = c_air + qv (i) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
+ lcp2 (i) = lhl (i) / cvm (i)
+ ! denfac (i) = sqrt (sfcrho / den (i))
+ enddo
+
+ do i = is, ie
+ if (qr (i) > qrmin .and. tz (i) > t_wfr) then
+ qpz = qv (i) + ql (i)
+ tin = tz (i) - lcp2 (i) * ql (i) ! presence of clouds suppresses the rain evap
+ qsat = wqs2 (tin, den (i), dqsdt)
+ dqh = max (ql (i), hvar (i) * max (qpz, qcmin))
+ dqv = qsat - qv (i)
+ q_minus = qpz - dqh
+ q_plus = qpz + dqh
+
+ ! -----------------------------------------------------------------------
+ ! qsat must be > q_minus to activate evaporation
+ ! qsat must be < q_plus to activate accretion
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! rain evaporation
+ ! -----------------------------------------------------------------------
+
+ if (dqv > qvmin .and. qsat > q_minus) then
+ if (qsat > q_plus) then
+ dq = qsat - qpz
+ else
+ ! q_minus < qsat < q_plus
+ ! dq == dqh if qsat == q_minus
+ dq = 0.25 * (q_minus - qsat) ** 2 / dqh
+ endif
+ qden = qr (i) * den (i)
+ t2 = tin * tin
+ evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * exp (0.725 * log (qden))) &
+ / (crevp (4) * t2 + crevp (5) * qsat * den (i))
+ evap = min (qr (i), dt * evap, dqv / (1. + lcp2 (i) * dqsdt))
+ qr (i) = qr (i) - evap
+ qv (i) = qv (i) + evap
+ q_liq (i) = q_liq (i) - evap
+ cvm (i) = c_air + qv (i) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
+ tz (i) = tz (i) - evap * lhl (i) / cvm (i)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! accretion: pracc
+ ! -----------------------------------------------------------------------
+
+ if (qr (i) > qrmin .and. ql (i) > 1.e-8 .and. qsat < q_plus) then
+ denfac (i) = sqrt (sfcrho / den (i))
+ sink = dt * denfac (i) * cracw * exp (0.95 * log (qr (i) * den (i)))
+ sink = sink / (1. + sink) * ql (i)
+ ql (i) = ql (i) - sink
+ qr (i) = qr (i) + sink
+ endif
+ endif
+ enddo
+
+end subroutine revap_rac1
+
+! =======================================================================
+! compute terminal fall speed
+! consider cloud ice, snow, and graupel's melting during fall
+! =======================================================================
+
+subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
+ den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1, dte)
+
+ implicit none
+
+ integer, intent (in) :: ks, ke
+ real, intent (in) :: dtm ! time step (s)
+ real, intent (in), dimension (ks:ke) :: vtg, vts, vti, den, dp, dz
+ real (kind = r_grid), intent (inout), dimension (ks:ke) :: tz
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qg, qs, qi, m1_sol, w1
+ real (kind = r_grid), intent (inout) :: dte
+ real, intent (out) :: r1, g1, s1, i1
+ ! local:
+ real, dimension (ks:ke + 1) :: ze, zt
+ real :: qsat, dqsdt, dt5, evap, dtime
+ real :: factor, frac
real :: tmp, precip, tc, sink
real, dimension (ks:ke) :: lcpk, icpk, cvm, q_liq, q_sol
real, dimension (ks:ke) :: m1, dm
+ real (kind = r_grid), dimension (ks:ke) :: te1, te2
real :: zs = 0.
real :: fac_imlt
@@ -2169,7 +2644,7 @@ subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
enddo
! -----------------------------------------------------------------------
- ! melting of falling cloud ice into rain
+ ! melting of falling cloud ice into cloud water and rain
! -----------------------------------------------------------------------
call check_column (ks, ke, qi, no_fall)
@@ -2213,12 +2688,35 @@ subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
if (use_ppm_ice) then
call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof)
else
call implicit_fall (dtm, ks, ke, ze, vti, dp, qi, i1, m1_sol)
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+ endif
+
if (do_sedi_w) then
w1 (ks) = w1 (ks) + m1_sol (ks) * vti (ks) / dm (ks)
do k = ks + 1, ke
@@ -2280,12 +2778,35 @@ subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
if (use_ppm) then
call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qs, s1, m1, mono_prof)
else
call implicit_fall (dtm, ks, ke, ze, vts, dp, qs, s1, m1)
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+ endif
+
do k = ks, ke
m1_sol (k) = m1_sol (k) + m1 (k)
enddo
@@ -2348,12 +2869,35 @@ subroutine terminal_fall (dtm, ks, ke, tz, qv, ql, qr, qg, qs, qi, dz, dp, &
enddo
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te1 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te1 (k) = rgrav * te1 (k) * c_air * tz (k) * dp (k)
+ enddo
+ endif
+
if (use_ppm) then
call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qg, g1, m1, mono_prof)
else
call implicit_fall (dtm, ks, ke, ze, vtg, dp, qg, g1, m1)
endif
+ ! -----------------------------------------------------------------------
+ ! energy loss during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ do k = ks, ke
+ te2 (k) = one_r8 + qv (k) * c1_vap + (ql (k) + qr (k)) * c1_liq + (qi (k) + qs (k) + qg (k)) * c1_ice
+ te2 (k) = rgrav * te2 (k) * c_air * tz (k) * dp (k)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+ endif
+
do k = ks, ke
m1_sol (k) = m1_sol (k) + m1 (k)
enddo
@@ -2451,7 +2995,7 @@ subroutine implicit_fall (dt, ks, ke, ze, vt, dp, q, precip, m1)
! -----------------------------------------------------------------------
do k = ks, ke
- q (k) = qm (k) / dp (k)
+ q (k) = qm (k) / dp (k) !dry dp used inside MP
enddo
end subroutine implicit_fall
@@ -2829,8 +3373,14 @@ subroutine fall_speed (ks, ke, den, qs, qi, qg, ql, tk, vts, vti, vtg)
vti (k) = vf_min
else
tc (k) = tk (k) - tice
- vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee
- vti (k) = vi0 * exp (log_10 * vti (k))
+ if (hd_icefall) then
+ ! heymsfield and donner, 1990, jas
+ vti (k) = vi_fac * 3.29 * (qi (k) * den (k)) ** 0.16
+ else
+ ! deng and mace, 2008, grl
+ vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee
+ vti (k) = vi0 * exp (log_10 * vti (k))
+ endif
vti (k) = min (vi_max, max (vf_min, vti (k)))
endif
enddo
@@ -2927,11 +3477,11 @@ subroutine setupm
tcond = 2.36e-2
visk = 1.259e-5
- hlts = 2.8336e6
- hltc = 2.5e6
- hltf = 3.336e5
+ hlts = hlv + hlf
+ hltc = hlv
+ hltf = hlf
- ch2o = 4.1855e3
+ ch2o = c_liq
ri50 = 1.e-4
pisq = pie * pie
@@ -3038,7 +3588,7 @@ subroutine setupm
cgmlt (4) = cgsub (3)
cgmlt (5) = ch2o / hltf
- es0 = 6.107799961e2 ! ~6.1 mb
+ es0 = e00
ces0 = eps * es0
end subroutine setupm
@@ -3047,71 +3597,21 @@ end subroutine setupm
! initialization of gfdl cloud microphysics
! =======================================================================
-!subroutine gfdl_mp_init (id, jd, kd, axes, time)
-subroutine gfdl_mp_init (me, master, nlunit, input_nml_file, logunit, fn_nml)
+subroutine gfdl_mp_init (input_nml_file, logunit)
implicit none
- integer, intent (in) :: me
- integer, intent (in) :: master
- integer, intent (in) :: nlunit
- integer, intent (in) :: logunit
-
- character (len = 64), intent (in) :: fn_nml
character (len = *), intent (in) :: input_nml_file (:)
+ integer, intent (in) :: logunit
- integer :: ios
logical :: exists
- ! integer, intent (in) :: id, jd, kd
- ! integer, intent (in) :: axes (4)
- ! type (time_type), intent (in) :: time
-
- ! integer :: unit, io, ierr, k, logunit
- ! logical :: flag
- ! real :: tmp, q1, q2
-
- ! master = (mpp_pe () .eq.mpp_root_pe ())
-
- !#ifdef internal_file_nml
- ! read (input_nml_file, nml = gfdl_mp_nml, iostat = io)
- ! ierr = check_nml_error (io, 'gfdl_mp_nml')
- !#else
- ! if (file_exist ('input.nml')) then
- ! unit = open_namelist_file ()
- ! io = 1
- ! do while (io .ne. 0)
- ! read (unit, nml = gfdl_mp_nml, iostat = io, end = 10)
- ! ierr = check_nml_error (io, 'gfdl_mp_nml')
- ! enddo
- !10 call close_file (unit)
- ! endif
- !#endif
- ! call write_version_number ('gfdl_mp_mod', version)
- ! logunit = stdlog ()
-
-#ifdef INTERNAL_FILE_NML
read (input_nml_file, nml = gfdl_mp_nml)
-#else
- inquire (file = trim (fn_nml), exist = exists)
- if (.not. exists) then
- write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist'
- stop
- else
- open (unit = nlunit, file = fn_nml, readonly, status = 'old', iostat = ios)
- endif
- rewind (nlunit)
- read (nlunit, nml = gfdl_mp_nml)
- close (nlunit)
-#endif
! write version number and namelist to log file
-
- if (me == master) then
- write (logunit, *) " ================================================================== "
- write (logunit, *) "gfdl_mp_mod"
- write (logunit, nml = gfdl_mp_nml)
- endif
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "gfdl_mp_mod"
+ write (logunit, nml = gfdl_mp_nml)
if (do_setup) then
call setup_con
@@ -3122,31 +3622,11 @@ subroutine gfdl_mp_init (me, master, nlunit, input_nml_file, logunit, fn_nml)
g2 = 0.5 * grav
log_10 = log (10.)
- tice0 = tice - 0.01
- t_wfr = tice - 40.0 ! supercooled water can exist down to - 48 c, which is the "absolute"
-
- ! if (master) write (logunit, nml = gfdl_mp_nml)
-
- ! if (master) write (*, *) 'prec_lin diagnostics initialized.', id_prec
-
- ! call qsmith_init
-
- ! testing the water vapor tables
-
- ! if (mp_debug .and. master) then
- ! write (*, *) 'testing water vapor tables in gfdl_mp'
- ! tmp = tice - 90.
- ! do k = 1, 25
- ! q1 = wqsat_moist (tmp, 0., 1.e5)
- ! q2 = qs1d_m (tmp, 0., 1.e5)
- ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2
- ! tmp = tmp + 5.
- ! enddo
- ! endif
-
- ! if (master) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.'
-
- ! gfdl_mp_clock = mpp_clock_id ('gfdl_mp', grain = clock_routine)
+ if (do_warm_rain_mp) then
+ t_wfr = t_min
+ else
+ t_wfr = t_ice - 40.0
+ endif
module_is_initialized = .true.
@@ -3183,150 +3663,436 @@ subroutine setup_con
! master = (mpp_pe () .eq.mpp_root_pe ())
- rgrav = 1. / grav
-
if (.not. qsmith_tables_initialized) call qsmith_init
qsmith_tables_initialized = .true.
-end subroutine setup_con
+end subroutine setup_con
+
+! =======================================================================
+! accretion function (lin et al. 1983)
+! =======================================================================
+
+real function acr3d (v1, v2, q1, q2, c, cac, rho)
+
+ implicit none
+
+ real, intent (in) :: v1, v2, c, rho
+ real, intent (in) :: q1, q2 ! mixing ratio!!!
+ real, intent (in) :: cac (3)
+
+ real :: t1, s1, s2
+
+ ! integer :: k
+ !
+ ! real :: a
+ !
+ ! a = 0.0
+ ! do k = 1, 3
+ ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25))
+ ! enddo
+ ! acr3d = c * abs (v1 - v2) * a / rho
+
+ ! optimized
+
+ t1 = sqrt (q1 * rho)
+ s1 = sqrt (q2 * rho)
+ s2 = sqrt (s1) ! s1 = s2 ** 2
+ acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1)
+
+end function acr3d
+
+! =======================================================================
+! melting of snow function (lin et al. 1983)
+! note: psacw and psacr must be calc before smlt is called
+! =======================================================================
+
+real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac)
+
+ implicit none
+
+ real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac
+
+ smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + &
+ c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr)
+
+end function smlt
+
+! =======================================================================
+! melting of graupel function (lin et al. 1983)
+! note: pgacw and pgacr must be calc before gmlt is called
+! =======================================================================
+
+real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho)
+
+ implicit none
+
+ real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho
+
+ gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + &
+ c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr)
+
+end function gmlt
+
+! =======================================================================
+! initialization
+! prepare saturation water vapor pressure tables
+! =======================================================================
+
+subroutine qsmith_init
+
+ implicit none
+
+ integer, parameter :: length = 2621
+
+ integer :: i
+
+ if (.not. tables_are_initialized) then
+
+ allocate (table (length))
+ allocate (table2 (length))
+ allocate (table3 (length))
+ allocate (tablew (length))
+ allocate (des (length))
+ allocate (des2 (length))
+ allocate (des3 (length))
+ allocate (desw (length))
+
+ call qs_table (length)
+ call qs_table2 (length)
+ call qs_table3 (length)
+ call qs_tablew (length)
+
+ do i = 1, length - 1
+ des (i) = max (0., table (i + 1) - table (i))
+ des2 (i) = max (0., table2 (i + 1) - table2 (i))
+ des3 (i) = max (0., table3 (i + 1) - table3 (i))
+ desw (i) = max (0., tablew (i + 1) - tablew (i))
+ enddo
+ des (length) = des (length - 1)
+ des2 (length) = des2 (length - 1)
+ des3 (length) = des3 (length - 1)
+ desw (length) = desw (length - 1)
+
+ tables_are_initialized = .true.
+
+ if (is_master()) print*, ' QS lookup tables initialized'
+
+ endif
+
+end subroutine qsmith_init
+
+! =======================================================================
+! compute the saturated specific humidity for table ii
+! =======================================================================
+
+real function wqs1 (ta, den)
+
+ implicit none
+
+ ! pure water phase; universal dry / moist formular using air density
+ ! input "den" can be either dry or moist air density
+
+ real, intent (in) :: ta, den
+
+ real :: es, ap1, tmin
+
+ integer :: it
+
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = tablew (it) + (ap1 - it) * desw (it)
+ wqs1 = es / (rvgas * ta * den)
+
+end function wqs1
+
+! =======================================================================
+! compute the gradient of saturated specific humidity for table ii
+! =======================================================================
+
+real function wqs2 (ta, den, dqdt)
+
+ implicit none
+
+ ! pure water phase; universal dry / moist formular using air density
+ ! input "den" can be either dry or moist air density
+
+ real, intent (in) :: ta, den
+ real, intent (out) :: dqdt
+ real :: es, ap1, tmin
+ integer :: it
+
+ tmin = table_ice - 160.
+
+ if (.not. tables_are_initialized) call qsmith_init
+
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = tablew (it) + (ap1 - it) * desw (it)
+ wqs2 = es / (rvgas * ta * den)
+ it = ap1 - 0.5
+ ! finite diff, del_t = 0.1:
+ dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den)
+
+end function wqs2
+
+! =======================================================================
+! compute the gradient of saturated specific humidity for table ii
+! it is the same as "wqs2", but written as vector function
+! =======================================================================
+
+subroutine wqs2_vect (is, ie, ta, den, wqsat, dqdt)
+
+ implicit none
+
+ ! pure water phase; universal dry / moist formular using air density
+ ! input "den" can be either dry or moist air density
+
+ integer, intent (in) :: is, ie
+
+ real, intent (in), dimension (is:ie) :: ta, den
+
+ real, intent (out), dimension (is:ie) :: wqsat, dqdt
+
+ real :: es, ap1, tmin
+
+ integer :: i, it
+
+ tmin = t_ice - 160.
+
+ do i = is, ie
+ ap1 = 10. * dim (ta (i), tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = tablew (it) + (ap1 - it) * desw (it)
+ wqsat (i) = es / (rvgas * ta (i) * den (i))
+ it = ap1 - 0.5
+ ! finite diff, del_t = 0.1:
+ dqdt (i) = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta (i) * den (i))
+ enddo
+
+end subroutine wqs2_vect
+
+! =======================================================================
+! compute wet buld temperature
+! =======================================================================
+
+real function wet_bulb (q, t, den)
+
+ implicit none
+
+ real, intent (in) :: t, q, den
+
+ real :: qs, tp, dqdt
+
+ wet_bulb = t
+ qs = wqs2 (wet_bulb, den, dqdt)
+ tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp
+ wet_bulb = wet_bulb - tp
+
+ ! tp is negative if super - saturated
+ if (tp > 0.01) then
+ qs = wqs2 (wet_bulb, den, dqdt)
+ tp = (qs - q) / (1. + lcp * dqdt) * lcp
+ wet_bulb = wet_bulb - tp
+ endif
+
+end function wet_bulb
+
+! =======================================================================
+! compute the saturated specific humidity for table iii
+! =======================================================================
+
+real function iqs1 (ta, den)
+
+ implicit none
+
+ ! water - ice phase; universal dry / moist formular using air density
+ ! input "den" can be either dry or moist air density
+
+ real, intent (in) :: ta, den
+
+ real :: es, ap1, tmin
+
+ integer :: it
+
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = table2 (it) + (ap1 - it) * des2 (it)
+ iqs1 = es / (rvgas * ta * den)
+
+end function iqs1
+
+! =======================================================================
+! compute the gradient of saturated specific humidity for table iii
+! =======================================================================
+
+real function iqs2 (ta, den, dqdt)
+
+ implicit none
+
+ ! water - ice phase; universal dry / moist formular using air density
+ ! input "den" can be either dry or moist air density
+
+ real (kind = r_grid), intent (in) :: ta
+ real, intent (in) :: den
+ real, intent (out) :: dqdt
+ real (kind = r_grid) :: tmin, es, ap1
+ integer :: it
+
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = table2 (it) + (ap1 - it) * des2 (it)
+ iqs2 = es / (rvgas * ta * den)
+ it = ap1 - 0.5
+ dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den)
+
+end function iqs2
+
+! =======================================================================
+! compute the gradient of saturated specific humidity for table iii
+! =======================================================================
+
+real function qs1d_moist (ta, qv, pa, dqdt)
+
+ implicit none
+
+ real, intent (in) :: ta, pa, qv
+
+ real, intent (out) :: dqdt
+
+ real :: es, ap1, tmin, eps10
+
+ integer :: it
+
+ tmin = table_ice - 160.
+ eps10 = 10. * eps
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = table2 (it) + (ap1 - it) * des2 (it)
+ qs1d_moist = eps * es * (1. + zvir * qv) / pa
+ it = ap1 - 0.5
+ dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa
+
+end function qs1d_moist
! =======================================================================
-! accretion function (lin et al. 1983)
+! compute the gradient of saturated specific humidity for table ii
! =======================================================================
-real function acr3d (v1, v2, q1, q2, c, cac, rho)
+real function wqsat2_moist (ta, qv, pa, dqdt)
implicit none
- real, intent (in) :: v1, v2, c, rho
- real, intent (in) :: q1, q2 ! mixing ratio!!!
- real, intent (in) :: cac (3)
+ real, intent (in) :: ta, pa, qv
- real :: t1, s1, s2
+ real, intent (out) :: dqdt
- ! integer :: k
- !
- ! real :: a
- !
- ! a = 0.0
- ! do k = 1, 3
- ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25))
- ! enddo
- ! acr3d = c * abs (v1 - v2) * a / rho
+ real :: es, ap1, tmin, eps10
- ! optimized
+ integer :: it
- t1 = sqrt (q1 * rho)
- s1 = sqrt (q2 * rho)
- s2 = sqrt (s1) ! s1 = s2 ** 2
- acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1)
+ tmin = table_ice - 160.
+ eps10 = 10. * eps
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = tablew (it) + (ap1 - it) * desw (it)
+ wqsat2_moist = eps * es * (1. + zvir * qv) / pa
+ it = ap1 - 0.5
+ dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa
-end function acr3d
+end function wqsat2_moist
! =======================================================================
-! melting of snow function (lin et al. 1983)
-! note: psacw and psacr must be calc before smlt is called
+! compute the saturated specific humidity for table ii
! =======================================================================
-real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac)
+real function wqsat_moist (ta, qv, pa)
implicit none
- real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac
-
- smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + &
- c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr)
-
-end function smlt
-
-! =======================================================================
-! melting of graupel function (lin et al. 1983)
-! note: pgacw and pgacr must be calc before gmlt is called
-! =======================================================================
-
-real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho)
+ real, intent (in) :: ta, pa, qv
- implicit none
+ real :: es, ap1, tmin
- real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho
+ integer :: it
- gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + &
- c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr)
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = tablew (it) + (ap1 - it) * desw (it)
+ wqsat_moist = eps * es * (1. + zvir * qv) / pa
-end function gmlt
+end function wqsat_moist
! =======================================================================
-! initialization
-! prepare saturation water vapor pressure tables
+! compute the saturated specific humidity for table iii
! =======================================================================
-subroutine qsmith_init
+real function qs1d_m (ta, qv, pa)
implicit none
- integer, parameter :: length = 2621
+ real, intent (in) :: ta, pa, qv
- integer :: i
+ real :: es, ap1, tmin
- if (.not. tables_are_initialized) then
+ integer :: it
- ! master = (mpp_pe () .eq. mpp_root_pe ())
- ! if (master) print *, ' gfdl mp: initializing qs tables'
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = table2 (it) + (ap1 - it) * des2 (it)
+ qs1d_m = eps * es * (1. + zvir * qv) / pa
- ! debug code
- ! print *, mpp_pe (), allocated (table), allocated (table2), &
- ! allocated (table3), allocated (tablew), allocated (des), &
- ! allocated (des2), allocated (des3), allocated (desw)
- ! end debug code
+end function qs1d_m
- ! generate es table (dt = 0.1 deg. c)
+! =======================================================================
+! computes the difference in saturation vapor * density * between water and ice
+! =======================================================================
- allocate (table (length))
- allocate (table2 (length))
- allocate (table3 (length))
- allocate (tablew (length))
- allocate (des (length))
- allocate (des2 (length))
- allocate (des3 (length))
- allocate (desw (length))
+real function d_sat (ta, den)
- call qs_table (length)
- call qs_table2 (length)
- call qs_table3 (length)
- call qs_tablew (length)
+ implicit none
- do i = 1, length - 1
- des (i) = max (0., table (i + 1) - table (i))
- des2 (i) = max (0., table2 (i + 1) - table2 (i))
- des3 (i) = max (0., table3 (i + 1) - table3 (i))
- desw (i) = max (0., tablew (i + 1) - tablew (i))
- enddo
- des (length) = des (length - 1)
- des2 (length) = des2 (length - 1)
- des3 (length) = des3 (length - 1)
- desw (length) = desw (length - 1)
+ real, intent (in) :: ta, den
- tables_are_initialized = .true.
+ real :: es_w, es_i, ap1, tmin
- endif
+ integer :: it
-end subroutine qsmith_init
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (ta, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es_w = tablew (it) + (ap1 - it) * desw (it)
+ es_i = table2 (it) + (ap1 - it) * des2 (it)
+ d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference
+
+end function d_sat
! =======================================================================
-! compute the saturated specific humidity for table ii
+! compute the saturated water vapor pressure for table ii
! =======================================================================
-real function wqs1 (ta, den)
+real function esw_table (ta)
implicit none
- ! pure water phase; universal dry / moist formular using air density
- ! input "den" can be either dry or moist air density
-
- real, intent (in) :: ta, den
+ real, intent (in) :: ta
- real :: es, ap1, tmin
+ real :: ap1, tmin
integer :: it
@@ -3334,130 +4100,118 @@ real function wqs1 (ta, den)
ap1 = 10. * dim (ta, tmin) + 1.
ap1 = min (2621., ap1)
it = ap1
- !NOTE: a crash here usually means NaN
- !if (it < 1 .or. it > 2621) then
- ! write(*,*), 'WQS1: table range violation', it, ta, tmin, den
- !endif
- es = tablew (it) + (ap1 - it) * desw (it)
- wqs1 = es / (rvgas * ta * den)
+ esw_table = tablew (it) + (ap1 - it) * desw (it)
-end function wqs1
+end function esw_table
! =======================================================================
-! compute the gradient of saturated specific humidity for table ii
+! compute the saturated water vapor pressure for table iii
! =======================================================================
-real function wqs2 (ta, den, dqdt)
+real function es2_table (ta)
implicit none
- ! pure water phase; universal dry / moist formular using air density
- ! input "den" can be either dry or moist air density
+ real, intent (in) :: ta
+
+ real :: ap1, tmin
- real, intent (in) :: ta, den
- real, intent (out) :: dqdt
- real :: es, ap1, tmin
integer :: it
tmin = table_ice - 160.
-
- if (.not. tables_are_initialized) call qsmith_init
-
ap1 = 10. * dim (ta, tmin) + 1.
ap1 = min (2621., ap1)
it = ap1
- !NOTE: a crash here usually means NaN
- !if (it < 1 .or. it > 2621) then
- ! write(*,*), 'WQS2: table range violation', it, ta, tmin, den
- !endif
- es = tablew (it) + (ap1 - it) * desw (it)
- wqs2 = es / (rvgas * ta * den)
- it = ap1 - 0.5
- ! finite diff, del_t = 0.1:
- dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den)
+ es2_table = table2 (it) + (ap1 - it) * des2 (it)
-end function wqs2
+end function es2_table
! =======================================================================
-! compute wet buld temperature
+! compute the saturated water vapor pressure for table ii
! =======================================================================
-real function wet_bulb (q, t, den)
+subroutine esw_table1d (ta, es, n)
implicit none
- real, intent (in) :: t, q, den
+ integer, intent (in) :: n
- real :: qs, tp, dqdt
+ real, intent (in) :: ta (n)
- wet_bulb = t
- qs = wqs2 (wet_bulb, den, dqdt)
- tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp
- wet_bulb = wet_bulb - tp
+ real, intent (out) :: es (n)
- ! tp is negative if super - saturated
- if (tp > 0.01) then
- qs = wqs2 (wet_bulb, den, dqdt)
- tp = (qs - q) / (1. + lcp * dqdt) * lcp
- wet_bulb = wet_bulb - tp
- endif
+ real :: ap1, tmin
-end function wet_bulb
+ integer :: i, it
+
+ tmin = table_ice - 160.
+
+ do i = 1, n
+ ap1 = 10. * dim (ta (i), tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es (i) = tablew (it) + (ap1 - it) * desw (it)
+ enddo
+
+end subroutine esw_table1d
! =======================================================================
-! compute the saturated specific humidity for table iii
+! compute the saturated water vapor pressure for table iii
! =======================================================================
-real function iqs1 (ta, den)
+subroutine es2_table1d (ta, es, n)
implicit none
- ! water - ice phase; universal dry / moist formular using air density
- ! input "den" can be either dry or moist air density
+ integer, intent (in) :: n
- real, intent (in) :: ta, den
+ real, intent (in) :: ta (n)
- real :: es, ap1, tmin
+ real, intent (out) :: es (n)
- integer :: it
+ real :: ap1, tmin
+
+ integer :: i, it
tmin = table_ice - 160.
- ap1 = 10. * dim (ta, tmin) + 1.
- ap1 = min (2621., ap1)
- it = ap1
- es = table2 (it) + (ap1 - it) * des2 (it)
- iqs1 = es / (rvgas * ta * den)
-end function iqs1
+ do i = 1, n
+ ap1 = 10. * dim (ta (i), tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es (i) = table2 (it) + (ap1 - it) * des2 (it)
+ enddo
+
+end subroutine es2_table1d
! =======================================================================
-! compute the gradient of saturated specific humidity for table iii
+! compute the saturated water vapor pressure for table iv
! =======================================================================
-real function iqs2 (ta, den, dqdt)
+subroutine es3_table1d (ta, es, n)
implicit none
- ! water - ice phase; universal dry / moist formular using air density
- ! input "den" can be either dry or moist air density
+ integer, intent (in) :: n
- real (kind = r_grid), intent (in) :: ta
- real, intent (in) :: den
- real, intent (out) :: dqdt
- real (kind = r_grid) :: tmin, es, ap1
- integer :: it
+ real, intent (in) :: ta (n)
+
+ real, intent (out) :: es (n)
+
+ real :: ap1, tmin
+
+ integer :: i, it
tmin = table_ice - 160.
- ap1 = 10. * dim (ta, tmin) + 1.
- ap1 = min (2621., ap1)
- it = ap1
- es = table2 (it) + (ap1 - it) * des2 (it)
- iqs2 = es / (rvgas * ta * den)
- it = ap1 - 0.5
- dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den)
-end function iqs2
+ do i = 1, n
+ ap1 = 10. * dim (ta (i), tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es (i) = table3 (it) + (ap1 - it) * des3 (it)
+ enddo
+end subroutine es3_table1d
! =======================================================================
! saturation water vapor pressure table ii
@@ -3603,6 +4357,29 @@ subroutine qs_table3 (n)
end subroutine qs_table3
+! =======================================================================
+! compute the saturated specific humidity for table
+! note: this routine is based on "moist" mixing ratio
+! =======================================================================
+
+real function qs_blend (t, p, q)
+
+ implicit none
+
+ real, intent (in) :: t, p, q
+
+ real :: es, ap1, tmin
+
+ integer :: it
+
+ tmin = table_ice - 160.
+ ap1 = 10. * dim (t, tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es = table (it) + (ap1 - it) * des (it)
+ qs_blend = eps * es * (1. + zvir * q) / p
+
+end function qs_blend
! =======================================================================
! saturation water vapor pressure table i
@@ -3666,13 +4443,65 @@ subroutine qs_table (n)
end subroutine qs_table
+! =======================================================================
+! compute the saturated specific humidity and the gradient of saturated specific humidity
+! input t in deg k, p in pa; p = rho rdry tv, moist pressure
+! =======================================================================
+
+subroutine qsmith (im, km, ks, t, p, q, qs, dqdt)
+
+ implicit none
+
+ integer, intent (in) :: im, km, ks
+
+ real, intent (in), dimension (im, km) :: t, p, q
+
+ real, intent (out), dimension (im, km) :: qs
+
+ real, intent (out), dimension (im, km), optional :: dqdt
+
+ real :: eps10, ap1, tmin
+
+ real, dimension (im, km) :: es
+
+ integer :: i, k, it
+
+ tmin = table_ice - 160.
+ eps10 = 10. * eps
+
+ if (.not. tables_are_initialized) then
+ call qsmith_init
+ endif
+
+ do k = ks, km
+ do i = 1, im
+ ap1 = 10. * dim (t (i, k), tmin) + 1.
+ ap1 = min (2621., ap1)
+ it = ap1
+ es (i, k) = table (it) + (ap1 - it) * des (it)
+ qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k)
+ enddo
+ enddo
+
+ if (present (dqdt)) then
+ do k = ks, km
+ do i = 1, im
+ ap1 = 10. * dim (t (i, k), tmin) + 1.
+ ap1 = min (2621., ap1) - 0.5
+ it = ap1
+ dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k)
+ enddo
+ enddo
+ endif
+
+end subroutine qsmith
! =======================================================================
! fix negative water species
! this is designed for 6 - class micro - physics schemes
! =======================================================================
-subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg)
+subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg, cond)
implicit none
@@ -3680,6 +4509,7 @@ subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg)
real, intent (in), dimension (ks:ke) :: dp
real (kind = r_grid), intent (inout), dimension (ks:ke) :: pt
real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (out) :: cond
real, dimension (ks:ke) :: lcpk, icpk
@@ -3697,6 +4527,8 @@ subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg)
icpk (k) = (li00 + d1_ice * pt (k)) / cvm
enddo
+ cond = 0
+
do k = ks, ke
! -----------------------------------------------------------------------
@@ -3714,13 +4546,11 @@ subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg)
qs (k) = 0.
endif
! if graupel < 0, borrow from rain
-#ifdef HIGH_NEG_HT
if (qg (k) < 0.) then
qr (k) = qr (k) + qg (k)
pt (k) = pt (k) - qg (k) * icpk (k) ! heating
qg (k) = 0.
endif
-#endif
! -----------------------------------------------------------------------
! liquid phase:
@@ -3731,55 +4561,37 @@ subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg)
ql (k) = ql (k) + qr (k)
qr (k) = 0.
endif
+ ! if cloud water < 0, borrow from water vapor
+ if (ql (k) < 0.) then
+ cond = cond - ql (k) * dp (k)
+ qv (k) = qv (k) + ql (k)
+ pt (k) = pt (k) - ql (k) * lcpk (k) ! heating
+ ql (k) = 0.
+ endif
enddo
-end subroutine neg_adj
+ ! -----------------------------------------------------------------------
+ ! fix water vapor; borrow from below
+ ! -----------------------------------------------------------------------
-! =======================================================================
-! compute global sum
-! quick local sum algorithm
-! =======================================================================
-
-!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode)
-!
-! use mpp_mod, only: mpp_sum
-!
-! implicit none
-!
-! integer, intent (in) :: ifirst, ilast, jfirst, jlast
-! integer, intent (in) :: mode ! if == 1 divided by area
-!
-! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area
-!
-! integer :: i, j
-!
-! real :: gsum
-!
-! if (global_area < 0.) then
-! global_area = 0.
-! do j = jfirst, jlast
-! do i = ifirst, ilast
-! global_area = global_area + area (i, j)
-! enddo
-! enddo
-! call mpp_sum (global_area)
-! endif
-!
-! gsum = 0.
-! do j = jfirst, jlast
-! do i = ifirst, ilast
-! gsum = gsum + p (i, j) * area (i, j)
-! enddo
-! enddo
-! call mpp_sum (gsum)
-!
-! if (mode == 1) then
-! g_sum = gsum / global_area
-! else
-! g_sum = gsum
-! endif
-!
-!end function g_sum
+ do k = ks, ke - 1
+ if (qv (k) < 0.) then
+ qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1)
+ qv (k) = 0.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! bottom layer; borrow from above
+ ! -----------------------------------------------------------------------
+
+ if (qv (ke) < 0. .and. qv (ke - 1) > 0.) then
+ dq = min (- qv (ke) * dp (ke), qv (ke - 1) * dp (ke - 1))
+ qv (ke - 1) = qv (ke - 1) - dq / dp (ke - 1)
+ qv (ke) = qv (ke) + dq / dp (ke)
+ endif
+
+end subroutine neg_adj
end module gfdl_mp_mod
diff --git a/model/nh_core.F90 b/model/nh_core.F90
index 9dcd7a302..00055a928 100644
--- a/model/nh_core.F90
+++ b/model/nh_core.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module nh_core_mod
! Developer: S.-J. Lin, NOAA/GFDL
! To do list:
diff --git a/model/nh_utils.F90 b/model/nh_utils.F90
index 0921b1a02..adea41188 100644
--- a/model/nh_utils.F90
+++ b/model/nh_utils.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module nh_utils_mod
! Developer: S.-J. Lin, NOAA/GFDL
! To do list:
@@ -34,9 +35,13 @@ module nh_utils_mod
public update_dz_c, update_dz_d, nh_bc
public sim_solver, sim1_solver, sim3_solver
public sim3p0_solver, rim_2d
- public Riem_Solver_c
+ public Riem_Solver_c, edge_scalar
+#ifdef DZ_MIN_6
+ real, parameter:: dz_min = 6.
+#else
real, parameter:: dz_min = 2.
+#endif
real, parameter:: r3 = 1./3.
CONTAINS
@@ -173,6 +178,11 @@ subroutine update_dz_c(is, ie, js, je, km, ng, dt, dp0, zs, area, ut, vt, gz, ws
enddo
do k=km, 1, -1
do i=is1, ie1
+#ifdef DZ_MIN_6
+ if (gz(i,j,k) < gz(i,j,k+1) + dz_min) then
+ write(*,'(A, 3I4, 2F)') 'UPDATE_DZ_C: dz limiter applied', i, j, k, gz(i,j,k), gz(i,j,k+1)
+ endif
+#endif
gz(i,j,k) = max( gz(i,j,k), gz(i,j,k+1) + dz_min )
enddo
enddo
@@ -288,6 +298,11 @@ subroutine update_dz_d(ndif, damp, hord, is, ie, js, je, km, ng, npx, npy, area,
do k=km, 1, -1
do i=is, ie
! Enforce monotonicity of height to prevent blowup
+#ifdef DZ_MIN_6
+ if (zh(i,j,k) < zh(i,j,k+1) + dz_min) then
+ write(*,'(A, 3I4, 2F)') 'UPDATE_DZ_D: dz limiter applied', i, j, k, zh(i,j,k), zh(i,j,k+1)
+ endif
+#endif
zh(i,j,k) = max( zh(i,j,k), zh(i,j,k+1) + dz_min )
enddo
enddo
@@ -1625,7 +1640,6 @@ subroutine edge_profile(q1, q2, q1e, q2e, i1, i2, j1, j2, j, km, dp0, uniform_gr
end subroutine edge_profile
-!TODO LMH 25may18: do not need delz defined on full compute domain; pass appropriate BCs instead
subroutine nh_bc(ptop, grav, kappa, cp, delp, delzBC, pt, phis, &
#ifdef USE_COND
q_con, &
diff --git a/model/sw_core.F90 b/model/sw_core.F90
index b98c5c82d..69f0c02e1 100644
--- a/model/sw_core.F90
+++ b/model/sw_core.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,7 +18,8 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
- module sw_core_mod
+
+module sw_core_mod
use tp_core_mod, only: fv_tp_2d, pert_ppm, copy_corners
use fv_mp_mod, only: fill_corners, XDir, YDir
@@ -492,7 +493,7 @@ end subroutine c_sw
subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
ua, va, divg_d, xflux, yflux, cx, cy, &
crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source, &
- zvir, sphum, nq, q, k, km, inline_q, &
+ 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)
@@ -516,6 +517,7 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
real, intent(INOUT):: q(bd%isd:bd%ied,bd%jsd:bd%jed,km,nq)
real, intent(OUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc
real, intent(OUT), dimension(bd%is:bd%ie,bd%js:bd%je):: heat_source
+ real, intent(OUT), dimension(bd%is:bd%ie,bd%js:bd%je):: diss_est
! The flux capacitors:
real, intent(INOUT):: xflux(bd%is:bd%ie+1,bd%js:bd%je )
real, intent(INOUT):: yflux(bd%is:bd%ie ,bd%js:bd%je+1)
@@ -934,6 +936,7 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
do j=js,je
do i=is,ie
heat_source(i,j) = 0.
+ diss_est(i,j) = 0.
enddo
enddo
@@ -948,6 +951,9 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
! 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))
+ if ( flagstruct%do_diss_est ) then
+ diss_est(i,j) = heat_source(i,j)
+ endif
enddo
enddo
endif
@@ -977,10 +983,15 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
! enddo
! enddo
! endif
+#if defined(GFS_PHYS) || defined(DCMIP)
call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, gx, gy, &
xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, &
- mfx=fx, mfy=fy, mass=delp, nord=nord_v, damp_c=damp_v)
-! mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
+ mfx=fx, mfy=fy, mass=delp, nord=nord_v, damp_c=damp_v) !SHiELD
+#else
+ call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, 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) !AM4
+#endif
#endif
if ( inline_q ) then
@@ -1481,7 +1492,7 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
call del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, gridstruct, bd)
endif
- if ( d_con > 1.e-5 ) then
+ if ( d_con > 1.e-5 .or. flagstruct%do_diss_est ) then
do j=js,je+1
do i=is,ie
ub(i,j) = (ub(i,j) + vt(i,j))*rdx(i,j)
@@ -1512,6 +1523,12 @@ subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, &
(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 (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
enddo
enddo
endif
@@ -1544,6 +1561,8 @@ subroutine del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, gridstruct, bd)
! nord = 1: del-4
! nord = 2: del-6
!------------------
+!This does the same operation as tp_core::deln_flux except that it does not
+!add diffusive fluxes into the regular fluxes
integer, intent(in):: nord, npx, npy
real, intent(in):: damp
type(fv_grid_bounds_type), intent(IN) :: bd
diff --git a/model/tp_core.F90 b/model/tp_core.F90
index a8e83caa6..89d2b14e8 100644
--- a/model/tp_core.F90
+++ b/model/tp_core.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module tp_core_mod
!BOP
!
diff --git a/tools/coarse_grained_diagnostics.F90 b/tools/coarse_grained_diagnostics.F90
index 8f910abdd..55e4393b6 100644
--- a/tools/coarse_grained_diagnostics.F90
+++ b/tools/coarse_grained_diagnostics.F90
@@ -1,17 +1,40 @@
+!***********************************************************************
+!* 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 coarse_grained_diagnostics_mod
use constants_mod, only: rdgas, grav, pi=>pi_8
use diag_manager_mod, only: diag_axis_init, register_diag_field, register_static_field, send_data
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
+ 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 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, &
vertical_remapping_requirements, mask_area_weights, mask_mass_weights, &
- block_edge_sum_x, block_edge_sum_y
+ block_edge_sum_x, block_edge_sum_y,&
+ eddy_covariance_2d_weights, eddy_covariance_3d_weights
+
use time_manager_mod, only: time_type
use tracer_manager_mod, only: get_tracer_index, get_tracer_names
@@ -36,19 +59,20 @@ module coarse_grained_diagnostics_mod
logical :: always_model_level_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
+ character(len=64) :: special_case = '' ! E.g. height is computed differently on pressure surfaces
type(data_subtype) :: data
end type coarse_diag_type
public :: fv_coarse_diag_init, fv_coarse_diag
integer :: tile_count = 1 ! Following fv_diagnostics.F90
- integer :: DIAG_SIZE = 512
- type(coarse_diag_type), dimension(512) :: coarse_diagnostics
+ integer :: DIAG_SIZE = 1024
+ type(coarse_diag_type), dimension(1024) :: coarse_diagnostics
! Reduction methods
character(len=11) :: AREA_WEIGHTED = 'area_weighted'
character(len=11) :: MASS_WEIGHTED = 'mass_weighted'
+ character(len=15) :: EDDY_COVARIANCE = 'eddy_covariance'
character(len=5) :: pressure_level_label
contains
@@ -59,6 +83,7 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics)
integer :: is, ie, js, je, npz, n_tracers, n_prognostic, t, p, n_pressure_levels
integer :: index = 1
+ integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel
character(len=128) :: tracer_name
character(len=256) :: tracer_long_name, tracer_units
character(len=8) :: DYNAMICS = 'dynamics'
@@ -69,6 +94,12 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics)
npz = Atm(tile_count)%npz
n_prognostic = size(Atm(tile_count)%q, 4)
n_tracers = Atm(tile_count)%ncnst
+ sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
+ liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
+ ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
+ rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
+ snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
+ graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
call get_fine_array_bounds(is, ie, js, je)
coarse_diagnostics(index)%axes = 3
@@ -164,6 +195,69 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics)
! Defer pointer association for these diagnostics in case their arrays have
! not been allocated yet.
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_temperature_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of temperature'
+ coarse_diagnostics(index)%units = 'K Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%pt(is:ie,js:je,1:npz)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_specific_humidity_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of specific humidity'
+ coarse_diagnostics(index)%units = 'kg/kg Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,sphum)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_liquid_water_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of liquid water'
+ coarse_diagnostics(index)%units = 'kg/kg Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,liq_wat)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_ice_water_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of ice water'
+ coarse_diagnostics(index)%units = 'kg/kg Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,ice_wat)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_rain_water_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of rain water'
+ coarse_diagnostics(index)%units = 'kg/kg Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,rainwat)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_snow_water_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of snow water'
+ coarse_diagnostics(index)%units = 'kg/kg Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,snowwat)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 3
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vertical_eddy_flux_of_graupel_water_coarse'
+ coarse_diagnostics(index)%description = 'vertical eddy flux of graupel water'
+ coarse_diagnostics(index)%units = 'kg/kg Pa/s'
+ coarse_diagnostics(index)%reduction_method = EDDY_COVARIANCE
+ coarse_diagnostics(index)%data%var3 => Atm(tile_count)%q(is:ie,js:je,1:npz,graupel)
+
index = index + 1
coarse_diagnostics(index)%axes = 3
coarse_diagnostics(index)%module_name = DYNAMICS
@@ -293,6 +387,126 @@ 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_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained specific humidity tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'ql_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained total liquid water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'qi_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained total ice water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'liq_wat_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained liquid water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'ice_wat_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained ice water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'qr_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained rain water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'qs_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained snow water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'qg_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained graupel water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 't_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained temperature tendency from GFDL MP'
+ coarse_diagnostics(index)%units = 'K/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 = 'u_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained zonal wind tendency from GFDL MP'
+ 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 = 'v_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained meridional wind tendency from GFDL MP'
+ 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 = 't_dt_sg_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained temperature tendency from 2dz filter'
+ coarse_diagnostics(index)%units = 'K/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 = 'u_dt_sg_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained zonal wind tendency from 2dz filter'
+ coarse_diagnostics(index)%units = 'm/s**2'
+ 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 = 'v_dt_sg_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained meridional wind tendency from 2dz filter'
+ coarse_diagnostics(index)%units = 'm/s**2'
+ 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_sg_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained specific humidity tendency from 2dz filter'
+ coarse_diagnostics(index)%units = 'kg/kg/s'
+ coarse_diagnostics(index)%reduction_method = MASS_WEIGHTED
+
! Vertically integrated diagnostics
index = index + 1
coarse_diagnostics(index)%axes = 2
@@ -420,6 +634,159 @@ 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_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated water vapor specific humidity tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_ql_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated total liquid water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_qi_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated total ice water tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_liq_wat_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated liquid water tracer tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_ice_wat_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated ice water tracer tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_qr_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated rain water tracer tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_qs_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated snow water tracer tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_qg_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated graupel tracer tendency from GFDL MP'
+ 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
+ coarse_diagnostics(index)%name = 'int_t_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated temperature tendency from GFDL MP'
+ coarse_diagnostics(index)%units = 'W/m**2'
+ coarse_diagnostics(index)%scaled_by_specific_heat_and_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_u_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated zonal wind tendency from GFDL MP'
+ coarse_diagnostics(index)%units = 'kg/m s/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
+ coarse_diagnostics(index)%name = 'int_v_dt_gfdlmp_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained vertically integrated meridional wind tendency from GFDL MP'
+ coarse_diagnostics(index)%units = 'kg/m s/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
+ coarse_diagnostics(index)%name = 'tq_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained total water path'
+ coarse_diagnostics(index)%units = 'kg/m**2'
+ coarse_diagnostics(index)%special_case = 'tq'
+ 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 = 'lw_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained liquid water path'
+ coarse_diagnostics(index)%units = 'kg/m**2'
+ coarse_diagnostics(index)%special_case = 'lw'
+ 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 = 'iw_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained ice water path'
+ coarse_diagnostics(index)%units = 'kg/m**2'
+ coarse_diagnostics(index)%special_case = 'iw'
+ 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 = 'tb_coarse'
+ coarse_diagnostics(index)%description = 'coarse temperature in lowest model level'
+ coarse_diagnostics(index)%units = 'K'
+ coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED
+ coarse_diagnostics(index)%data%var2 => Atm(tile_count)%pt(is:ie,js:je,npz)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 2
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'us_coarse'
+ coarse_diagnostics(index)%description = 'coarse zonal wind in lowest model level'
+ coarse_diagnostics(index)%units = 'm/s'
+ coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED
+ coarse_diagnostics(index)%data%var2 => Atm(tile_count)%ua(is:ie,js:je,npz)
+
+ index = index + 1
+ coarse_diagnostics(index)%axes = 2
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vs_coarse'
+ coarse_diagnostics(index)%description = 'coarse meridional wind in lowest model level'
+ coarse_diagnostics(index)%units = 'm/s'
+ coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED
+ coarse_diagnostics(index)%data%var2 => Atm(tile_count)%va(is:ie,js:je,npz)
+
! iv =-1: winds
! iv = 0: positive definite scalars
! iv = 1: temperature
@@ -482,6 +849,16 @@ subroutine populate_coarse_diag_type(Atm, coarse_diagnostics)
coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED
coarse_diagnostics(index)%special_case = 'height'
+ index = index + 1
+ coarse_diagnostics(index)%pressure_level = pressure_levels(p)
+ coarse_diagnostics(index)%axes = 2
+ coarse_diagnostics(index)%module_name = DYNAMICS
+ coarse_diagnostics(index)%name = 'vort' // trim(adjustl(pressure_level_label)) // '_coarse'
+ coarse_diagnostics(index)%description = 'coarse-grained ' // trim(adjustl(pressure_level_label)) // '-mb vorticity'
+ coarse_diagnostics(index)%units = '1/s'
+ coarse_diagnostics(index)%reduction_method = AREA_WEIGHTED
+ coarse_diagnostics(index)%special_case = 'vorticity'
+
do t = 1, n_tracers
call get_tracer_names(MODEL_ATMOS, t, tracer_name, tracer_long_name, tracer_units)
index = index + 1
@@ -559,9 +936,13 @@ subroutine maybe_allocate_reference_array(Atm, coarse_diagnostic)
type(fv_atmos_type), target, intent(inout) :: Atm(:)
type(coarse_diag_type), intent(inout) :: coarse_diagnostic
- integer :: is, ie, js, je, npz
+ integer :: is, ie, js, je, npz, isd, ied, jsd, jed
call get_fine_array_bounds(is, ie, js, je)
+ isd = Atm(tile_count)%bd%isd
+ ied = Atm(tile_count)%bd%ied
+ jsd = Atm(tile_count)%bd%jsd
+ jed = Atm(tile_count)%bd%jed
npz = Atm(tile_count)%npz
! It would be really nice if there were a cleaner way to do this;
@@ -653,6 +1034,97 @@ 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_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))
+ Atm(tile_count)%inline_mp%qv_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%qv_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'ql_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%ql_dt)) then
+ allocate(Atm(tile_count)%inline_mp%ql_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%ql_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%ql_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'qi_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%qi_dt)) then
+ allocate(Atm(tile_count)%inline_mp%qi_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%qi_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%qi_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'liq_wat_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%liq_wat_dt)) then
+ allocate(Atm(tile_count)%inline_mp%liq_wat_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%liq_wat_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%liq_wat_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'ice_wat_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%ice_wat_dt)) then
+ allocate(Atm(tile_count)%inline_mp%ice_wat_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%ice_wat_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%ice_wat_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'qr_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%qr_dt)) then
+ allocate(Atm(tile_count)%inline_mp%qr_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%qr_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%qr_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'qs_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%qs_dt)) then
+ allocate(Atm(tile_count)%inline_mp%qs_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%qs_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%qs_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'qg_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%qg_dt)) then
+ allocate(Atm(tile_count)%inline_mp%qg_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%qg_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%qg_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 't_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%t_dt)) then
+ allocate(Atm(tile_count)%inline_mp%t_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%t_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%t_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'u_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%u_dt)) then
+ allocate(Atm(tile_count)%inline_mp%u_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%u_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%u_dt(is:ie,js:je,1:npz)
+ elseif (ends_with(coarse_diagnostic%name, 'v_dt_gfdlmp_coarse')) then
+ if (.not. allocated(Atm(tile_count)%inline_mp%v_dt)) then
+ allocate(Atm(tile_count)%inline_mp%v_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%inline_mp%v_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%inline_mp%v_dt(is:ie,js:je,1:npz)
+ elseif (coarse_diagnostic%name .eq. 't_dt_sg_coarse') then
+ if (.not. allocated(Atm(tile_count)%sg_diag%t_dt)) then
+ allocate(Atm(tile_count)%sg_diag%t_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%sg_diag%t_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%sg_diag%t_dt(is:ie,js:je,1:npz)
+ elseif (coarse_diagnostic%name .eq. 'u_dt_sg_coarse') then
+ if (.not. allocated(Atm(tile_count)%sg_diag%u_dt)) then
+ allocate(Atm(tile_count)%sg_diag%u_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%sg_diag%u_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%sg_diag%u_dt(is:ie,js:je,1:npz)
+ ! Note: don't use ends_with here, because qv_dt_sg_coarse also ends with v_dt_sg_coarse.
+ elseif (coarse_diagnostic%name .eq. 'v_dt_sg_coarse') then
+ if (.not. allocated(Atm(tile_count)%sg_diag%v_dt)) then
+ allocate(Atm(tile_count)%sg_diag%v_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%sg_diag%v_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%sg_diag%v_dt(is:ie,js:je,1:npz)
+ elseif (coarse_diagnostic%name .eq. 'qv_dt_sg_coarse') then
+ if (.not. allocated(Atm(tile_count)%sg_diag%qv_dt)) then
+ allocate(Atm(tile_count)%sg_diag%qv_dt(is:ie,js:je,1:npz))
+ Atm(tile_count)%sg_diag%qv_dt(is:ie,js:je,1:npz) = 0.0
+ endif
+ coarse_diagnostic%data%var3 => Atm(tile_count)%sg_diag%qv_dt(is:ie,js:je,1:npz)
endif
endif
end subroutine maybe_allocate_reference_array
@@ -714,16 +1186,21 @@ subroutine initialize_coarse_diagnostic_axes(coarse_domain, &
Domain2=coarse_domain, tile_count=tile_count, domain_position=NORTH)
end subroutine initialize_coarse_diagnostic_axes
- subroutine fv_coarse_diag(Atm, Time)
+ subroutine fv_coarse_diag(Atm, Time, zvir)
type(fv_atmos_type), intent(in), target :: Atm(:)
type(time_type), intent(in) :: Time
+ real, intent(in) :: 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 :: 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
integer :: index, i, j
character(len=256) :: error_message
@@ -731,6 +1208,7 @@ subroutine fv_coarse_diag(Atm, Time)
call get_need_nd_work_array(3, need_3d_work_array)
call get_need_mass_array(need_mass_array)
call get_need_height_array(need_height_array)
+ call get_need_vorticity_array(need_vorticity_array)
if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL) then
call get_need_masked_area_array(need_masked_area_array)
@@ -741,6 +1219,10 @@ subroutine fv_coarse_diag(Atm, Time)
call get_fine_array_bounds(is, ie, js, je)
call get_coarse_array_bounds(is_coarse, ie_coarse, js_coarse, je_coarse)
npz = Atm(tile_count)%npz
+ isd = Atm(tile_count)%bd%isd
+ ied = Atm(tile_count)%bd%ied
+ jsd = Atm(tile_count)%bd%jsd
+ jed = Atm(tile_count)%bd%jed
if (need_2d_work_array) then
allocate(work_2d_coarse(is_coarse:ie_coarse,js_coarse:je_coarse))
@@ -786,32 +1268,29 @@ subroutine fv_coarse_diag(Atm, Time)
if (need_height_array) then
allocate(height_on_interfaces(is:ie,js:je,1:npz+1))
- if(Atm(tile_count)%flagstruct%hydrostatic) then
- call compute_height_on_interfaces_hydrostatic( &
- is, &
- ie, &
- js, &
- je, &
- npz, &
- Atm(tile_count)%pt(is:ie,js:je,1:npz), &
- Atm(tile_count)%peln(is:ie,1:npz+1,js:je), &
- height_on_interfaces(is:ie,js:je,1:npz) &
- )
- else
- call compute_height_on_interfaces_nonhydrostatic( &
- is, &
- ie, &
- js, &
- je, &
- npz, &
- Atm(tile_count)%delz(is:ie,js:je,1:npz), &
- height_on_interfaces(is:ie,js:je,1:npz) &
- )
- endif
+ allocate(zsurf(is:ie,js:je))
+ zsurf = Atm(tile_count)%phis(is:ie,js:je) / grav
+ call get_height_field(is, ie, js, je, Atm(tile_count)%ng, npz, &
+ Atm(tile_count)%flagstruct%hydrostatic, &
+ zsurf, &
+ Atm(tile_count)%delz, &
+ height_on_interfaces, &
+ Atm(tile_count)%pt, &
+ Atm(tile_count)%q, &
+ Atm(tile_count)%peln, &
+ zvir &
+ )
if (.not. allocated(work_2d_coarse)) allocate(work_2d_coarse(is_coarse:ie_coarse,js_coarse:je_coarse))
allocate(work_2d(is:ie,js:je))
endif
+ if (need_vorticity_array) then
+ 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)
+ endif
+
do index = 1, DIAG_SIZE
if (coarse_diagnostics(index)%id .gt. 0) then
if (coarse_diagnostics(index)%axes .eq. 2) then
@@ -821,12 +1300,16 @@ subroutine fv_coarse_diag(Atm, 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, &
- coarse_diagnostics(index), Atm(tile_count)%gridstruct%area(is:ie,js:je),&
- mass, work_3d_coarse)
+ 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
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, mass, phalf, &
- upsampled_coarse_phalf, Atm(tile_count)%ptop, work_3d_coarse)
+ coarse_diagnostics(index), masked_area, mass, phalf, &
+ upsampled_coarse_phalf, Atm(tile_count)%ptop, &
+ Atm(tile_count)%omga(is:ie,js:je,1:npz),&
+ 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)
@@ -839,10 +1322,11 @@ subroutine fv_coarse_diag(Atm, Time)
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, &
- npz, coarse_diag, area, mass, result)
+ 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
real, intent(in) :: mass(is:ie,js:je,1:npz), 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
@@ -859,6 +1343,13 @@ subroutine coarse_grain_3D_field_on_model_levels(is, ie, js, je, is_coarse, ie_c
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_on_model_levels: invalid reduction_method, ' // &
trim(coarse_diag%reduction_method) // ', provided for 3D variable, ' // &
@@ -868,26 +1359,36 @@ subroutine coarse_grain_3D_field_on_model_levels(is, ie, js, je, is_coarse, ie_c
end subroutine coarse_grain_3D_field_on_model_levels
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, masked_mass, phalf, upsampled_coarse_phalf, &
- ptop, result)
+ npz, coarse_diag, masked_area, masked_mass, phalf, upsampled_coarse_phalf, &
+ ptop, 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) :: masked_mass(is:ie,js:je,1:npz), 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(out) :: result(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
- real, allocatable :: remapped_field(:,:,:)
+ real, allocatable, dimension(:,:,:) :: remapped_field, remapped_omega
character(len=256) :: error_message
allocate(remapped_field(is:ie,js:je,1:npz))
-
call vertically_remap_field( &
phalf, &
coarse_diag%data%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( &
+ phalf, &
+ omega, &
+ upsampled_coarse_phalf, &
+ ptop, &
+ remapped_omega)
+ endif
+
if (trim(coarse_diag%reduction_method) .eq. AREA_WEIGHTED) then
call weighted_block_average( &
masked_area(is:ie,js:je,1:npz), &
@@ -900,6 +1401,13 @@ subroutine coarse_grain_3D_field_on_pressure_levels(is, ie, js, je, is_coarse, i
remapped_field(is:ie,js:je,1:npz), &
result &
)
+ elseif (trim(coarse_diag%reduction_method) .eq. EDDY_COVARIANCE) then
+ 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), &
+ result &
+ )
else
write(error_message, *) 'coarse_grain_3D_field_on_pressure_levels: invalid reduction_method, ' // &
trim(coarse_diag%reduction_method) // ', provided for 3D variable, ' // &
@@ -916,18 +1424,23 @@ subroutine coarse_grain_2D_field(is, ie, js, je, npz, is_coarse, ie_coarse, js_c
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)
+ integer :: nwat
character(len=256) :: error_message
real, allocatable :: work_2d(:,:)
+ nwat = Atm%flagstruct%nwat
+
if (coarse_diag%pressure_level > 0 .or. coarse_diag%vertically_integrated &
- .or. coarse_diag%scaled_by_specific_heat_and_vertically_integrated) then
+ .or. coarse_diag%scaled_by_specific_heat_and_vertically_integrated &
+ .or. coarse_diag%special_case .ne. '') then
allocate(work_2d(is:ie,js:je))
endif
if (trim(coarse_diag%reduction_method) .eq. AREA_WEIGHTED) then
if (coarse_diag%pressure_level < 0 &
.and. .not. coarse_diag%vertically_integrated &
- .and. .not. coarse_diag%scaled_by_specific_heat_and_vertically_integrated) then
+ .and. .not. coarse_diag%scaled_by_specific_heat_and_vertically_integrated &
+ .and. coarse_diag%special_case .eq. '') then
call weighted_block_average( &
Atm%gridstruct%area(is:ie,js:je), &
coarse_diag%data%var2, &
@@ -950,7 +1463,75 @@ subroutine coarse_grain_2D_field(is, ie, js, je, npz, is_coarse, ie_coarse, js_c
work_2d, &
result &
)
- elseif (coarse_diag%vertically_integrated) then
+ elseif (trim(coarse_diag%special_case) .eq. 'vorticity') then
+ call interpolate_vertical( &
+ is, &
+ ie, &
+ js, &
+ je, &
+ npz, &
+ 100.0 * coarse_diag%pressure_level, & ! Convert mb to Pa
+ Atm%peln(is:ie,1:npz+1,js:je), &
+ coarse_diag%data%var3, &
+ work_2d(is:ie,js:je) &
+ )
+ call weighted_block_average( &
+ Atm%gridstruct%area(is:ie,js:je), &
+ work_2d, &
+ result &
+ )
+ elseif (trim(coarse_diag%special_case) .eq. 'tq') then
+ call total_water_path( &
+ is, &
+ ie, &
+ js, &
+ je, &
+ npz, &
+ nwat, &
+ Atm%q(is:ie,js:je,1:npz,1:nwat), &
+ Atm%delp(is:ie,js:je,1:npz), &
+ work_2d(is:ie,js:je) &
+ )
+ call weighted_block_average( &
+ Atm%gridstruct%area(is:ie,js:je), &
+ work_2d, &
+ result &
+ )
+ elseif (trim(coarse_diag%special_case) .eq. 'lw') then
+ call liquid_water_path( &
+ is, &
+ ie, &
+ js, &
+ je, &
+ npz, &
+ nwat, &
+ Atm%q(is:ie,js:je,1:npz,1:nwat), &
+ Atm%delp(is:ie,js:je,1:npz), &
+ work_2d(is:ie,js:je) &
+ )
+ call weighted_block_average( &
+ Atm%gridstruct%area(is:ie,js:je), &
+ work_2d, &
+ result &
+ )
+ elseif (trim(coarse_diag%special_case) .eq. 'iw') then
+ call ice_water_path( &
+ is, &
+ ie, &
+ js, &
+ je, &
+ npz, &
+ nwat, &
+ Atm%q(is:ie,js:je,1:npz,1:nwat), &
+ Atm%delp(is:ie,js:je,1:npz), &
+ work_2d(is:ie,js:je) &
+ )
+ call weighted_block_average( &
+ Atm%gridstruct%area(is:ie,js:je), &
+ work_2d, &
+ result &
+ )
+ elseif (coarse_diag%vertically_integrated) then
call vertically_integrate( &
is, &
ie, &
@@ -1057,22 +1638,53 @@ subroutine get_need_height_array(need_height_array)
enddo
end subroutine get_need_height_array
+ subroutine get_need_vorticity_array(need_vorticity_array)
+ logical, intent(out) :: need_vorticity_array
+
+ integer :: index
+
+ need_vorticity_array = .false.
+ do index = 1, DIAG_SIZE
+ if (trim(coarse_diagnostics(index)%special_case) .eq. 'vorticity' .and. &
+ coarse_diagnostics(index)%id .gt. 0) then
+ need_vorticity_array = .true.
+ exit
+ endif
+ enddo
+ end subroutine get_need_vorticity_array
+
subroutine get_need_masked_area_array(need_masked_area_array)
logical, intent(out) :: need_masked_area_array
+ logical :: valid_axes, valid_reduction_method, valid_id
integer :: index
need_masked_area_array = .false.
do index = 1, DIAG_SIZE
- if ((coarse_diagnostics(index)%axes == 3) .and. &
- (trim(coarse_diagnostics(index)%reduction_method) .eq. AREA_WEIGHTED) .and. &
- (coarse_diagnostics(index)%id > 0)) then
- need_masked_area_array = .true.
- exit
- endif
+ valid_reduction_method = &
+ trim(coarse_diagnostics(index)%reduction_method) .eq. AREA_WEIGHTED .or. &
+ trim(coarse_diagnostics(index)%reduction_method) .eq. EDDY_COVARIANCE
+ valid_axes = coarse_diagnostics(index)%axes .eq. 3
+ valid_id = coarse_diagnostics(index)%id .gt. 0
+ need_masked_area_array = valid_reduction_method .and. valid_axes .and. valid_id
+ if (need_masked_area_array) exit
enddo
end subroutine get_need_masked_area_array
+ subroutine associate_vorticity_pointers(is, ie, js, je, npz, vorticity)
+ integer, intent(in) :: is, ie, js, je, npz
+ real, target, intent(in) :: vorticity(is:ie,js:je,1:npz)
+
+ 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
+
subroutine compute_mass(Atm, is, ie, js, je, npz, mass)
type(fv_atmos_type), intent(in) :: Atm
integer, intent(in) :: is, ie, js, je, npz
@@ -1103,43 +1715,6 @@ subroutine interpolate_to_pressure_level(is, ie, js, je, npz, field, height, pha
result = work(is:ie,js:je,1)
end subroutine interpolate_to_pressure_level
- subroutine compute_height_on_interfaces_hydrostatic(is, ie, js, je, npz, temperature, phalf, height)
- integer, intent(in) :: is, ie, js, je, npz
- real, intent(in) :: temperature(is:ie,js:je,1:npz), phalf(is:ie,1:npz+1,js:je)
- real, intent(out) :: height(is:ie,js:je,1:npz+1)
-
- integer :: i, j, k
- real :: rgrav
-
- rgrav = 1.0 / grav
-
- do j = js, je
- do i = is, ie
- height(i,j,npz+1) = 0.0
- do k = npz, 1, -1
- height(i,j,k) = height(i,j,k+1) - (rdgas / grav) * temperature(i,j,k) * (phalf(i,k,j) - phalf(i,k+1,j))
- enddo
- enddo
- enddo
- end subroutine compute_height_on_interfaces_hydrostatic
-
- subroutine compute_height_on_interfaces_nonhydrostatic(is, ie, js, je, npz, delz, height)
- integer, intent(in) :: is, ie, js, je, npz
- real, intent(in) :: delz(is:ie,js:je,1:npz)
- real, intent(out) :: height(is:ie,js:je,1:npz+1)
-
- integer :: i, j, k
-
- do j = js, je
- do i = is, ie
- height(i,j,npz+1) = 0.0
- do k = npz, 1, -1
- height(i,j,k) = height(i,j,k+1) - delz(i,j,k)
- enddo
- enddo
- enddo
- end subroutine compute_height_on_interfaces_nonhydrostatic
-
subroutine height_given_pressure_level(is, ie, js, je, npz, height, phalf, pressure_level, result)
integer, intent(in) :: is, ie, js, je, npz, pressure_level
real, intent(in) :: height(is:ie,js:je,1:npz+1), phalf(is:ie,1:npz+1,js:je)
@@ -1158,7 +1733,7 @@ subroutine height_given_pressure_level(is, ie, js, je, npz, height, phalf, press
end subroutine height_given_pressure_level
function starts_with(string, prefix)
- character(len=64), intent(in) :: string, prefix
+ character(len=128), intent(in) :: string, prefix
logical :: starts_with
starts_with = string(1:len(trim(prefix))) .eq. trim(prefix)
@@ -1166,7 +1741,7 @@ function starts_with(string, prefix)
end function starts_with
function ends_with(string, suffix)
- character(len=64), intent(in) :: string
+ character(len=128), intent(in) :: string
character(len=*), intent(in) :: suffix
logical :: ends_with
@@ -1362,4 +1937,100 @@ subroutine compute_grid_coarse(is, ie, js, je, is_coarse, ie_coarse, &
factor = Atm(tile_count)%coarse_graining%factor
grid_coarse = Atm(tile_count)%gridstruct%grid(is:ie+1:factor,js:je+1:factor,:)
end subroutine compute_grid_coarse
+
+ subroutine get_height_field(is, ie, js, je, ng, km, hydrostatic, zsurf, 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)
+ real, intent(in):: pt(is-ng:ie+ng,js-ng:je+ng,km)
+ real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) ! water vapor
+ real, intent(in):: delz(is:,js:,1:)
+ real, intent(in):: zvir
+ logical, intent(in):: hydrostatic
+ real, intent(in) :: zsurf(is:ie,js:je)
+ real, intent(out):: wz(is:ie,js:je,km+1)
+!
+ integer i,j,k, sphum
+ real gg
+
+ sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
+ gg = rdgas / grav
+
+ do j=js,je
+ do i=is,ie
+ wz(i,j,km+1) = zsurf(i,j)
+ enddo
+ if (hydrostatic ) then
+ do k=km,1,-1
+ do i=is,ie
+ wz(i,j,k) = wz(i,j,k+1) + gg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum)) &
+ *(peln(i,k+1,j)-peln(i,k,j))
+ enddo
+ enddo
+ else
+ do k=km,1,-1
+ do i=is,ie
+ wz(i,j,k) = wz(i,j,k+1) - delz(i,j,k)
+ enddo
+ enddo
+ endif
+ enddo
+
+ end subroutine get_height_field
+
+ subroutine total_water_path(is, ie, js, je, npz, nwat, q, delp, tq)
+ 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)
+ real, intent(out) :: tq(is:ie,js:je)
+
+ real :: ginv
+
+ ginv = 1. / GRAV
+ tq = ginv * sum(sum(q, 4) * delp, 3)
+ end subroutine total_water_path
+
+ subroutine liquid_water_path(is, ie, js, je, npz, nwat, q, delp, lw)
+ 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)
+ real, intent(out) :: lw(is:ie,js:je)
+
+ integer :: liq_wat, rainwat
+ real :: ginv
+
+ liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat')
+ rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
+
+ ginv = 1. / GRAV
+ lw = 0.0
+ if (liq_wat .gt. 0) then
+ lw = lw + ginv * sum(q(is:ie,js:je,1:npz,liq_wat) * delp(is:ie,js:je,1:npz), 3)
+ endif
+ if (rainwat .gt. 0) then
+ lw = lw + ginv * sum(q(is:ie,js:je,1:npz,rainwat) * delp(is:ie,js:je,1:npz), 3)
+ endif
+ end subroutine liquid_water_path
+
+ subroutine ice_water_path(is, ie, js, je, npz, nwat, q, delp, iw)
+ 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)
+ real, intent(out) :: iw(is:ie,js:je)
+
+ integer :: ice_wat, snowwat, graupel
+ real :: ginv
+
+ ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat')
+ snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
+ graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
+
+ ginv = 1. / GRAV
+ iw = 0.0
+ if (ice_wat .gt. 0) then
+ iw = iw + ginv * sum(q(is:ie,js:je,1:npz,ice_wat) * delp(is:ie,js:je,1:npz), 3)
+ endif
+ if (snowwat .gt. 0) then
+ iw = iw + ginv * sum(q(is:ie,js:je,1:npz,snowwat) * delp(is:ie,js:je,1:npz), 3)
+ endif
+ if (graupel .gt. 0) then
+ 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
end module coarse_grained_diagnostics_mod
diff --git a/tools/coarse_grained_restart_files.F90 b/tools/coarse_grained_restart_files.F90
index ce6297752..15d3ed51b 100644
--- a/tools/coarse_grained_restart_files.F90
+++ b/tools/coarse_grained_restart_files.F90
@@ -1,3 +1,24 @@
+!***********************************************************************
+!* 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 coarse_grained_restart_files_mod
use coarse_graining_mod, only: compute_mass_weights, get_coarse_array_bounds,&
@@ -7,7 +28,7 @@ module coarse_grained_restart_files_mod
remap_edges_along_y, vertically_remap_field
use constants_mod, only: GRAV, RDGAS, RVGAS
use field_manager_mod, only: MODEL_ATMOS
- use fms2_io_mod, only: register_restart_field, write_restart, open_file, close_file
+ use fms2_io_mod, only: register_restart_field, write_restart, open_file, close_file, register_variable_attribute, variable_exists
use fv_arrays_mod, only: coarse_restart_type, fv_atmos_type
use mpp_domains_mod, only: domain2d, EAST, NORTH, CENTER, mpp_update_domains
use mpp_mod, only: FATAL, mpp_error
@@ -210,34 +231,78 @@ subroutine register_fv_core_coarse(hydrostatic, hybrid_z, &
if (write_coarse_dgrid_vel_rst) then
call register_restart_field(restart%fv_core_coarse, &
'u', restart%u, dim_names_4d)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'u', "long_name", "u", str_len=len("u"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'u', "units", "none", str_len=len("none"))
call register_restart_field(restart%fv_core_coarse, &
'v', restart%v, dim_names_4d2)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'v', "long_name", "v", str_len=len("v"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'v', "units", "none", str_len=len("none"))
endif
if (write_coarse_agrid_vel_rst) then
call register_restart_field(restart%fv_core_coarse, &
'ua', restart%ua, dim_names_4d3)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'ua', "long_name", "ua", str_len=len("ua"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'ua', "units", "none", str_len=len("none"))
call register_restart_field(restart%fv_core_coarse, &
'va', restart%va, dim_names_4d3)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'va', "long_name", "va", str_len=len("va"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'va', "units", "none", str_len=len("none"))
endif
if (.not. hydrostatic) then
call register_restart_field(restart%fv_core_coarse, &
'W', restart%w, dim_names_4d3, is_optional=.true.)
+ if (variable_exists(restart%fv_core_coarse, 'W')) then
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'W', "long_name", "W", str_len=len("W"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'W', "units", "none", str_len=len("none"))
+ endif
call register_restart_field(restart%fv_core_coarse, &
'DZ', restart%delz, dim_names_4d3, is_optional=.true.)
+ if (variable_exists(restart%fv_core_coarse, 'DZ')) then
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'DZ', "long_name", "DZ", str_len=len("DZ"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'DZ', "units", "none", str_len=len("none"))
+ endif
if (hybrid_z) then
call register_restart_field(restart%fv_core_coarse, &
'ZE0', restart%ze0, dim_names_4d3, is_optional=.false.)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'ZE0', "long_name", "ZE0", str_len=len("ZE0"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'ZE0', "units", "none", str_len=len("none"))
endif
endif
call register_restart_field(restart%fv_core_coarse, &
'T', restart%pt, dim_names_4d3)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'T', "long_name", "T", str_len=len("T"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'T', "units", "none", str_len=len("none"))
call register_restart_field(restart%fv_core_coarse, &
'delp', restart%delp, dim_names_4d3)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'delp', "long_name", "delp", str_len=len("delp"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'delp', "units", "none", str_len=len("none"))
call register_restart_field(restart%fv_core_coarse, &
'phis', restart%phis, dim_names_3d)
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'phis', "long_name", "phis", str_len=len("phis"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'phis', "units", "none", str_len=len("none"))
endif
end subroutine register_fv_core_coarse
@@ -274,6 +339,12 @@ subroutine register_fv_tracer_coarse(coarse_domain, restart, timestamp)
call register_restart_field(restart%fv_tracer_coarse, &
tracer_name, restart%q(:,:,:,n_tracer), dim_names_4d, &
is_optional=.true.)
+ if (variable_exists(restart%fv_tracer_coarse, tracer_name)) then
+ call register_variable_attribute(restart%fv_tracer_coarse, &
+ tracer_name, "long_name", tracer_name, str_len=len(tracer_name))
+ call register_variable_attribute(restart%fv_tracer_coarse, &
+ tracer_name, "units", "none", str_len=len("none"))
+ endif
enddo
do n_tracer = n_prognostic_tracers + 1, n_tracers
@@ -282,6 +353,12 @@ subroutine register_fv_tracer_coarse(coarse_domain, restart, timestamp)
call register_restart_field(restart%fv_tracer_coarse, &
tracer_name, restart%qdiag(:,:,:,n_tracer), dim_names_4d, &
is_optional=.true.)
+ if (variable_exists(restart%fv_tracer_coarse, tracer_name)) then
+ call register_variable_attribute(restart%fv_tracer_coarse, &
+ tracer_name, "long_name", tracer_name, str_len=len(tracer_name))
+ call register_variable_attribute(restart%fv_tracer_coarse, &
+ tracer_name, "units", "none", str_len=len("none"))
+ endif
enddo
endif
end subroutine register_fv_tracer_coarse
@@ -311,8 +388,16 @@ subroutine register_fv_srf_wnd_coarse(coarse_domain, restart, timestamp)
call register_restart_field(restart%fv_srf_wnd_coarse, &
'u_srf', restart%u_srf, dim_names_3d)
+ call register_variable_attribute(restart%fv_srf_wnd_coarse, &
+ 'u_srf', "long_name", "u_srf", str_len=len("u_srf"))
+ call register_variable_attribute(restart%fv_srf_wnd_coarse, &
+ 'u_srf', "units", "none", str_len=len("none"))
call register_restart_field(restart%fv_srf_wnd_coarse, &
'v_srf', restart%v_srf, dim_names_3d)
+ call register_variable_attribute(restart%fv_srf_wnd_coarse, &
+ 'v_srf', "long_name", "v_srf", str_len=len("v_srf"))
+ call register_variable_attribute(restart%fv_srf_wnd_coarse, &
+ 'v_srf', "units", "none", str_len=len("none"))
endif
end subroutine register_fv_srf_wnd_coarse
@@ -341,6 +426,10 @@ subroutine register_mg_drag_coarse(coarse_domain, restart, timestamp)
call register_restart_field(restart%mg_drag_coarse, &
'ghprime', restart%sgh, dim_names_3d)
+ call register_variable_attribute(restart%mg_drag_coarse, &
+ 'ghprime', "long_name", "ghprime", str_len=len("ghprime"))
+ call register_variable_attribute(restart%mg_drag_coarse, &
+ 'ghprime', "units", "none", str_len=len("none"))
endif
end subroutine register_mg_drag_coarse
@@ -369,6 +458,10 @@ subroutine register_fv_land_coarse(coarse_domain, restart, timestamp)
call register_restart_field(restart%fv_land_coarse, &
'oro', restart%oro, dim_names_3d)
+ call register_variable_attribute(restart%fv_land_coarse, &
+ 'oro', "long_name", "oro", str_len=len("oro"))
+ call register_variable_attribute(restart%fv_core_coarse, &
+ 'oro', "units", "none", str_len=len("none"))
endif
end subroutine register_fv_land_coarse
diff --git a/tools/coarse_graining.F90 b/tools/coarse_graining.F90
index 4584d4f0e..97bb2f6b4 100644
--- a/tools/coarse_graining.F90
+++ b/tools/coarse_graining.F90
@@ -1,9 +1,30 @@
+!***********************************************************************
+!* 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 coarse_graining_mod
- use fms_mod, only: check_nml_error
+ use fms_mod, only: check_nml_error, close_file, open_namelist_file
use mpp_domains_mod, only: domain2d, mpp_define_io_domain, mpp_define_mosaic, mpp_get_compute_domain
- use fv_mapz_mod, only: mappm
use mpp_mod, only: FATAL, input_nml_file, mpp_error, mpp_npes
+ use statistics_mod, only: mode
implicit none
private
@@ -13,10 +34,14 @@ module coarse_graining_mod
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, mask_mass_weights, remap_edges_along_x, remap_edges_along_y, &
- block_edge_sum_x, block_edge_sum_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
interface block_sum
- module procedure block_sum_2d
+ module procedure block_sum_2d_real4
+ module procedure block_sum_2d_real8
+ module procedure masked_block_sum_2d_real4
+ module procedure masked_block_sum_2d_real8
end interface block_sum
interface block_edge_sum_x
@@ -28,9 +53,16 @@ module coarse_graining_mod
end interface block_edge_sum_y
interface weighted_block_average
- module procedure weighted_block_average_2d
- module procedure weighted_block_average_3d_field_2d_weights
- module procedure weighted_block_average_3d_field_3d_weights
+ module procedure weighted_block_average_2d_real4
+ module procedure weighted_block_average_2d_real8
+ module procedure masked_weighted_block_average_2d_real4
+ module procedure masked_weighted_block_average_2d_real8
+ module procedure masked_weighted_block_average_3d_field_2d_weights_real4
+ module procedure masked_weighted_block_average_3d_field_2d_weights_real8
+ module procedure weighted_block_average_3d_field_2d_weights_real4
+ module procedure weighted_block_average_3d_field_2d_weights_real8
+ module procedure weighted_block_average_3d_field_3d_weights_real4
+ module procedure weighted_block_average_3d_field_3d_weights_real8
end interface weighted_block_average
interface weighted_block_edge_average_x
@@ -44,8 +76,10 @@ module coarse_graining_mod
end interface weighted_block_edge_average_y
interface block_upsample
- module procedure block_upsample_2d
- module procedure block_upsample_3d
+ module procedure block_upsample_2d_real4
+ module procedure block_upsample_3d_real4
+ module procedure block_upsample_2d_real8
+ module procedure block_upsample_3d_real8
end interface block_upsample
interface weighted_block_edge_average_x_pre_downsampled
@@ -58,12 +92,83 @@ module coarse_graining_mod
module procedure weighted_block_edge_average_y_pre_downsampled_masked
end interface weighted_block_edge_average_y_pre_downsampled
+ interface eddy_covariance
+ 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
+ module procedure block_mode_2d_real8
+ module procedure masked_block_mode_2d_real8
+ end interface block_mode
+
+ interface block_min
+ module procedure masked_block_min_2d_real4
+ module procedure masked_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
+ end interface vertical_remapping_requirements
+
+ interface compute_phalf_from_delp
+ module procedure compute_phalf_from_delp_real4
+ module procedure compute_phalf_from_delp_real8
+ end interface compute_phalf_from_delp
+
+ interface mask_area_weights
+ module procedure mask_area_weights_real4
+ module procedure mask_area_weights_real8
+ end interface mask_area_weights
+
+ interface vertically_remap_field
+ module procedure vertically_remap_field_real4
+ module procedure vertically_remap_field_real8
+ end interface vertically_remap_field
+
+ interface mappm
+ module procedure mappm_real4
+ module procedure mappm_real8
+ end interface mappm
+
+ interface cs_profile
+ module procedure cs_profile_real4
+ module procedure cs_profile_real8
+ end interface cs_profile
+
+ interface cs_limiters
+ module procedure cs_limiters_real4
+ module procedure cs_limiters_real8
+ end interface cs_limiters
+
+ interface ppm_profile
+ module procedure ppm_profile_real4
+ module procedure ppm_profile_real8
+ end interface ppm_profile
+
+ interface ppm_limiters
+ module procedure ppm_limiters_real4
+ module procedure ppm_limiters_real8
+ end interface ppm_limiters
+
! 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
+ 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
@@ -112,12 +217,6 @@ subroutine compute_nx_coarse(npx, coarsening_factor, nx_coarse)
integer :: nx
nx = npx - 1
-
- if (coarsening_factor < 1) then
- write(error_message, *) 'Invalid coarsening_factor chosen'
- call mpp_error(FATAL, error_message)
- endif
-
if (mod(nx, coarsening_factor) > 0) then
write(error_message, *) 'coarse_graining_init: coarsening_factor does not evenly divide the native resolution.'
call mpp_error(FATAL, error_message)
@@ -190,9 +289,9 @@ subroutine compute_mass_weights(area, delp, mass)
enddo
end subroutine compute_mass_weights
- subroutine block_sum_2d(fine, coarse)
- real, intent(in) :: fine(is:ie,js:je)
- real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
+ subroutine block_sum_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
@@ -204,45 +303,194 @@ subroutine block_sum_2d(fine, coarse)
coarse(i_coarse,j_coarse) = sum(fine(i:i+offset,j:j+offset))
enddo
enddo
- end subroutine
+ end subroutine block_sum_2d_real4
- subroutine weighted_block_average_2d(weights, fine, coarse)
- real, intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je)
- real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
+ subroutine block_sum_2d_real8(fine, coarse)
+ real(kind=8), intent(in) :: fine(is:ie,js:je)
+ real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
- real, allocatable :: weighted_fine(:,:), weighted_block_sum(:,:), block_sum_weights(:,:)
+ integer :: i, j, i_coarse, 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) = sum(fine(i:i+offset,j:j+offset))
+ enddo
+ enddo
+ end subroutine block_sum_2d_real8
+
+ subroutine masked_block_sum_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)
+
+ integer :: i, j, i_coarse, 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) = sum(fine(i:i+offset,j:j+offset), mask=mask(i:i+offset,j:j+offset))
+ enddo
+ enddo
+ end subroutine masked_block_sum_2d_real4
+
+ subroutine masked_block_sum_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)
+
+ integer :: i, j, i_coarse, 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) = sum(fine(i:i+offset,j:j+offset), mask=mask(i:i+offset,j:j+offset))
+ enddo
+ enddo
+ end subroutine masked_block_sum_2d_real8
+
+ subroutine weighted_block_average_2d_real4(weights, fine, coarse)
+ real(kind=4), intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je)
+ real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
+
+ real(kind=4), allocatable :: weighted_fine(:,:), weighted_block_sum(:,:), block_sum_weights(:,:)
allocate(weighted_fine(is:ie,js:je))
allocate(weighted_block_sum(is_coarse:ie_coarse,js_coarse:je_coarse))
allocate(block_sum_weights(is_coarse:ie_coarse,js_coarse:je_coarse))
weighted_fine = weights * fine
- call block_sum_2d(weighted_fine, weighted_block_sum)
- call block_sum_2d(weights, block_sum_weights)
+ call block_sum_2d_real4(weighted_fine, weighted_block_sum)
+ call block_sum_2d_real4(weights, block_sum_weights)
coarse = weighted_block_sum / block_sum_weights
- end subroutine weighted_block_average_2d
+ end subroutine weighted_block_average_2d_real4
- subroutine weighted_block_average_3d_field_2d_weights(weights, fine, coarse)
- real, intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je,1:npz)
- real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
+ subroutine weighted_block_average_2d_real8(weights, fine, coarse)
+ real(kind=8), intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je)
+ real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
+
+ real(kind=8), allocatable :: weighted_fine(:,:), weighted_block_sum(:,:), block_sum_weights(:,:)
+
+ allocate(weighted_fine(is:ie,js:je))
+ allocate(weighted_block_sum(is_coarse:ie_coarse,js_coarse:je_coarse))
+ allocate(block_sum_weights(is_coarse:ie_coarse,js_coarse:je_coarse))
+
+ weighted_fine = weights * fine
+ call block_sum_2d_real8(weighted_fine, weighted_block_sum)
+ call block_sum_2d_real8(weights, block_sum_weights)
+ coarse = weighted_block_sum / block_sum_weights
+ end subroutine weighted_block_average_2d_real8
+
+ subroutine masked_weighted_block_average_2d_real4(weights, fine, mask, coarse)
+ real(kind=4), intent(in) :: weights(is:ie,js:je), 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)
+
+ real(kind=4), allocatable :: weighted_fine(:,:), weighted_block_sum(:,:), block_sum_weights(:,:)
+
+ allocate(weighted_fine(is:ie,js:je))
+ allocate(weighted_block_sum(is_coarse:ie_coarse,js_coarse:je_coarse))
+ allocate(block_sum_weights(is_coarse:ie_coarse,js_coarse:je_coarse))
+
+ weighted_fine = weights * fine
+ call masked_block_sum_2d_real4(weighted_fine, mask, weighted_block_sum)
+ call masked_block_sum_2d_real4(weights, mask, block_sum_weights)
+ coarse = weighted_block_sum / block_sum_weights
+ end subroutine masked_weighted_block_average_2d_real4
+
+ subroutine masked_weighted_block_average_2d_real8(weights, fine, mask, coarse)
+ real(kind=8), intent(in) :: weights(is:ie,js:je), 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)
+
+ real(kind=8), allocatable :: weighted_fine(:,:), weighted_block_sum(:,:), block_sum_weights(:,:)
+
+ allocate(weighted_fine(is:ie,js:je))
+ allocate(weighted_block_sum(is_coarse:ie_coarse,js_coarse:je_coarse))
+ allocate(block_sum_weights(is_coarse:ie_coarse,js_coarse:je_coarse))
+
+ weighted_fine = weights * fine
+ call masked_block_sum_2d_real8(weighted_fine, mask, weighted_block_sum)
+ call masked_block_sum_2d_real8(weights, mask, block_sum_weights)
+ coarse = weighted_block_sum / block_sum_weights
+ end subroutine masked_weighted_block_average_2d_real8
+
+ subroutine masked_weighted_block_average_3d_field_2d_weights_real4(weights, fine, mask, nz, coarse)
+ real(kind=4), intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je,1:nz)
+ logical, intent(in) :: mask(is:ie,js:je)
+ integer, intent(in) :: nz
+ real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:nz)
+
+ integer :: k
+
+ 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
+ end subroutine masked_weighted_block_average_3d_field_2d_weights_real4
+
+ subroutine masked_weighted_block_average_3d_field_2d_weights_real8(weights, fine, mask, nz, coarse)
+ real(kind=8), intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je,1:nz)
+ logical, intent(in) :: mask(is:ie,js:je)
+ integer, intent(in) :: nz
+ real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:nz)
+
+ integer :: k
+
+ 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
+ end subroutine masked_weighted_block_average_3d_field_2d_weights_real8
+
+ subroutine weighted_block_average_3d_field_2d_weights_real4(weights, fine, coarse)
+ real(kind=4), intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je,1:npz)
+ real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
integer :: k
do k = 1, npz
- call weighted_block_average_2d(weights, fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k))
+ call weighted_block_average_2d_real4(weights, fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k))
enddo
- end subroutine weighted_block_average_3d_field_2d_weights
+ end subroutine weighted_block_average_3d_field_2d_weights_real4
- subroutine weighted_block_average_3d_field_3d_weights(weights, fine, coarse)
- real, intent(in) :: weights(is:ie,js:je,1:npz), fine(is:ie,js:je,1:npz)
- real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
+ subroutine weighted_block_average_3d_field_2d_weights_real8(weights, fine, coarse)
+ real(kind=8), intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je,1:npz)
+ real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
+
+ integer :: k
+
+ 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
+ end subroutine weighted_block_average_3d_field_2d_weights_real8
+
+ subroutine weighted_block_average_3d_field_3d_weights_real4(weights, fine, coarse)
+ real(kind=4), intent(in) :: weights(is:ie,js:je,1:npz), fine(is:ie,js:je,1:npz)
+ real(kind=4), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
+
+ integer :: k
+
+ 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
+ end subroutine weighted_block_average_3d_field_3d_weights_real4
+
+ subroutine weighted_block_average_3d_field_3d_weights_real8(weights, fine, coarse)
+ real(kind=8), intent(in) :: weights(is:ie,js:je,1:npz), fine(is:ie,js:je,1:npz)
+ real(kind=8), intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
integer :: k
do k = 1, npz
- call weighted_block_average_2d(weights(is:ie,js:je,k), fine(is:ie,js:je,k), coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k))
+ 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
- end subroutine weighted_block_average_3d_field_3d_weights
+ end subroutine weighted_block_average_3d_field_3d_weights_real8
+
subroutine block_edge_sum_x_2d(fine, coarse)
real, intent(in) :: fine(is:ie,js_coarse:je_coarse+1)
@@ -334,11 +582,167 @@ subroutine weighted_block_edge_average_y_3d_field_2d_weights(weights, fine, coar
enddo
end subroutine weighted_block_edge_average_y_3d_field_2d_weights
- subroutine vertically_remap_field(phalf_in, field, phalf_out, ptop, field_out)
- real, intent(in) :: phalf_in(is:ie,js:je,1:npz+1), phalf_out(is:ie,js:je,1:npz+1)
- real, intent(in) :: field(is:ie,js:je,1:npz)
- real, intent(in) :: ptop
- real, intent(out) :: field_out(is:ie,js:je,1:npz)
+ subroutine block_mode_2d_real8(fine, coarse)
+ real(kind=8), intent(in) :: fine(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
+ 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) = mode(fine(i:i+offset,j:j+offset))
+ enddo
+ enddo
+ end subroutine block_mode_2d_real8
+
+ subroutine masked_block_mode_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)
+
+ integer :: i, j, i_coarse, 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) = mode(fine(i:i+offset,j:j+offset), mask(i:i+offset,j:j+offset))
+ enddo
+ enddo
+ end subroutine masked_block_mode_2d_real8
+
+ subroutine block_mode_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
+ 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) = mode(fine(i:i+offset,j:j+offset))
+ enddo
+ enddo
+ end subroutine block_mode_2d_real4
+
+ subroutine masked_block_mode_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)
+
+ integer :: i, j, i_coarse, 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) = mode(fine(i:i+offset,j:j+offset), mask(i:i+offset,j:j+offset))
+ enddo
+ 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)
+
+ integer :: i, j, i_coarse, 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) = minval(fine(i:i+offset,j:j+offset), mask=mask(i:i + offset,j:j + offset))
+ enddo
+ enddo
+ end subroutine masked_block_min_2d_real8
+
+ subroutine masked_block_max_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)
+
+ integer :: i, j, i_coarse, 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
+ enddo
+ end subroutine masked_block_max_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)
+
+ integer :: i, j, i_coarse, 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) = minval(fine(i:i+offset,j:j+offset), mask=mask(i:i + offset,j:j + offset))
+ 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)
+
+ integer :: i, j, i_coarse, 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
+ enddo
+ end subroutine masked_block_max_2d_real4
+
+ 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)
+ real(kind=4), intent(in) :: ptop
+ real(kind=4), intent(out) :: field_out(is:ie,js:je,1:npz)
+
+ integer :: kn, km, kord, iv, j, q2
+
+ kn = npz
+ km = npz
+
+ ! Hard code values of kord and iv for now
+ kord = 1
+ iv = 1
+ q2 = 1
+
+ do j = js, je
+ call mappm(km, phalf_in(is:ie,j,:), field(is:ie,j,:), kn, &
+ phalf_out(is:ie,j,:), field_out(is:ie,j,:), is, ie, iv, kord, ptop)
+ enddo
+ end subroutine vertically_remap_field_real4
+
+ subroutine vertically_remap_field_real8(phalf_in, field, phalf_out, ptop, field_out)
+ real(kind=8), intent(in) :: phalf_in(is:ie,js:je,1:npz+1), phalf_out(is:ie,js:je,1:npz+1)
+ real(kind=8), intent(in) :: field(is:ie,js:je,1:npz)
+ real(kind=8), intent(in) :: ptop
+ real(kind=8), intent(out) :: field_out(is:ie,js:je,1:npz)
integer :: kn, km, kord, iv, j, q2
@@ -354,11 +758,39 @@ subroutine vertically_remap_field(phalf_in, field, phalf_out, ptop, field_out)
call mappm(km, phalf_in(is:ie,j,:), field(is:ie,j,:), kn, &
phalf_out(is:ie,j,:), field_out(is:ie,j,:), is, ie, iv, kord, ptop)
enddo
- end subroutine vertically_remap_field
+ end subroutine vertically_remap_field_real8
+
+ subroutine block_upsample_2d_real4(coarse, fine)
+ real(kind=4), intent(in) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
+ real(kind=4), intent(out) :: fine(is:ie,js:je)
+
+ integer :: i, j, i_coarse, 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
+ fine(i:i+offset,j:j+offset) = coarse(i_coarse, j_coarse)
+ enddo
+ enddo
+ end subroutine block_upsample_2d_real4
+
+ subroutine block_upsample_3d_real4(coarse, fine, nz)
+ integer, intent(in) :: nz
+ real(kind=4), intent(in) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:nz)
+ real(kind=4), intent(out) :: fine(is:ie,js:je,1:nz)
+
+ integer :: k
+
+ 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
+ end subroutine block_upsample_3d_real4
- subroutine block_upsample_2d(coarse, fine)
- real, intent(in) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
- real, intent(out) :: fine(is:ie,js:je)
+ subroutine block_upsample_2d_real8(coarse, fine)
+ real(kind=8), intent(in) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse)
+ real(kind=8), intent(out) :: fine(is:ie,js:je)
integer :: i, j, i_coarse, j_coarse, offset
@@ -370,19 +802,19 @@ subroutine block_upsample_2d(coarse, fine)
fine(i:i+offset,j:j+offset) = coarse(i_coarse, j_coarse)
enddo
enddo
- end subroutine block_upsample_2d
+ end subroutine block_upsample_2d_real8
- subroutine block_upsample_3d(coarse, fine, nz)
+ subroutine block_upsample_3d_real8(coarse, fine, nz)
integer, intent(in) :: nz
- real, intent(in) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:nz)
- real, intent(out) :: fine(is:ie,js:je,1:nz)
+ real(kind=8), intent(in) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:nz)
+ real(kind=8), intent(out) :: fine(is:ie,js:je,1:nz)
integer :: k
do k = 1, nz
- call block_upsample_2d(coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k), fine(is:ie,js:je,k))
+ call block_upsample_2d_real8(coarse(is_coarse:ie_coarse,js_coarse:je_coarse,k), fine(is:ie,js:je,k))
enddo
- end subroutine block_upsample_3d
+ end subroutine block_upsample_3d_real8
! This subroutine is copied from FMS/test_fms/horiz_interp/test2_horiz_interp.F90.
! domain_decomp in fv_mp_mod.F90 does something similar, but it does a
@@ -479,11 +911,11 @@ subroutine define_cubic_mosaic(domain, ni, nj, layout)
symmetry=.true., name='coarse cubic mosaic')
end subroutine define_cubic_mosaic
- subroutine compute_phalf_from_delp(delp, ptop, i_start, i_end, j_start, j_end, phalf)
+ subroutine compute_phalf_from_delp_real4(delp, ptop, i_start, i_end, j_start, j_end, phalf)
integer, intent(in) :: i_start, i_end, j_start, j_end
- real, intent(in) :: delp(i_start:i_end,j_start:j_end,1:npz)
- real, intent(in) :: ptop
- real, intent(out) :: phalf(i_start:i_end,j_start:j_end,1:npz+1)
+ real(kind=4), intent(in) :: delp(i_start:i_end,j_start:j_end,1:npz)
+ real(kind=4), intent(in) :: ptop
+ real(kind=4), intent(out) :: phalf(i_start:i_end,j_start:j_end,1:npz+1)
integer :: i, j, k
@@ -497,17 +929,37 @@ subroutine compute_phalf_from_delp(delp, ptop, i_start, i_end, j_start, j_end, p
enddo
enddo
enddo
- end subroutine compute_phalf_from_delp
+ end subroutine compute_phalf_from_delp_real4
+
+ subroutine compute_phalf_from_delp_real8(delp, ptop, i_start, i_end, j_start, j_end, phalf)
+ integer, intent(in) :: i_start, i_end, j_start, j_end
+ real(kind=8), intent(in) :: delp(i_start:i_end,j_start:j_end,1:npz)
+ real(kind=8), intent(in) :: ptop
+ real(kind=8), intent(out) :: phalf(i_start:i_end,j_start:j_end,1:npz+1)
+
+ integer :: i, j, k
+
+ phalf(:,:,1) = ptop ! Top level interface pressure is the model top
+
+ ! Integrate delp from top of model to the surface.
+ do i = i_start, i_end
+ do j = j_start, j_end
+ do k = 2, npz + 1
+ phalf(i,j,k) = phalf(i,j,k-1) + delp(i,j,k-1)
+ enddo
+ enddo
+ enddo
+ end subroutine compute_phalf_from_delp_real8
! Routine for computing the common requirements for pressure-level coarse-graining.
- subroutine vertical_remapping_requirements(delp, area, ptop, phalf, upsampled_coarse_phalf)
- real, intent(in) :: delp(is:ie,js:je,1:npz)
- real, intent(in) :: area(is:ie,js:je)
- real, intent(in) :: ptop
- real, intent(out) :: phalf(is:ie,js:je,1:npz+1)
- real, intent(out) :: upsampled_coarse_phalf(is:ie,js:je,1:npz+1)
+ subroutine vertical_remapping_requirements_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
+ 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, allocatable :: coarse_delp(:,:,:), coarse_phalf(:,:,:)
+ real(kind=4), allocatable :: coarse_delp(:,:,:), coarse_phalf(:,:,:)
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))
@@ -519,13 +971,51 @@ subroutine vertical_remapping_requirements(delp, area, ptop, phalf, upsampled_co
deallocate(coarse_delp)
deallocate(coarse_phalf)
- end subroutine vertical_remapping_requirements
+ end subroutine vertical_remapping_requirements_real4
- subroutine mask_area_weights(area, phalf, upsampled_coarse_phalf, masked_area_weights)
- real, intent(in) :: area(is:ie,js:je)
- real, intent(in) :: phalf(is:ie,js:je,1:npz+1)
- real, intent(in) :: upsampled_coarse_phalf(is:ie,js:je,1:npz+1)
- real, intent(out) :: masked_area_weights(is:ie,js:je,1:npz)
+ subroutine vertical_remapping_requirements_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
+ 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), allocatable :: coarse_delp(:,:,:), coarse_phalf(:,:,:)
+
+ 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)
+
+ deallocate(coarse_delp)
+ deallocate(coarse_phalf)
+ end subroutine vertical_remapping_requirements_real8
+
+ subroutine mask_area_weights_real4(area, phalf, upsampled_coarse_phalf, 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)
+ real(kind=4), intent(out) :: masked_area_weights(is:ie,js:je,1:npz)
+
+ 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
+ end subroutine mask_area_weights_real4
+
+ subroutine mask_area_weights_real8(area, phalf, upsampled_coarse_phalf, 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)
+ real(kind=8), intent(out) :: masked_area_weights(is:ie,js:je,1:npz)
integer :: k
@@ -536,7 +1026,7 @@ subroutine mask_area_weights(area, phalf, upsampled_coarse_phalf, masked_area_we
masked_area_weights(is:ie,js:je,k) = 0.0
endwhere
enddo
- end subroutine mask_area_weights
+ end subroutine mask_area_weights_real8
subroutine mask_mass_weights(area, delp, phalf, upsampled_coarse_phalf, &
masked_mass_weights)
@@ -878,4 +1368,2032 @@ subroutine block_edge_sum_y_2d_full_input(fine, coarse)
enddo
end subroutine block_edge_sum_y_2d_full_input
+ ! Needed for computing variances over coarse grid cells.
+ subroutine anomaly_2d(weights, fine, anom)
+ real, intent(in) :: weights(is:ie,js:je), fine(is:ie,js:je)
+ real, intent(out) :: anom(is:ie,js:je)
+
+ integer :: i, j, i_coarse, j_coarse, offset
+ real, allocatable :: coarse(:,:)
+
+ allocate(coarse(is_coarse:ie_coarse,js_coarse:je_coarse))
+
+ ! First compute the coarse-grained field
+ call weighted_block_average(weights, fine, coarse)
+
+ ! Then subtract it off
+ 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
+ anom(i:i+offset,j:j+offset) = fine(i:i+offset,j:j+offset) - coarse(i_coarse,j_coarse)
+ enddo
+ enddo
+ end subroutine anomaly_2d
+
+ subroutine anomaly_3d_weights_3d_array(weights, fine, anom)
+ real, intent(in) :: weights(is:ie,js:je,1:npz), fine(is:ie,js:je,1:npz)
+ real, intent(out) :: anom(is:ie,js:je,1:npz)
+
+ integer :: k
+ do k = 1,npz
+ call anomaly_2d(weights(is:ie,js:je,k), fine(is:ie,js:je,k), anom(is:ie,js:je,k))
+ enddo
+ end subroutine anomaly_3d_weights_3d_array
+
+ subroutine anomaly_2d_weights_3d_array(weights, fine, anom)
+ real, intent(in) :: weights(is:ie,js:je)
+ real, intent(in) :: fine(is:ie,js:je,1:npz)
+ real, intent(out) :: anom(is:ie,js:je,1:npz)
+
+ integer :: k
+ do k = 1,npz
+ call anomaly_2d(weights(is:ie,js:je), fine(is:ie,js:je,k), anom(is:ie,js:je,k))
+ enddo
+ end subroutine anomaly_2d_weights_3d_array
+
+ subroutine eddy_covariance_2d_weights(weights, field_a, field_b, coarse)
+ real, intent(in) :: weights(is:ie,js:je)
+ real, intent(in) :: field_a(is:ie,js:je,1:npz)
+ real, intent(in) :: field_b(is:ie,js:je,1:npz)
+ real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
+
+ real, allocatable :: anom_a(:,:,:)
+ real, allocatable :: anom_b(:,:,:)
+
+ allocate(anom_a(is:ie,js:je,1:npz))
+ allocate(anom_b(is:ie,js:je,1:npz))
+
+ call anomaly_2d_weights_3d_array(weights, field_a, anom_a)
+ call anomaly_2d_weights_3d_array(weights, field_b, anom_b)
+ call weighted_block_average(weights, anom_a * anom_b, coarse)
+ end subroutine eddy_covariance_2d_weights
+
+ subroutine eddy_covariance_3d_weights(weights, field_a, field_b, coarse)
+ real, intent(in) :: weights(is:ie,js:je,1:npz)
+ real, intent(in) :: field_a(is:ie,js:je,1:npz)
+ real, intent(in) :: field_b(is:ie,js:je,1:npz)
+ real, intent(out) :: coarse(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz)
+
+ real, allocatable :: anom_a(:,:,:)
+ real, allocatable :: anom_b(:,:,:)
+
+ allocate(anom_a(is:ie,js:je,1:npz))
+ allocate(anom_b(is:ie,js:je,1:npz))
+
+ call anomaly_3d_weights_3d_array(weights, field_a, anom_a)
+ call anomaly_3d_weights_3d_array(weights, field_b, anom_b)
+ call weighted_block_average(weights, anom_a * anom_b, coarse)
+ end subroutine eddy_covariance_3d_weights
+
+! Port mappm for single and double precision
+ subroutine mappm_real4(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
+
+! IV = 0: constituents
+! IV = 1: potential temp
+! IV =-1: winds
+
+! 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(kind=4), intent(in ):: pe1(i1:i2,km+1), pe2(i1:i2,kn+1)
+ real(kind=4), intent(in ):: q1(i1:i2,km)
+ real(kind=4), intent(out):: q2(i1:i2,kn)
+ real(kind=4), intent(IN) :: ptop
+! local
+ real(kind=4) qs(i1:i2)
+ real(kind=4) dp1(i1:i2,km)
+ real(kind=4) a4(4,i1:i2,km)
+ integer i, k, l
+ integer k0, k1
+ real(kind=4) 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
+
+!------------------------------------
+! Lowest layer: constant distribution
+!------------------------------------
+#ifdef NGGPS_SUBMITTED
+ do i=i1,i2
+ a4(2,i,km) = q1(i,km)
+ a4(3,i,km) = q1(i,km)
+ a4(4,i,km) = 0.
+ enddo
+#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
+#ifdef NGGPS_SUBMITTED
+ q2(i,k) = a4(3,i,km) ! this is not good.
+#else
+ q2(i,k) = q1(i,km)
+#endif
+ 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_real4*(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_real4*(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_real4*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
+#ifdef NGGPS_SUBMITTED
+ qsum = qsum + delp * a4(3,i,km) ! not good.
+#else
+ qsum = qsum + delp * q1(i,km)
+#endif
+ dpsum = dpsum + delp
+ endif
+123 q2(i,k) = qsum / dpsum
+ endif
+555 continue
+5555 continue
+
+ end subroutine mappm_real4
+
+ subroutine mappm_real8(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
+
+! IV = 0: constituents
+! IV = 1: potential temp
+! IV =-1: winds
+
+! 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(kind=8), intent(in ):: pe1(i1:i2,km+1), pe2(i1:i2,kn+1)
+ real(kind=8), intent(in ):: q1(i1:i2,km)
+ real(kind=8), intent(out):: q2(i1:i2,kn)
+ real(kind=8), intent(IN) :: ptop
+! local
+ real(kind=8) qs(i1:i2)
+ real(kind=8) dp1(i1:i2,km)
+ real(kind=8) a4(4,i1:i2,km)
+ integer i, k, l
+ integer k0, k1
+ real(kind=8) 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
+
+!------------------------------------
+! Lowest layer: constant distribution
+!------------------------------------
+#ifdef NGGPS_SUBMITTED
+ do i=i1,i2
+ a4(2,i,km) = q1(i,km)
+ a4(3,i,km) = q1(i,km)
+ a4(4,i,km) = 0.
+ enddo
+#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
+#ifdef NGGPS_SUBMITTED
+ q2(i,k) = a4(3,i,km) ! this is not good.
+#else
+ q2(i,k) = q1(i,km)
+#endif
+ 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_real8*(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_real8*(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_real8*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
+#ifdef NGGPS_SUBMITTED
+ qsum = qsum + delp * a4(3,i,km) ! not good.
+#else
+ qsum = qsum + delp * q1(i,km)
+#endif
+ dpsum = dpsum + delp
+ endif
+123 q2(i,k) = qsum / dpsum
+ endif
+555 continue
+5555 continue
+
+ end subroutine mappm_real8
+
+ subroutine cs_profile_real4(qs, a4, delp, km, i1, i2, iv, kord)
+! 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 =-2: vertical velocity
+ ! iv =-1: winds
+ ! iv = 0: positive definite scalars
+ ! iv = 1: others
+ integer, intent(in):: kord
+ real(kind=4), intent(in) :: qs(i1:i2)
+ real(kind=4), intent(in) :: delp(i1:i2,km) ! layer pressure thickness
+ real(kind=4), intent(inout):: a4(4,i1:i2,km) ! Interpolated values
+!-----------------------------------------------------------------------
+ logical, dimension(i1:i2,km):: extm, ext5, ext6
+ real(kind=4) gam(i1:i2,km)
+ real(kind=4) q(i1:i2,km+1) ! interface values
+ real(kind=4) d4(i1:i2)
+ real(kind=4) bet, a_bot, grat
+ real(kind=4) pmp_1, lac_1, pmp_2, lac_2, x0, x1
+ integer i, k, im
+
+ 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 ! all others
+ 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
+
+ if (iv.eq.-3) then !LBC for vertical velocities
+ do k=2,km-1
+ 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) )
+ d4(i) = delp(i,km-1) / delp(i,km)
+ bet = 2. + d4(i) + d4(i) - gam(i,km-1)
+ grat = delp(i,km-1) / delp(i,km)
+ q(i,km) = ( 3.*(a4(1,i,k-1)+d4(i)*a4(1,i,k)) - grat*qs(i) - q(i,k-1) )/bet
+ q(i,km+1) = qs(i)
+ enddo
+
+ else ! all others
+ 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
+ endif
+
+ 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) > 16 ) 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
+!----- Perfectly linear scheme --------------------------------
+
+!------------------
+! Apply constraints
+!------------------
+ im = i2 - i1 + 1
+
+! Apply *large-scale* constraints
+ 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) ! now dq
+ enddo
+ enddo
+
+! Interior:
+ do k=3,km-1
+ do i=i1,i2
+ if ( gam(i,k-1)*gam(i,k+1)>0. ) then
+! Apply large-scale constraint to ALL fields if not local max/min
+ 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
+
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(2,i,1) = max(0., a4(2,i,1))
+ 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 ( iv==2 ) then
+ 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
+ endif
+
+ 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_real4(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_real4(im, extm(i1,2), a4(1,i1,2), 2)
+
+!-------------------------------------
+! Huynh's 2nd constraint for interior:
+!-------------------------------------
+ do k=3,km-2
+ if ( abs(kord)<9 ) then
+ 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
+
+ elseif ( abs(kord)==9 ) then
+ 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
+ elseif ( abs(kord)==10 ) then
+ 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
+ elseif ( abs(kord)==12 ) then
+ do i=i1,i2
+ if( extm(i,k) ) 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 ! 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
+ elseif ( abs(kord)==13 ) then
+ do i=i1,i2
+ if( ext6(i,k) ) then
+ if ( ext6(i,k-1) .and. ext6(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)
+ 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
+ elseif ( abs(kord)==14 ) then
+
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+
+ elseif ( abs(kord)==15 ) then ! revised kord=9 scehem
+ do i=i1,i2
+ if ( ext5(i,k) ) then ! c90_mp122
+ if ( ext5(i,k-1) .or. ext5(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)
+ endif
+ elseif( ext6(i,k) ) then
+! Check within the smooth region if subgrid profile is non-monotonic
+ 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
+ enddo
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+ elseif ( abs(kord)==16 ) then
+ 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
+ ! 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) )
+ 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
+ else ! kord = 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
+ endif
+
+! Additional constraint to ensure positivity
+ if ( iv==0 ) call cs_limiters_real4(im, extm(i1,k), a4(1,i1,k), 0)
+
+ enddo ! k-loop
+
+!----------------------------------
+! Bottom layer subgrid constraints:
+!----------------------------------
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(3,i,km) = max(0., a4(3,i,km))
+ enddo
+ elseif ( iv .eq. -1 ) then
+ do i=i1,i2
+ if ( a4(3,i,km)*a4(1,i,km) <= 0. ) a4(3,i,km) = 0.
+ enddo
+ endif
+
+ 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_real4(im, extm(i1,k), a4(1,i1,k), 2)
+ if(k== km ) call cs_limiters_real4(im, extm(i1,k), a4(1,i1,k), 1)
+ enddo
+
+ end subroutine cs_profile_real4
+
+ subroutine cs_limiters_real4(im, extm, a4, iv)
+ integer, intent(in) :: im
+ integer, intent(in) :: iv
+ logical, intent(in) :: extm(im)
+ real(kind=4) , intent(inout) :: a4(4,im) ! PPM array
+! !LOCAL VARIABLES:
+ real(kind=4) 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_real4) < 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_real4
+
+ subroutine cs_profile_real8(qs, a4, delp, km, i1, i2, iv, kord)
+! 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 =-2: vertical velocity
+ ! iv =-1: winds
+ ! iv = 0: positive definite scalars
+ ! iv = 1: others
+ integer, intent(in):: kord
+ real(kind=8), intent(in) :: qs(i1:i2)
+ real(kind=8), intent(in) :: delp(i1:i2,km) ! layer pressure thickness
+ real(kind=8), intent(inout):: a4(4,i1:i2,km) ! Interpolated values
+!-----------------------------------------------------------------------
+ logical, dimension(i1:i2,km):: extm, ext5, ext6
+ real(kind=8) gam(i1:i2,km)
+ real(kind=8) q(i1:i2,km+1) ! interface values
+ real(kind=8) d4(i1:i2)
+ real(kind=8) bet, a_bot, grat
+ real(kind=8) pmp_1, lac_1, pmp_2, lac_2, x0, x1
+ integer i, k, im
+
+ 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 ! all others
+ 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
+
+ if (iv.eq.-3) then !LBC for vertical velocities
+ do k=2,km-1
+ 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) )
+ d4(i) = delp(i,km-1) / delp(i,km)
+ bet = 2. + d4(i) + d4(i) - gam(i,km-1)
+ grat = delp(i,km-1) / delp(i,km)
+ q(i,km) = ( 3.*(a4(1,i,k-1)+d4(i)*a4(1,i,k)) - grat*qs(i) - q(i,k-1) )/bet
+ q(i,km+1) = qs(i)
+ enddo
+
+ else ! all others
+ 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
+ endif
+
+ 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) > 16 ) 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
+!----- Perfectly linear scheme --------------------------------
+
+!------------------
+! Apply constraints
+!------------------
+ im = i2 - i1 + 1
+
+! Apply *large-scale* constraints
+ 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) ! now dq
+ enddo
+ enddo
+
+! Interior:
+ do k=3,km-1
+ do i=i1,i2
+ if ( gam(i,k-1)*gam(i,k+1)>0. ) then
+! Apply large-scale constraint to ALL fields if not local max/min
+ 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
+
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(2,i,1) = max(0., a4(2,i,1))
+ 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 ( iv==2 ) then
+ 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
+ endif
+
+ 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_real8(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_real8(im, extm(i1,2), a4(1,i1,2), 2)
+
+!-------------------------------------
+! Huynh's 2nd constraint for interior:
+!-------------------------------------
+ do k=3,km-2
+ if ( abs(kord)<9 ) then
+ 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
+
+ elseif ( abs(kord)==9 ) then
+ 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
+ elseif ( abs(kord)==10 ) then
+ 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
+ elseif ( abs(kord)==12 ) then
+ do i=i1,i2
+ if( extm(i,k) ) 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 ! 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
+ elseif ( abs(kord)==13 ) then
+ do i=i1,i2
+ if( ext6(i,k) ) then
+ if ( ext6(i,k-1) .and. ext6(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)
+ 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
+ elseif ( abs(kord)==14 ) then
+
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+
+ elseif ( abs(kord)==15 ) then ! revised kord=9 scehem
+ do i=i1,i2
+ if ( ext5(i,k) ) then ! c90_mp122
+ if ( ext5(i,k-1) .or. ext5(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)
+ endif
+ elseif( ext6(i,k) ) then
+! Check within the smooth region if subgrid profile is non-monotonic
+ 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
+ enddo
+ do i=i1,i2
+ a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k)))
+ enddo
+ elseif ( abs(kord)==16 ) then
+ 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
+ ! 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) )
+ 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
+ else ! kord = 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
+ endif
+
+! Additional constraint to ensure positivity
+ if ( iv==0 ) call cs_limiters_real8(im, extm(i1,k), a4(1,i1,k), 0)
+
+ enddo ! k-loop
+
+!----------------------------------
+! Bottom layer subgrid constraints:
+!----------------------------------
+ if ( iv==0 ) then
+ do i=i1,i2
+ a4(3,i,km) = max(0., a4(3,i,km))
+ enddo
+ elseif ( iv .eq. -1 ) then
+ do i=i1,i2
+ if ( a4(3,i,km)*a4(1,i,km) <= 0. ) a4(3,i,km) = 0.
+ enddo
+ endif
+
+ 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_real8(im, extm(i1,k), a4(1,i1,k), 2)
+ if(k== km ) call cs_limiters_real8(im, extm(i1,k), a4(1,i1,k), 1)
+ enddo
+
+ end subroutine cs_profile_real8
+
+ subroutine cs_limiters_real8(im, extm, a4, iv)
+ integer, intent(in) :: im
+ integer, intent(in) :: iv
+ logical, intent(in) :: extm(im)
+ real(kind=8) , intent(inout) :: a4(4,im) ! PPM array
+! !LOCAL VARIABLES:
+ real(kind=8) 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_real8) < 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_real8
+
+ subroutine ppm_profile_real4(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(kind=4) , intent(in):: delp(i1:i2,km) ! layer pressure thickness
+
+! !INPUT/OUTPUT PARAMETERS:
+ real(kind=4) , 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(kind=4) dc(i1:i2,km)
+ real(kind=4) h2(i1:i2,km)
+ real(kind=4) delq(i1:i2,km)
+ real(kind=4) df2(i1:i2,km)
+ real(kind=4) d4(i1:i2,km)
+
+! local scalars:
+ integer i, k, km1, lmt, it
+ real(kind=4) fac
+ real(kind=4) a1, a2, c1, c2, c3, d1, d2
+ real(kind=4) 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_real4(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_real4(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_real4(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_real4(dc(i1,k), a4(1,i1,k), it, 0)
+ enddo
+
+ end subroutine ppm_profile_real4
+
+ subroutine ppm_limiters_real4(dm, a4, itot, lmt)
+
+! !INPUT PARAMETERS:
+ real(kind=4) , 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(kind=4) , 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(kind=4) qmp
+ real(kind=4) da1, da2, a6da
+ real(kind=4) 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_real4
+ 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_real4
+
+ subroutine ppm_profile_real8(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(kind=8) , intent(in):: delp(i1:i2,km) ! layer pressure thickness
+
+! !INPUT/OUTPUT PARAMETERS:
+ real(kind=8) , 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(kind=8) dc(i1:i2,km)
+ real(kind=8) h2(i1:i2,km)
+ real(kind=8) delq(i1:i2,km)
+ real(kind=8) df2(i1:i2,km)
+ real(kind=8) d4(i1:i2,km)
+
+! local scalars:
+ integer i, k, km1, lmt, it
+ real(kind=8) fac
+ real(kind=8) a1, a2, c1, c2, c3, d1, d2
+ real(kind=8) 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_real8(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_real8(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_real8(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_real8(dc(i1,k), a4(1,i1,k), it, 0)
+ enddo
+
+ end subroutine ppm_profile_real8
+
+
+ subroutine ppm_limiters_real8(dm, a4, itot, lmt)
+
+! !INPUT PARAMETERS:
+ real(kind=8) , 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(kind=8) , 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(kind=8) qmp
+ real(kind=8) da1, da2, a6da
+ real(kind=8) 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_real8
+ 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_real8
end module coarse_graining_mod
diff --git a/tools/external_ic.F90 b/tools/external_ic.F90
index fd68d1fdd..9f5eabd65 100644
--- a/tools/external_ic.F90
+++ b/tools/external_ic.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -42,7 +42,8 @@ module external_ic_mod
use tracer_manager_mod, only: set_tracer_profile
use field_manager_mod, only: MODEL_ATMOS
- use constants_mod, only: pi=>pi_8, omega, grav, kappa, rdgas, rvgas, cp_air
+ use constants_mod, only: pi=>pi_8, grav, kappa, rdgas, rvgas, cp_air
+ use fv_arrays_mod, only: omega ! scaled for small earth
use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_grid_bounds_type, R_GRID
use fv_diagnostics_mod,only: prt_maxmin, 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
@@ -75,6 +76,7 @@ module external_ic_mod
real, parameter:: zvir = rvgas/rdgas - 1.
real(kind=R_GRID), parameter :: cnst_0p20=0.20d0
real :: deg2rad
+ character(len=128) :: inputdir
logical :: source_fv3gfs
! version number of this module
@@ -85,11 +87,12 @@ module external_ic_mod
contains
- subroutine get_external_ic( Atm, fv_domain, cold_start )
+ subroutine get_external_ic( Atm, fv_domain, cold_start, icdir )
type(fv_atmos_type), intent(inout), target :: Atm
type(domain2d), intent(inout) :: fv_domain
logical, intent(IN) :: cold_start
+ character(len=*), intent(in), optional :: icdir
real:: alpha = 0.
real rdg
integer i,j,k,nq
@@ -101,6 +104,9 @@ subroutine get_external_ic( Atm, fv_domain, cold_start )
integer :: isd, ied, jsd, jed, ng
integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, o3mr, sgs_tke, cld_amt
+ inputdir = 'INPUT/'
+ if(present(icdir)) inputdir = icdir
+
is = Atm%bd%is
ie = Atm%bd%ie
js = Atm%bd%js
@@ -181,9 +187,6 @@ subroutine get_external_ic( Atm, fv_domain, cold_start )
call prt_maxmin('T', Atm%pt, is, ie, js, je, ng, Atm%npz, 1.)
if (.not.Atm%flagstruct%hydrostatic) call prt_maxmin('W', Atm%w, is, ie, js, je, ng, Atm%npz, 1.)
call prt_maxmin('SPHUM', Atm%q(:,:,:,1), is, ie, js, je, ng, Atm%npz, 1.)
- if ( Atm%flagstruct%nggps_ic .or. Atm%flagstruct%hrrrv3_ic ) then
- call prt_maxmin('TS', Atm%ts, is, ie, js, je, 0, 1, 1.)
- endif
if ( Atm%flagstruct%nggps_ic .or. Atm%flagstruct%ecmwf_ic .or. Atm%flagstruct%hrrrv3_ic ) then
sphum = get_tracer_index(MODEL_ATMOS, 'sphum')
liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat')
@@ -282,11 +285,6 @@ subroutine get_nggps_ic (Atm, fv_domain)
!--- variables read in from 'gfs_ctrl.nc'
! VCOORD - level information
! maps to 'ak & bk'
-!--- variables read in from 'sfc_data.nc'
-! land_frac - land-sea-ice mask (L:0 / S:1)
-! maps to 'oro'
-! TSEA - surface skin temperature (k)
-! maps to 'ts'
!--- variables read in from 'gfs_data.nc'
! ZH - GFS grid height at edges (m)
! PS - surface pressure (Pa)
@@ -316,6 +314,7 @@ subroutine get_nggps_ic (Atm, fv_domain)
integer :: is, ie, js, je
integer :: isd, ied, jsd, jed
integer :: ios, ierr, unit, id_res
+
type(FmsNetcdfDomainFile_t) :: ORO_restart, SFC_restart, GFS_restart
type(FmsNetcdfFile_t) :: Gfs_ctl
integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist
@@ -405,12 +404,10 @@ subroutine get_nggps_ic (Atm, fv_domain)
!
- call get_data_source(source_fv3gfs,Atm%flagstruct%regional)
-
+ call get_data_source(source_fv3gfs,Atm%flagstruct%regional,inputdir)
levp = levsp-1
-
! read in GFS IC
call mpp_error(NOTE,'==> External_ic::get_nggps_ic: Reading processed IC')
call mpp_error(NOTE,'==> External_ic::get_nggps_ic: IC has ', levp ,' levels' )
@@ -478,8 +475,10 @@ subroutine get_nggps_ic (Atm, fv_domain)
else
call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_oro_ics)//' for NGGPS IC does not exist')
endif
+
call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_oro_ics)//' for NGGPS IC')
+
! initialize all tracers to default values prior to being input
do nt = 1, ntprog
call get_tracer_names(MODEL_ATMOS, nt, tracer_name)
@@ -744,6 +743,7 @@ subroutine read_gfs_ic()
allocate ( v_s(is:ie, js:je+1, 1:levp) )
if (source_fv3gfs) allocate (temp(is:ie,js:je,1:levp))
+
! initialize dim_names for register restart
dim_names_3d(1) = "lev"
dim_names_3d(2) = "lat"
@@ -810,11 +810,6 @@ subroutine get_hrrr_ic (Atm, fv_domain)
!--- variables read in from 'hrrr_ctrl.nc'
! VCOORD - level information
! maps to 'ak & bk'
-!--- variables read in from 'sfc_data.nc'
-! land_frac - land-sea-ice mask (L:0 / S:1)
-! maps to 'oro'
-! TSEA - surface skin temperature (k)
-! maps to 'ts'
!--- variables read in from 'gfs_data.nc'
! ZH - GFS grid height at edges (m)
! PS - surface pressure (Pa)
@@ -842,6 +837,7 @@ subroutine get_hrrr_ic (Atm, fv_domain)
integer :: is, ie, js, je
integer :: isd, ied, jsd, jed
integer :: ios, ierr, unit, id_res
+
type (FmsNetcdfDomainFile_t) :: ORO_restart, SFC_restart, HRRR_restart
type(FmsNetcdfFile_t) :: Hrr_ctl
integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist
@@ -1794,7 +1790,7 @@ subroutine get_ecmwf_ic( Atm, fv_domain )
real(kind=R_GRID), dimension(3):: e1, e2, ex, ey
real, allocatable:: ps_gfs(:,:), zh_gfs(:,:,:), o3mr_gfs(:,:,:)
real, allocatable:: ak_gfs(:), bk_gfs(:)
- integer :: id_res, ntprog, ntracers, ks, iq, nt
+ integer :: id_res, ntprog, ntracers, ks, iq, nt, levsp
character(len=64) :: tracer_name
integer :: levp_gfs = 64
type(FmsNetcdfDomainFile_t) :: ORO_restart, GFS_restart
@@ -1817,6 +1813,11 @@ subroutine get_ecmwf_ic( Atm, fv_domain )
jsd = Atm%bd%jsd
jed = Atm%bd%jed
+ call open_ncfile( trim(inputdir)//'/'//trim(fn_gfs_ctl), ncid )
+ call get_ncdim1( ncid, 'levsp', levsp )
+ call close_ncfile( ncid )
+ levp_gfs = levsp-1
+
deg2rad = pi/180.
npz = Atm%npz
@@ -2859,7 +2860,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in)
qp(i,k) = qa(i,j,k,iq)
enddo
enddo
- call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop)
+ call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8)
if ( iq==sphum ) then
call fillq(ie-is+1, npz, 1, qn1, dp2)
else
@@ -2943,8 +2944,8 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in)
qp(i,k) = t_in(i,j,k)
enddo
- call mappm(km, log(pe0), qp, npz, log(pe1), qn1, is,ie, 2, 4, Atm%ptop) ! pn0 and pn1 are higher-precision
- ! and cannot be passed to mappm
+ call mappm(km, log(pe0), qp, npz, log(pe1), qn1, is,ie, 2, 4) ! pn0 and pn1 are higher-precision
+ ! and cannot be passed to mappm
do k=1,npz
Atm%pt(i,j,k) = qn1(i,k)
enddo
@@ -3023,7 +3024,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in)
qp(i,k) = omga(i,j,k)
enddo
enddo
- call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop)
+ call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4)
if (source_fv3gfs) then
do k=1,npz
do i=is,ie
@@ -3167,7 +3168,7 @@ subroutine remap_scalar_single(Atm, km, npz, ak0, bk0, psc, qa, zh ,iq)
qp(i,k) = qa(i,j,k)
enddo
enddo
- call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop)
+ call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8)
if ( iq==1 ) then
call fillq(ie-is+1, npz, 1, qn1, dp2)
else
@@ -3266,7 +3267,7 @@ subroutine remap_dwinds(km, npz, ak0, bk0, psc, ud, vd, Atm)
enddo
enddo
call mappm(km, pe0(is:ie,1:km+1), ud(is:ie,j,1:km), npz, pe1(is:ie,1:npz+1), &
- qn1(is:ie,1:npz), is,ie, -1, 8, Atm%ptop)
+ qn1(is:ie,1:npz), is,ie, -1, 8)
do k=1,npz
do i=is,ie
Atm%u(i,j,k) = qn1(i,k)
@@ -3288,7 +3289,7 @@ subroutine remap_dwinds(km, npz, ak0, bk0, psc, ud, vd, Atm)
enddo
enddo
call mappm(km, pe0(is:ie+1,1:km+1), vd(is:ie+1,j,1:km), npz, pe1(is:ie+1,1:npz+1), &
- qn1(is:ie+1,1:npz), is,ie+1, -1, 8, Atm%ptop)
+ qn1(is:ie+1,1:npz), is,ie+1, -1, 8)
do k=1,npz
do i=is,ie+1
Atm%v(i,j,k) = qn1(i,k)
@@ -3348,7 +3349,7 @@ subroutine remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm)
!------
! map u
!------
- call mappm(km, pe0, ua(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8, Atm%ptop)
+ call mappm(km, pe0, ua(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8)
do k=1,npz
do i=is,ie
ut(i,j,k) = qn1(i,k)
@@ -3357,7 +3358,7 @@ subroutine remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm)
!------
! map v
!------
- call mappm(km, pe0, va(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8, Atm%ptop)
+ call mappm(km, pe0, va(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8)
do k=1,npz
do i=is,ie
vt(i,j,k) = qn1(i,k)
@@ -3584,7 +3585,7 @@ subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0
!------
! map u
!------
- call mappm(km, pe0, up, npz, pe1, qn1, is,ie, -1, 9, Atm%ptop)
+ call mappm(km, pe0, up, npz, pe1, qn1, is,ie, -1, 9)
do k=1,npz
do i=is,ie
ut(i,j,k) = qn1(i,k)
@@ -3593,7 +3594,7 @@ subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0
!------
! map v
!------
- call mappm(km, pe0, vp, npz, pe1, qn1, is,ie, -1, 9, Atm%ptop)
+ call mappm(km, pe0, vp, npz, pe1, qn1, is,ie, -1, 9)
do k=1,npz
do i=is,ie
vt(i,j,k) = qn1(i,k)
@@ -3606,7 +3607,7 @@ subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0
do iq=1,ncnst
! Note: AM2 physics tracers only
! if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then
- call mappm(km, pe0, qp(is,1,iq), npz, pe1, qn1, is,ie, 0, 11, Atm%ptop)
+ call mappm(km, pe0, qp(is,1,iq), npz, pe1, qn1, is,ie, 0, 11)
do k=1,npz
do i=is,ie
Atm%q(i,j,k,iq) = qn1(i,k)
@@ -3618,7 +3619,7 @@ subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0
!-------------------------------------------------------------
! map virtual temperature using geopotential conserving scheme.
!-------------------------------------------------------------
- call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 9, Atm%ptop)
+ call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 9)
do k=1,npz
do i=is,ie
Atm%pt(i,j,k) = qn1(i,k)/(1.+zvir*Atm%q(i,j,k,sphum))
diff --git a/tools/external_sst.F90 b/tools/external_sst.F90
index 96b531928..d67f62391 100644
--- a/tools/external_sst.F90
+++ b/tools/external_sst.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module external_sst_mod
#ifdef NO_GFDL_SHARED
diff --git a/tools/fv_diag_column.F90 b/tools/fv_diag_column.F90
new file mode 100644
index 000000000..0ece9fd6f
--- /dev/null
+++ b/tools/fv_diag_column.F90
@@ -0,0 +1,619 @@
+!***********************************************************************
+!* 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_diag_column_mod
+
+ use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_diag_type, fv_grid_bounds_type, &
+ R_GRID
+ use fv_grid_utils_mod, only: great_circle_dist
+ use time_manager_mod, only: time_type, get_date, get_time, month_name
+ 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
+ use fv_sg_mod, only: qsmith
+
+ implicit none
+ private
+
+ integer, parameter :: MAX_DIAG_COLUMN = 100
+ integer, parameter :: diag_name_len = 16
+ integer, allocatable, dimension(:) :: diag_debug_units
+ character(diag_name_len), dimension(MAX_DIAG_COLUMN) :: diag_debug_names
+ real, dimension(MAX_DIAG_COLUMN) :: diag_debug_lon, diag_debug_lat
+
+ integer, allocatable, dimension(:) :: diag_sonde_units
+ character(diag_name_len), dimension(MAX_DIAG_COLUMN) :: diag_sonde_names
+ real, dimension(MAX_DIAG_COLUMN) :: diag_sonde_lon, diag_sonde_lat
+ integer, dimension(MAX_DIAG_COLUMN) :: diag_debug_i, diag_debug_j, diag_debug_tile
+ integer, dimension(MAX_DIAG_COLUMN) :: diag_sonde_i, diag_sonde_j, diag_sonde_tile
+
+ logical :: do_diag_debug = .false. !< Whether to enable "diagnostic" debug columns, read from column_table
+ logical :: do_diag_debug_dyn = .false. !< Whether to write out debug columns every acoustic timestep instead of just every fv_diag timestep. Requires do_diag_debug to be .true.
+ logical :: do_diag_sonde = .false. !< Whether to enable point (column) sounding output, in the University of Wyoming format, read from column_table
+ integer :: sound_freq = 3 !< frequency (in hours) to write out diagnostic soundings
+ integer :: num_diag_debug = 0
+ integer :: num_diag_sonde = 0
+ character(100) :: runname = 'test' !< Name for this run, used in sonde output
+ integer :: diag_debug_kbottom !< bottom level (noting k=1 is the top) of diagnostic debug output. Used to limit the copious diagnostic sounding output to the layers of interest. Default is npz.
+ integer :: diag_debug_nlevels !< number of levels, counting upwards (to smaller k) from diag_debug_kbottom of diagnostic debug output. Default is npz/3.
+
+ character(10) :: init_str
+ real, parameter :: rad2deg = 180./pi
+
+ logical :: m_calendar
+
+ public :: do_diag_debug_dyn, debug_column, debug_column_dyn, fv_diag_column_init, sounding_column
+
+
+ namelist /fv_diag_column_nml/ do_diag_debug, do_diag_debug_dyn, do_diag_sonde, &
+ sound_freq, runname, diag_debug_kbottom, diag_debug_nlevels
+
+! version number of this module
+! Include variable "version" to be written to log file.
+#include
+
+contains
+
+ subroutine fv_diag_column_init(Atm, yr_init, mo_init, dy_init, hr_init, do_diag_debug_out, do_diag_sonde_out, sound_freq_out, m_calendar_in)
+
+ type(fv_atmos_type), intent(inout), target :: Atm
+ integer, intent(IN) :: yr_init, mo_init, dy_init, hr_init
+ logical, intent(IN) :: m_calendar_in
+ logical, intent(OUT) :: do_diag_debug_out, do_diag_sonde_out
+ integer, intent(OUT) :: sound_freq_out
+
+ integer :: ios
+
+ m_calendar = m_calendar_in
+
+ call write_version_number ( 'FV_DIAG_COLUMN_MOD', version )
+
+ diag_debug_names(:) = ''
+ diag_debug_lon(:) = -999.
+ diag_debug_lat(:) = -999.
+ diag_debug_i(:) = -999
+ diag_debug_j(:) = -999
+ diag_debug_tile(:) = -999
+ diag_debug_kbottom = Atm%npz
+ diag_debug_nlevels = Atm%npz/3
+
+ diag_sonde_names(:) = ''
+ diag_sonde_lon(:) = -999.
+ diag_sonde_lat(:) = -999.
+ diag_sonde_i(:) = -999
+ diag_sonde_j(:) = -999
+ diag_sonde_tile(:) = -99
+
+ read(input_nml_file, nml=fv_diag_column_nml,iostat=ios)
+
+ if (do_diag_debug .or. do_diag_sonde) then
+ call read_column_table
+ endif
+
+ if (do_diag_debug) then
+ allocate(diag_debug_units(num_diag_debug))
+ call find_diagnostic_column("DEBUG", diag_debug_names, diag_debug_i, diag_debug_j, diag_debug_tile, diag_debug_lat, diag_debug_lon, diag_debug_units, Atm%gridstruct%grid_64, Atm%gridstruct%agrid_64, num_diag_debug, Atm%gridstruct%ntiles_g, Atm%bd, Atm%global_tile, Atm%npx, Atm%npy)
+ endif
+ if (do_diag_sonde) then
+ allocate(diag_sonde_units(num_diag_sonde))
+ call find_diagnostic_column("Sonde ", diag_sonde_names, diag_sonde_i, diag_sonde_j, diag_sonde_tile, diag_sonde_lat, diag_sonde_lon, diag_sonde_units, Atm%gridstruct%grid_64, Atm%gridstruct%agrid_64, num_diag_sonde, Atm%gridstruct%ntiles_g, Atm%bd, Atm%global_tile, Atm%npx, Atm%npy)
+ endif
+
+ write(init_str,400) yr_init, mo_init, dy_init, hr_init
+400 format(I4, I2.2, I2.2, I2.2 )
+
+ do_diag_debug_out = do_diag_debug
+ do_diag_sonde_out = do_diag_sonde
+ sound_freq_out = sound_freq
+
+ end subroutine fv_diag_column_init
+
+
+!-----------------------------------------------------------------------
+!use diag_debug_[ij] for everything
+
+ subroutine read_column_table
+!< EXAMPLE COLUMN_TABLE file:
+!< #Use space-delineated fields (no commas)
+!< DEBUG index ORD 2 30 5
+!< DEBUG index Princeton 2 37 5
+!< DEBUG lonlat ORD2 272. 42.
+!< DEBUG lonlat Princeton 285.33 40.36
+!< DEBUG lonlat NP 0. 90.
+!< DEBUG lonlat SP 0. -90.
+!< sonde lonlat OUN -97.47 35.22
+!< sonde lonlat Amarillo -101.70 35.22
+!< sonde lonlat DelRio -100.92 29.37
+!< sonde lonlat Jackson -90.08 32.32
+!< sonde lonlat ILX -89.34 40.15
+!< sonde lonlat AtlanticCity -74.56 39.45
+!< sonde lonlat DodgeCity -99.97 37.77
+
+ integer :: iunit, io, nline
+ character(len=256) :: record
+ character(len=10) :: dum1, dum2
+
+ iunit = get_unit()
+ open(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
+ num_diag_sonde=0
+ nline=0
+ do while (num_diag_debug < MAX_DIAG_COLUMN .and. num_diag_sonde < MAX_DIAG_COLUMN .and. nline < MAX_DIAG_COLUMN*4)
+ nline = nline + 1
+ read(iunit,'(a)',end=100) record
+ if (record(1:1) == '#') cycle
+ if (record(1:10) == ' ') cycle
+
+ !Debug record with index point (index point not supported for sonde output)
+ !if (is_master()) print*, index(lowercase(record), "debug"), index(lowercase(record), "index"), trim(record)
+ if (index(lowercase(record), "debug") .ne. 0 .and. index(lowercase(record), "index") .ne. 0) then
+ if (num_diag_debug >= MAX_DIAG_COLUMN) continue
+ num_diag_debug = num_diag_debug + 1
+ read(record,*,iostat=io) dum1, dum2, diag_debug_names(num_diag_debug), diag_debug_i(num_diag_debug), diag_debug_j(num_diag_debug), diag_debug_tile(num_diag_debug)
+ if (io/=0) then
+ print*, ' read_column_table: error on line ', nline
+ call mpp_error(FATAL,'error in column_table format')
+ endif
+ else !debug or sonde record with specified lat-lon
+ if (index(lowercase(record), "debug") .ne. 0 ) then
+ if (num_diag_debug >= MAX_DIAG_COLUMN) continue
+ num_diag_debug = num_diag_debug + 1
+ read(record,*,iostat=io) dum1, dum2, diag_debug_names(num_diag_debug), diag_debug_lon(num_diag_debug), diag_debug_lat(num_diag_debug)
+ if (io/=0) then
+ print*, ' read_column_table: error on line ', nline
+ call mpp_error(FATAL,'error in column_table format')
+ endif
+ else
+ if (num_diag_sonde >= MAX_DIAG_COLUMN) continue
+ num_diag_sonde = num_diag_sonde + 1
+ read(record,*,iostat=io) dum1, dum2, diag_sonde_names(num_diag_sonde), diag_sonde_lon(num_diag_sonde), diag_sonde_lat(num_diag_sonde)
+ if (io/=0) then
+ print*, ' read_column_table: error on line ', nline
+ call mpp_error(FATAL,'error in column_table format')
+ endif
+ endif
+
+ endif
+
+ enddo
+100 continue
+
+ end subroutine read_column_table
+
+ !Note that output lat-lon are in degrees but input is in radians
+ subroutine find_diagnostic_column(diag_class, diag_names, diag_i, diag_j, diag_tile, diag_lat, diag_lon, diag_units, grid, agrid, num_diag, ntiles, bd, tile, npx, npy)
+
+ implicit none
+ type(fv_grid_bounds_type), intent(IN) :: bd
+ integer, intent(IN) :: num_diag, tile, ntiles, npx, npy
+ character(*), intent(IN) :: diag_class
+ character(diag_name_len), intent(IN) :: diag_names(MAX_DIAG_COLUMN)
+ integer, dimension(MAX_DIAG_COLUMN), intent(INOUT) :: diag_i, diag_j, diag_tile
+ real, dimension(MAX_DIAG_COLUMN), intent(INOUT) :: diag_lat, diag_lon
+ integer, dimension(num_diag), intent(OUT) :: diag_units
+ real(kind=R_GRID), intent(IN) :: grid(bd%isd+1:bd%ied+1,bd%jsd+1:bd%jed+1,2)
+ real(kind=R_GRID), intent(IN) :: agrid(bd%isd:bd%ied,bd%jsd:bd%jed,2)
+
+ integer :: i,j,m,io
+ character(80) :: filename
+ real(kind=R_GRID), dimension(2):: pp
+ real(kind=R_GRID), dimension(3):: vp_12, vp_23, vp_34, vp_14
+ real :: dmin, dist
+ integer :: isc, iec, jsc, jec
+ integer :: isd, ied, jsd, jed
+ logical :: point_found
+
+ isd = bd%isd
+ ied = bd%ied
+ jsd = bd%jsd
+ jed = bd%jed
+ isc = bd%isc
+ iec = bd%iec
+ jsc = bd%jsc
+ jec = bd%jec
+
+
+ do m=1,num_diag
+
+ point_found = .false.
+
+ !Index specified
+ if (diag_i(m) >= -10 .and. diag_j(m) >= -10) then
+
+ if ((diag_tile(m) < 0 .or. diag_tile(m) > ntiles)) then
+ if (ntiles > 1) then
+ call mpp_error(FATAL, ' find_diagnostic_column: diag_tile must be specified for '//trim(diag_class)//' point '//trim(diag_names(m))//' since ntiles > 1')
+ else
+ diag_tile(m) = 1
+ endif
+ endif
+
+ i=diag_i(m)
+ j=diag_j(m)
+
+ if (diag_tile(m) == tile .and. i >= isc .and. i <= iec .and. &
+ j >= jsc .and. j <= jec) then
+ diag_lon(m) = agrid(i,j,1)*rad2deg
+ diag_lat(m) = agrid(i,j,2)*rad2deg
+ point_found = .true.
+ else
+ diag_i(m) = -999
+ diag_j(m) = -999
+ diag_lon(m) = -999.
+ diag_lat(m) = -999.
+ diag_tile(m) = -1
+ point_found = .false.
+ endif
+
+ else ! lat-lon specified: find nearest grid cell center
+
+ !diag_lon and diag_lat are in degrees
+ ! great_circle_dist wants radians
+ pp = (/ diag_lon(m)/rad2deg, diag_lat(m)/rad2deg /)
+ !find nearest grid cell: if it is in the halo skip
+ dmin = 9.e20
+ diag_i(m) = -999
+ diag_j(m) = -999
+ do j=jsd,jed
+ do i=isd,ied
+ !no corners
+ if ( i < 1 .and. j < 1 ) cycle
+ if ( i >= npx .and. j < 1 ) cycle
+ if ( i < 1 .and. j >= npy ) cycle
+ if ( i >= npx .and. j >= npy ) cycle
+ dist = great_circle_dist(pp, agrid(i,j,:))
+ if (dmin >= dist) then
+ diag_i(m) = i
+ diag_j(m) = j
+ dmin = dist
+ endif
+ enddo
+ enddo
+ !print*, 'lat-lon point:', mpp_pe(), dmin, diag_i(m), diag_j(m), isc, iec, jsc, jec
+
+ if ( diag_i(m) < isc .or. diag_i(m) > iec .or. diag_j(m) < jsc .or. diag_j(m) > jec ) then
+ diag_i(m) = -999
+ diag_j(m) = -999
+ diag_lon(m) = -999.
+ diag_lat(m) = -999.
+ diag_tile(m) = -1
+ point_found = .false.
+ else
+ diag_lon(m) = agrid(diag_i(m), diag_j(m), 1)*rad2deg
+ diag_lat(m) = agrid(diag_i(m), diag_j(m), 2)*rad2deg
+ diag_tile(m) = tile
+ point_found = .true.
+ endif
+
+ endif
+
+ if (point_found) then
+
+ !Initialize output file
+ write(filename, 202) trim(diag_names(m)), trim(diag_class)
+202 format(A, '.', A, '.out')
+ open(newunit=diag_units(m), file=trim(filename), action='WRITE', position='rewind', iostat=io)
+ if(io/=0) call mpp_error(FATAL, ' find_diagnostic_column: Error in opening file '//trim(filename))
+ !Print debug message
+ write(*,'(A, 1x, A, 1x, 1x, A, 2F8.3, 2I5, I3, I04)') trim(diag_class), 'point: ', diag_names(m), diag_lon(m), diag_lat(m), diag_i(m), diag_j(m), diag_tile(m), mpp_pe()
+
+ endif
+
+ enddo
+
+ end subroutine find_diagnostic_column
+
+ subroutine debug_column(pt, delp, delz, u, v, w, q, npz, ncnst, sphum, nwat, zvir, ptop, hydrostatic, bd, Time)
+
+ type(fv_grid_bounds_type), intent(IN) :: bd
+ integer, intent(IN) :: npz, ncnst, sphum, nwat
+ real, intent(IN) :: zvir, ptop
+ logical, intent(IN) :: hydrostatic
+ real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: pt, delp, w
+ 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
+ real, dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst), intent(IN) :: q
+
+
+ type(time_type), intent(IN) :: Time
+ integer :: i,j,k,n,l, unit
+ real cond, pres, rdg, preshyd(npz), pehyd(npz+1), presdry, preshyddry(npz), pehyddry(npz+1)
+ integer :: yr, mon, dd, hr, mn, days, seconds
+
+ rdg = -rdgas/grav
+
+ do n=1,size(diag_debug_units)
+
+ i=diag_debug_i(n)
+ j=diag_debug_j(n)
+ unit=diag_debug_units(n)
+
+ !Sanity check
+ if (i < bd%is .or. i > bd%ie) cycle
+ if (j < bd%js .or. j > bd%je) cycle
+
+!< EXAMPLE FORMAT FOR DIAG OUTPUT HEADER
+!< PRINTING ORD DIAGNOSTICS
+!<
+!< time stamp: 2016 August 6 0 7 30
+!< DIAGNOSTIC POINT COORDINATES, point # 1
+!<
+!< longitude = 271.354 latitude = 42.063
+!< on processor # 162 : processor i = 2 , processor j = 30
+
+ write(unit, *) "DEBUG POINT ", diag_debug_names(n)
+ write(unit, *)
+ if (m_calendar) then
+ call get_date(Time, yr, mon, dd, hr, mn, seconds)
+ write(unit, '(A, I6, A12, 4I4)') " Time: ", yr, month_name(mon), dd, hr, mn, seconds
+ else
+ call get_time (Time, seconds, days)
+ write(unit, '(A, I6, I6)') " Time: ", days, seconds
+ endif
+ write(unit, *)
+ write(unit, '(A, F8.3, A, F8.3)') ' longitude = ', diag_debug_lon(n), ' latitude = ', diag_debug_lat(n)
+ write(unit, '(A, I8, A, I6, A, I6, A, I3)') ' on processor # ', mpp_pe(), ' : local i = ', i, ', local j = ', j, ' tile = ', diag_debug_tile(n)
+ write(unit, *)
+
+ write(unit,500) 'k', 'T', 'delp', 'delz', 'u', 'v', 'w', 'sphum', 'cond', 'pres', 'NHprime'!, 'pdry', 'NHpdry'
+ write(unit,500) ' ', 'K', 'mb', 'm', 'm/s', 'm/s', 'm/s', 'g/kg', 'g/kg', 'mb', 'mb'!, ! 'mb', 'mb'
+500 format(A4, A7, A8, A6, A8, A8, A8, A8, A9, A9, A9)
+ if (hydrostatic) then
+ call mpp_error(NOTE, 'Hydrostatic debug sounding not yet supported')
+ else
+ pehyd = ptop
+ pehyddry = ptop
+ do k=1,npz
+ pehyd(k+1) = pehyd(k) + delp(i,j,k)
+ preshyd(k) = (pehyd(k+1) - pehyd(k))/log(pehyd(k+1)/pehyd(k))
+ !pehyddry(k+1) = pehyddry(k) + delp(i,j,k)*(1.-sum(q(i,j,k,1:nwat)))
+ !preshyddry(k) = (pehyddry(k+1) - pehyddry(k))/log(pehyddry(k+1)/pehyddry(k))
+ enddo
+
+ !do k=2*npz/3,npz
+ do k=max(diag_debug_kbottom-diag_debug_nlevels,1),min(diag_debug_kbottom,npz)
+ cond = 0.
+ do l=2,nwat
+ cond = cond + q(i,j,k,l)
+ enddo
+ pres = rdg*delp(i,j,k)*(1.-cond)/delz(i,j,k)*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))
+ !presdry = rdg*delp(i,j,k)*(1.-cond-q(i,j,k,sphum))/delz(i,j,k)*pt(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)') &
+ k, pt(i,j,k), 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!, presdry*1.e-2, (presdry-preshyddry(k))*1.e-2
+ enddo
+ endif
+
+ write(unit, *) '==================================================================='
+ write(unit, *)
+
+ call flush(unit)
+
+
+ enddo
+
+ 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)
+
+ 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
+ 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
+ real, dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst), intent(IN) :: q
+ real, dimension(bd%isd:,bd%jsd:,1:), intent(IN) :: cappa
+
+ !Will need to convert variables from internal dyn_core values into logical external values
+ ! esp. pt from theta_v to T
+
+ type(time_type), intent(IN) :: Time
+ integer :: i,j,k,n,l, unit
+ real cond, pres, rdg, Tv, temp, heats, virt, pk, cv_air
+ real preshyd(npz), pehyd(npz+1)
+ integer yr, mon, dd, hr, mn, seconds
+
+ rdg = -rdgas/grav
+ cv_air = cp_air - rdgas
+
+ do n=1,size(diag_debug_units)
+
+ i=diag_debug_i(n)
+ j=diag_debug_j(n)
+ unit=diag_debug_units(n)
+
+ if (i < bd%is .or. i > bd%ie) cycle
+ if (j < bd%js .or. j > bd%je) cycle
+
+ write(unit, *) "DEBUG POINT ", diag_debug_names(n)
+ write(unit, *)
+ if (m_calendar) then
+ call get_date(Time, yr, mon, dd, hr, mn, seconds)
+ write(unit, '(A, I6, A12, 4I4)') " Time: ", yr, month_name(mon), dd, hr, mn, seconds
+ else
+ call get_time (Time, seconds, dd)
+ write(unit, '(A, I6, I6)') " Time: ", dd, seconds
+ endif
+ write(unit,*) 'k_split = ', k_step, ', n_split = ', n_step
+ write(unit, *)
+ write(unit, '(A, F8.3, A, F8.3)') ' longitude = ', diag_debug_lon(n), ' latitude = ', diag_debug_lat(n)
+ write(unit, '(A, I8, A, I6, A, I6)') ' on processor # ', mpp_pe(), ' : local i = ', i, ', local j = ', j
+ write(unit, *)
+
+ write(unit,500) 'k', 'T', 'delp', 'delz', 'u', 'v', 'w', 'sphum', 'cond', 'pres', 'NHprime', 'heat'
+ write(unit,500) ' ', 'K', 'mb', 'm', 'm/s', 'm/s', 'm/s', 'g/kg', 'g/kg', 'mb', 'mb', 'K'
+500 format(A4, A7, A8, A6, A8, A8, A8, A8, A9, A9, A9, A8)
+ if (hydrostatic) then
+ call mpp_error(NOTE, 'Hydrostatic debug sounding not yet supported')
+ else
+ pehyd = ptop
+ do k=1,npz
+ pehyd(k+1) = pehyd(k) + delp(i,j,k)
+ preshyd(k) = (pehyd(k+1) - pehyd(k))/log(pehyd(k+1)/pehyd(k))
+ enddo
+ !do k=2*npz/3,npz
+ do k=max(diag_debug_kbottom-diag_debug_nlevels,1),min(diag_debug_kbottom,npz)
+ cond = 0.
+ do l=2,nwat
+ 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))
+ else
+ heats = 0.0
+ endif
+ write(unit,'(I4, F7.2, F8.3, I6, F8.3, F8.3, F8.3, F8.3, F9.5, F9.3, F9.3, 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
+ enddo
+ endif
+
+ write(unit, *) '==================================================================='
+ write(unit, *)
+
+ call flush(unit)
+
+ enddo
+
+ end subroutine debug_column_dyn
+
+ subroutine sounding_column( pt, delp, delz, u, v, q, peln, pkz, thetae, phis, &
+ npz, ncnst, sphum, nwat, hydrostatic, zvir, ng, bd, Time )
+
+ type(fv_grid_bounds_type), intent(IN) :: bd
+ integer, intent(IN) :: npz, ncnst, sphum, nwat, ng
+ real, intent(IN) :: zvir
+ logical, intent(IN) :: hydrostatic
+ real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: pt, delp
+ 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
+ real, dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst), intent(IN) :: q
+ real, dimension(bd%is:bd%ie,npz+1,bd%js:bd%je), intent(in):: peln
+ real, dimension(bd%is:bd%ie,bd%js:bd%je,npz), intent(in):: pkz, thetae
+ real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed), intent(IN) :: phis
+ type(time_type), intent(IN) :: Time
+
+ real :: Tv, pres, hght(npz), dewpt, rh, mixr, tmp, qs(1), wspd, wdir, rpk, theta, thetav
+
+ real, PARAMETER :: rgrav = 1./grav
+ real, PARAMETER :: rdg = -rdgas*rgrav
+ real, PARAMETER :: sounding_top = 10.e2
+ real, PARAMETER :: ms_to_knot = 1.9438445
+ real, PARAMETER :: p0 = 1000.e2
+
+ integer :: i, j, k, n, unit
+ integer :: yr_v, mo_v, dy_v, hr_v, mn_v, sec_v ! need to get numbers for these
+
+ if (m_calendar) then
+ call get_date(Time, yr_v, mo_v, dy_v, hr_v, mn_v, sec_v)
+ else
+ call get_time (Time, sec_v, dy_v)
+ endif
+
+ do n=1,size(diag_sonde_units)
+
+ i=diag_sonde_i(n)
+ j=diag_sonde_j(n)
+ unit=diag_sonde_units(n)
+
+ if (i < bd%is .or. i > bd%ie) cycle
+ if (j < bd%js .or. j > bd%je) cycle
+
+
+ if (m_calendar) then
+ write(unit,600) &
+ trim(diag_sonde_names(n)), yr_v, mo_v, dy_v, hr_v, init_str, trim(runname)
+600 format(A,'.v', I4, I2.2, I2.2, I2.2, '.i', A10, '.', A, '.dat########################################################')
+ write(unit,601) trim(diag_sonde_names(n)), yr_v, mo_v, dy_v, hr_v, init_str(1:8),init_str(9:10)
+601 format(3x, A16, ' Valid ', I4, I2.2, I2.2, '.', I2.2, 'Z Init ', A8, '.', A2, 'Z')
+ endif
+ write(unit,'(5x, A, 2F8.3)') trim(runname), diag_sonde_lon(n), diag_sonde_lat(n)
+ write(unit,*)
+ write(unit,*) '-------------------------------------------------------------------------------'
+ write(unit,'(11A7)') 'PRES', 'HGHT', "TEMP", "DWPT", "RELH", "MIXR", "DRCT", "SKNT", "THTA", "THTE", "THTV"
+ write(unit,'(11A7)') 'hPa', 'm', 'C', 'C', '%', 'g/kg', 'deg', 'knot', 'K', 'K', 'K'
+ write(unit,*) '-------------------------------------------------------------------------------'
+
+ if (hydrostatic) then
+ call mpp_error(NOTE, 'Hydrostatic diagnostic sounding not yet supported')
+ else
+ hght(npz) = phis(i,j)*rgrav - 0.5*delz(i,j,npz)
+ do k=npz-1,1,-1
+ hght(k) = hght(k+1) - 0.5*(delz(i,j,k)+delz(i,j,k+1))
+ enddo
+
+ do k=npz,1,-1
+
+ Tv = pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))
+ pres = delp(i,j,k)/delz(i,j,k)*rdg*Tv
+ !if (pres < sounding_top) cycle
+
+ call qsmith(1, 1, 1, pt(i,j,k:k), &
+ (/pres/), q(i,j,k:k,sphum), qs)
+
+ mixr = q(i,j,k,sphum)/(1.-sum(q(i,j,k,1:nwat))) ! convert from sphum to mixing ratio
+ rh = q(i,j,k,sphum)/qs(1)
+ tmp = ( log(max(rh,1.e-2))/ 17.27 + ( pt(i,j,k) - 273.14 )/ ( -35.84 + pt(i,j,k)) )
+ dewpt = 237.3* tmp/ ( 1. - tmp ) ! deg C
+ wspd = 0.5*sqrt((u(i,j,k)+u(i,j+1,k))*(u(i,j,k)+u(i,j+1,k)) + (v(i,j,k)+v(i+1,j,k))*(v(i,j,k)+v(i+1,j,k)))*ms_to_knot ! convert to knots
+ if (wspd > 0.01) then
+ !https://www.eol.ucar.edu/content/wind-direction-quick-reference
+ wdir = atan2(u(i,j,k)+u(i,j+1,k),v(i,j,k)+v(i+1,j,k)) * rad2deg
+ else
+ wdir = 0.
+ endif
+ rpk = exp(-kappa*log(pres/p0))
+ theta = pt(i,j,k)*rpk
+ thetav = Tv*rpk
+
+ write(unit,'(F7.1, I7, F7.1, F7.1, I7, F7.2, I7, F7.2, F7.1, F7.1, F7.1)') &
+ pres*1.e-2, int(hght(k)), pt(i,j,k)-TFREEZE, dewpt, int(rh*100.), mixr*1.e3, int(wdir), wspd, theta, thetae(i,j,k), thetav
+ enddo
+ endif
+
+ call flush(unit)
+
+ enddo
+
+
+ end subroutine sounding_column
+
+
+
+end module fv_diag_column_mod
diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90
index ac40d2c88..5a8280494 100644
--- a/tools/fv_diagnostics.F90
+++ b/tools/fv_diagnostics.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -24,8 +24,9 @@
module fv_diagnostics_mod
- use constants_mod, only: grav, rdgas, rvgas, pi=>pi_8, radius, kappa, WTMAIR, WTMCO2, &
- omega, hlv, cp_air, cp_vapor, TFREEZE
+ use constants_mod, only: grav, rdgas, rvgas, pi=>pi_8, kappa, WTMAIR, WTMCO2, &
+ hlv, cp_air, cp_vapor, TFREEZE
+ use fv_arrays_mod, only: radius ! scaled for small earth
use fms_mod, only: write_version_number
use time_manager_mod, only: time_type, get_date, get_time
use mpp_domains_mod, only: domain2d, mpp_update_domains, DGRID_NE, NORTH, EAST
@@ -47,9 +48,10 @@ 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: wqs1, qsmith_init, c_liq
+ use fv_arrays_mod, only: max_step
+ use gfdl_mp_mod, only: wqs1, qsmith_init, c_liq
+ use rad_ref_mod, only: rad_ref
use fv_diag_column_mod, only: fv_diag_column_init, sounding_column, debug_column
implicit none
@@ -91,12 +93,14 @@ module fv_diagnostics_mod
real :: sphum_ll_fix = 0.
real :: qcly0 ! initial value for terminator test
- public :: fv_diag_init, fv_time, fv_diag, prt_mxm, prt_maxmin, range_check!, id_divg, id_te
+ logical :: is_ideal_case = .false.
+ public :: fv_diag_init, fv_time, fv_diag, prt_mxm, prt_maxmin, range_check
+
public :: prt_mass, prt_minmax, ppme, fv_diag_init_gn, z_sum, sphum_ll_fix, eqv_pot, qcly0, gn
- public :: prt_height, prt_gb_nh_sh, interpolate_vertical, rh_calc, get_height_field, dbzcalc
- public :: max_vv, get_vorticity, max_uh
- public :: max_vorticity, max_vorticity_hy1, bunkers_vector, helicity_relative_CAPS
- public :: cs3_interpolator, get_height_given_pressure
+ public :: prt_height, prt_gb_nh_sh, interpolate_vertical, rh_calc, get_height_field, get_height_given_pressure
+ public :: cs3_interpolator, get_vorticity, is_ideal_case
+! needed by fv_nggps_diag
+ public :: max_vv, max_uh, bunkers_vector, helicity_relative_CAPS
integer, parameter :: MAX_PLEVS = 31
#ifdef FEWER_PLEVS
@@ -112,7 +116,7 @@ module fv_diagnostics_mod
integer :: yr_init, mo_init, dy_init, hr_init, mn_init, sec_init
integer :: id_dx, id_dy
- real :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2)
+ real :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2), psrange(2), skrange(2)
! integer :: id_d_grid_ucomp, id_d_grid_vcomp ! D grid winds
! integer :: id_c_grid_ucomp, id_c_grid_vcomp ! C grid winds
@@ -146,7 +150,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
integer :: id_hyam, id_hybm
integer :: id_plev, 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 :: isc, iec, jsc, jec
+ integer :: isd, ied, jsd, jed, isc, iec, jsc, jec
logical :: used
@@ -160,12 +164,18 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
integer :: axe_ave(3)
character(len=64) :: errmsg
+#ifdef GFS_PHYS
+ character(len=*), parameter :: massdef_str = " (GFS moist-mass)"
+#else
+ character(len=*), parameter :: massdef_str = ""
+#endif
logical :: exists
integer :: nlunit, ios
real, allocatable :: dx(:,:), dy(:,:)
call write_version_number ( 'FV_DIAGNOSTICS_MOD', version )
+
idiag => Atm(1)%idiag
! For total energy diagnostics:
@@ -201,6 +211,12 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
trange = (/ 100., 350. /) ! temperature
#endif
slprange = (/800., 1200./) ! sea-level-pressure
+ skrange = (/ -10000000.0, 10000000.0 /) ! dissipation estimate for SKEB
+#ifdef SW_DYNAMICS
+ psrange = (/.01, 1.e7 /)
+#else
+ psrange = (/40000.0, 110000.0/)
+#endif
ginv = 1./GRAV
if (Atm(1)%grid_number == 1) fv_time = Time
@@ -234,6 +250,9 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
isc = Atm(n)%bd%isc; iec = Atm(n)%bd%iec
jsc = Atm(n)%bd%jsc; jec = Atm(n)%bd%jec
+ isd = Atm(n)%bd%isd; ied = Atm(n)%bd%ied
+ jsd = Atm(n)%bd%jsd; jed = Atm(n)%bd%jed
+
! Send diag_manager the grid informtaion
call diag_grid_init(DOMAIN=Atm(n)%domain, &
& GLO_LON=rad2deg*Atm(n)%gridstruct%grid(isc:iec+1,jsc:jec+1,1), &
@@ -426,7 +445,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'dy', 'm')
#ifndef DYNAMICS_ZS
id_zsurf = register_static_field ( trim(field), 'zsurf', axes(1:2), &
- 'surface height', 'm' )
+ 'surface height', 'm', interp_method='conserve_order1' )
#endif
id_zs = register_static_field ( trim(field), 'zs', axes(1:2), &
'Original Mean Terrain', 'm' )
@@ -565,13 +584,13 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
#ifdef DYNAMICS_ZS
id_zsurf = register_diag_field ( trim(field), 'zsurf', axes(1:2), Time, &
- 'surface height', 'm')
+ 'surface height', 'm', interp_method='conserve_order1')
#endif
!-------------------
! Surface pressure
!-------------------
id_ps = register_diag_field ( trim(field), 'ps', axes(1:2), Time, &
- 'surface pressure', 'Pa', missing_value=missing_value )
+ 'surface pressure', 'Pa', missing_value=missing_value, range=psrange)
!-------------------
! Mountain torque
@@ -589,6 +608,8 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
!-------------------
! Precipitation from GFDL MP
!-------------------
+ id_prec = register_diag_field ( trim(field), 'prec', axes(1:2), Time, &
+ 'total precipitation', 'mm/day', missing_value=missing_value )
id_prer = register_diag_field ( trim(field), 'prer', axes(1:2), Time, &
'rain precipitation', 'mm/day', missing_value=missing_value )
id_prei = register_diag_field ( trim(field), 'prei', axes(1:2), Time, &
@@ -623,7 +644,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
id_liq_wat_dt_gfdlmp = register_diag_field ( trim(field), 'liq_wat_dt_gfdlmp', axes(1:3), Time, &
'liquid water tracer tendency from GFDL MP', 'kg/kg/s', missing_value=missing_value )
if (id_liq_wat_dt_gfdlmp > 0) allocate(Atm(n)%inline_mp%liq_wat_dt(isc:iec,jsc:jec,npz))
- id_ice_wat_dt_gfdlmp = register_diag_field ( trim(field), 'ice_dt_wat_gfdlmp', axes(1:3), Time, &
+ id_ice_wat_dt_gfdlmp = register_diag_field ( trim(field), 'ice_wat_dt_gfdlmp', axes(1:3), Time, &
'ice water tracer tendency from GFDL MP', 'kg/kg/s', missing_value=missing_value )
if (id_ice_wat_dt_gfdlmp > 0) allocate(Atm(n)%inline_mp%ice_wat_dt(isc:iec,jsc:jec,npz))
@@ -687,13 +708,28 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
idiag%id_T_dt_sg = register_diag_field ( trim(field), 'T_dt_sg', axes(1:3), Time, &
'temperature tendency from 2dz subgrid mixing', 'K/s', missing_value=missing_value )
+ if ((idiag%id_t_dt_sg > 0) .and. (.not. allocated(Atm(n)%sg_diag%t_dt))) then
+ allocate (Atm(n)%sg_diag%t_dt(isc:iec,jsc:jec,1:npz))
+ Atm(n)%sg_diag%t_dt = 0.0
+ endif
idiag%id_u_dt_sg = register_diag_field ( trim(field), 'u_dt_sg', axes(1:3), Time, &
'zonal wind tendency from 2dz subgrid mixing', 'm/s/s', missing_value=missing_value )
+ if ((idiag%id_u_dt_sg > 0) .and. (.not. allocated(Atm(n)%sg_diag%u_dt))) then
+ allocate (Atm(n)%sg_diag%u_dt(isc:iec,jsc:jec,1:npz))
+ Atm(n)%sg_diag%u_dt = 0.0
+ endif
idiag%id_v_dt_sg = register_diag_field ( trim(field), 'v_dt_sg', axes(1:3), Time, &
'meridional wind tendency from 2dz subgrid mixing', 'm/s/s', missing_value=missing_value )
+ if ((idiag%id_v_dt_sg > 0) .and. (.not. allocated(Atm(n)%sg_diag%v_dt))) then
+ allocate (Atm(n)%sg_diag%v_dt(isc:iec,jsc:jec,1:npz))
+ Atm(n)%sg_diag%v_dt = 0.0
+ endif
idiag%id_qv_dt_sg = register_diag_field ( trim(field), 'qv_dt_sg', axes(1:3), Time, &
'water vapor tendency from 2dz subgrid mixing', 'kg/kg/s', missing_value=missing_value )
-
+ if ((idiag%id_qv_dt_sg > 0) .and. (.not. allocated(Atm(n)%sg_diag%qv_dt))) then
+ allocate (Atm(n)%sg_diag%qv_dt(isc:iec,jsc:jec,1:npz))
+ Atm(n)%sg_diag%qv_dt = 0.0
+ endif
! Nudging tendencies
id_t_dt_nudge = register_diag_field('dynamics', &
@@ -736,6 +772,7 @@ 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
+
endif
!
@@ -766,8 +803,13 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'zonal wind', 'm/sec', missing_value=missing_value, range=vrange )
id_v_plev = register_diag_field ( trim(field), 'v_plev', axe2(1:3), Time, &
'meridional wind', 'm/sec', missing_value=missing_value, range=vrange )
- id_t_plev = register_diag_field ( trim(field), 't_plev', axe2(1:3), Time, &
- 'temperature', 'K', missing_value=missing_value, range=trange )
+ if (is_ideal_case) then
+ id_t_plev = register_diag_field ( trim(field), 't_plev', axe2(1:3), Time, &
+ 'temperature', 'K', missing_value=missing_value )
+ else
+ id_t_plev = register_diag_field ( trim(field), 't_plev', axe2(1:3), Time, &
+ 'temperature', 'K', missing_value=missing_value, range=trange )
+ endif
id_h_plev = register_diag_field ( trim(field), 'h_plev', axe2(1:3), Time, &
'height', 'm', missing_value=missing_value )
id_q_plev = register_diag_field ( trim(field), 'q_plev', axe2(1:3), Time, &
@@ -776,7 +818,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'omega', 'Pa/s', missing_value=missing_value )
endif
-
!Layer averages for temperature, moisture, etc.
id_t_plev_ave = register_diag_field(trim(field), 't_plev_ave', axe_ave(1:3), Time, &
'layer-averaged temperature', 'K', missing_value=missing_value)
@@ -794,6 +835,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
id_t_dt_phys_plev_ave = register_diag_field ( trim(field), 't_dt_phys_plev_ave', axe_ave(1:3), Time, &
'layer-averaged temperature tendency from physics', 'K/s', missing_value=missing_value )
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
id_any_hght = 1
@@ -856,9 +898,13 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
if ( .not. Atm(n)%flagstruct%hydrostatic ) &
id_w = register_diag_field ( trim(field), 'w', axes(1:3), Time, &
'vertical wind', 'm/sec', missing_value=missing_value, range=wrange )
-
- id_pt = register_diag_field ( trim(field), 'temp', axes(1:3), Time, &
- 'temperature', 'K', missing_value=missing_value, range=trange )
+ if (is_ideal_case) then
+ id_pt = register_diag_field ( trim(field), 'temp', axes(1:3), Time, &
+ 'temperature', 'K', missing_value=missing_value )
+ else
+ 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_theta_e = register_diag_field ( trim(field), 'theta_e', axes(1:3), Time, &
@@ -867,6 +913,9 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'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 )
+! 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 )
id_hght3d = register_diag_field( trim(field), 'hght', axes(1:3), Time, &
'height', 'm', missing_value=missing_value )
@@ -875,16 +924,18 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'Relative Humidity', '%', missing_value=missing_value )
! 'Relative Humidity', '%', missing_value=missing_value, range=rhrange )
id_delp = register_diag_field ( trim(field), 'delp', axes(1:3), Time, &
- 'pressure thickness', 'pa', missing_value=missing_value )
+ 'pressure thickness'//massdef_str, 'pa', missing_value=missing_value )
if ( .not. Atm(n)%flagstruct%hydrostatic ) &
id_delz = register_diag_field ( trim(field), 'delz', axes(1:3), Time, &
'height thickness', 'm', missing_value=missing_value )
if( Atm(n)%flagstruct%hydrostatic ) then
id_pfhy = register_diag_field ( trim(field), 'pfhy', axes(1:3), Time, &
- 'hydrostatic pressure', 'pa', missing_value=missing_value )
+ 'hydrostatic pressure'//massdef_str, 'pa', missing_value=missing_value )
else
id_pfnh = register_diag_field ( trim(field), 'pfnh', axes(1:3), Time, &
- 'non-hydrostatic pressure', 'pa', missing_value=missing_value )
+ 'non-hydrostatic pressure'//massdef_str, 'pa', missing_value=missing_value )
+ id_ppnh = register_diag_field ( trim(field), 'ppnh', axes(1:3), Time, &
+ 'non-hydrostatic pressure perturbation', 'pa', missing_value=missing_value )
endif
!--------------------
! 3D Condensate
@@ -916,14 +967,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
id_pv550K = register_diag_field ( trim(field), 'pv550K', axes(1:2), Time, &
'550-K potential vorticity; needs x550 scaling', '(K m**2) / (kg s)', missing_value=missing_value)
- ! -------------------
- ! Vertical flux correlation terms (good for averages)
- ! -------------------
- id_uw = register_diag_field ( trim(field), 'uw', axes(1:3), Time, &
- 'vertical zonal momentum flux', 'N/m**2', missing_value=missing_value )
- id_vw = register_diag_field ( trim(field), 'vw', axes(1:3), Time, &
- 'vertical meridional momentum flux', 'N/m**', missing_value=missing_value )
-
!--------------------
! 3D flux terms
!--------------------
@@ -956,6 +999,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
id_ww = register_diag_field ( trim(field), 'ww', axes(1:3), Time, &
'vertical flux of vertical wind', '(m/sec)^2', missing_value=missing_value )
endif
+
!--------------------
! vertical integral of 3D flux terms
!--------------------
@@ -1040,6 +1084,10 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'Convective available potential energy (surface-based)', 'J/kg' , missing_value=missing_value )
id_cin = register_diag_field( trim(field), 'cin', axes(1:2), Time, &
'Convective inhibition (surface-based)', 'J/kg' , missing_value=missing_value )
+ id_brn = register_diag_field( trim(field), 'BRN', axes(1:2), Time, &
+ 'Bulk Richardson Number', 'nondim' , missing_value=missing_value )
+ id_shear06 = register_diag_field( trim(field), 'shear06', axes(1:2), Time, &
+ '0--6 km shear', 'm/s' , missing_value=missing_value )
!--------------------------
! Vertically integrated tracers for GFDL MP
!--------------------------
@@ -1056,14 +1104,12 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
id_intqg = register_diag_field ( trim(field), 'intqg', axes(1:2), Time, &
'Vertically Integrated Graupel', 'kg/m**2', missing_value=missing_value )
-#ifdef HIWPP
id_acl = register_diag_field ( trim(field), 'acl', axes(1:2), Time, &
'Column-averaged Cl mixing ratio', 'kg/kg', missing_value=missing_value )
id_acl2 = register_diag_field ( trim(field), 'acl2', axes(1:2), Time, &
'Column-averaged Cl2 mixing ratio', 'kg/kg', missing_value=missing_value )
id_acly = register_diag_field ( trim(field), 'acly', axes(1:2), Time, &
'Column-averaged total chlorine mixing ratio', 'kg/kg', missing_value=missing_value )
-#endif
!--------------------------
! 850-mb vorticity
@@ -1288,14 +1334,8 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
! end do
-#ifdef TEST_TRACER
- call prt_mass(npz, Atm(n)%ncnst, isc, iec, jsc, jec, Atm(n)%ng, max(1,Atm(n)%flagstruct%nwat), &
- Atm(n)%ps, Atm(n)%delp, Atm(n)%q, Atm(n)%gridstruct%area_64, Atm(n)%domain)
-#else
call prt_mass(npz, Atm(n)%ncnst, isc, iec, jsc, jec, Atm(n)%ng, Atm(n)%flagstruct%nwat, &
Atm(n)%ps, Atm(n)%delp, Atm(n)%q, Atm(n)%gridstruct%area_64, Atm(n)%domain)
-#endif
-
!Model initialization time (not necessarily the time this simulation is started,
! conceivably a restart could be done
@@ -1312,8 +1352,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
if(id_theta_e >0 ) call qsmith_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)
-
+ 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)
end subroutine fv_diag_init
@@ -1513,6 +1552,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call prt_maxmin('PS', Atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01)
#ifdef HIWPP
+ if (.not. Atm(n)%gridstruct%bounded_domain ) then
allocate(var2(isc:iec,jsc:jec))
!hemispheric max/min pressure
do j=jsc,jec
@@ -1531,15 +1571,11 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call prt_maxmin('SH PS', var2, isc, iec, jsc, jec, 0, 1, 0.01)
deallocate(var2)
+ endif
#endif
-#ifdef TEST_TRACER
- call prt_mass(npz, nq, isc, iec, jsc, jec, ngc, max(1,Atm(n)%flagstruct%nwat), &
- Atm(n)%ps, Atm(n)%delp, Atm(n)%q, Atm(n)%gridstruct%area_64, Atm(n)%domain)
-#else
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)
-#endif
#ifndef SW_DYNAMICS
if (Atm(n)%flagstruct%consv_te > 1.e-5) then
@@ -1599,15 +1635,16 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call range_check('VA', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, &
-250., 250., bad_range, Time)
#ifndef SW_DYNAMICS
- call range_check('TA', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, &
-#ifdef HIWPP
- 130., 350., bad_range, Time) !DCMIP ICs have very low temperatures
-#else
+ if (is_ideal_case) then
+ call range_check('TA', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, &
+ 100., 500., bad_range, Time) !DCMIP ICs have very wide range of temperatures
+ else
+ call range_check('TA', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, &
150., 350., bad_range, Time)
-#endif
-#endif
+ endif
call range_check('Qv', Atm(n)%q(:,:,:,sphum), isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, &
-1.e-8, 1.e20, bad_range, Time)
+#endif
endif
@@ -1631,14 +1668,28 @@ 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)
#endif
if(id_ps > 0) used=send_data(id_ps, Atm(n)%ps(isc:iec,jsc:jec), Time)
+ if(id_prec > 0) used=send_data(id_prec, Atm(n)%inline_mp%prer(isc:iec,jsc:jec)+ &
+ Atm(n)%inline_mp%prei(isc:iec,jsc:jec)+ &
+ Atm(n)%inline_mp%pres(isc:iec,jsc:jec)+Atm(n)%inline_mp%preg(isc:iec,jsc:jec), Time)
if(id_prer > 0) used=send_data(id_prer, Atm(n)%inline_mp%prer(isc:iec,jsc:jec), Time)
if(id_prei > 0) used=send_data(id_prei, Atm(n)%inline_mp%prei(isc:iec,jsc:jec), Time)
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)
+ if(id_cond > 0) used=send_data(id_cond, Atm(n)%inline_mp%cond(isc:iec,jsc:jec), Time)
+ if(id_dep > 0) used=send_data(id_dep, Atm(n)%inline_mp%dep(isc:iec,jsc:jec), Time)
+ if(id_reevap > 0) used=send_data(id_reevap, Atm(n)%inline_mp%reevap(isc:iec,jsc:jec), Time)
+ if(id_sub > 0) used=send_data(id_sub, Atm(n)%inline_mp%sub(isc:iec,jsc:jec), 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)
@@ -1670,6 +1721,11 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
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 (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)
+ if (idiag%id_v_dt_sg > 0) used=send_data(idiag%id_v_dt_sg, Atm(n)%sg_diag%v_dt(isc:iec,jsc:jec,1:npz), Time)
+ if (idiag%id_qv_dt_sg > 0) used=send_data(idiag%id_qv_dt_sg, Atm(n)%sg_diag%qv_dt(isc:iec,jsc:jec,1:npz), Time)
+
if(id_c15>0 .or. id_c25>0 .or. id_c35>0 .or. id_c45>0) then
call wind_max(isc, iec, jsc, jec ,isd, ied, jsd, jed, Atm(n)%ua(isc:iec,jsc:jec,npz), &
Atm(n)%va(isc:iec,jsc:jec,npz), ws_max, Atm(n)%domain)
@@ -1846,7 +1902,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
allocate ( a3(isc:iec,jsc:jec,npz+1) )
! Modified pv_entropy to get potential temperature at layer interfaces (last variable)
! The values are needed for interpolate_z
- ! Note: this is expensive computation.
+ ! Note: this is expensive computation.
call pv_entropy(isc, iec, jsc, jec, ngc, npz, wk, &
Atm(n)%gridstruct%f0, Atm(n)%pt, Atm(n)%pkz, Atm(n)%delp, grav, a3)
if ( id_pv > 0) then
@@ -2454,7 +2510,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
used = send_data(id_tq, a2*ginv, Time)
endif
-#ifdef HIWPP
+
Cl = get_tracer_index (MODEL_ATMOS, 'Cl')
Cl2 = get_tracer_index (MODEL_ATMOS, 'Cl2')
if (Cl > 0 .and. Cl2 > 0) then
@@ -2549,7 +2605,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
deallocate(var2)
endif
-#endif
+
if ( id_iw>0 ) then
a2 = 0.
if (ice_wat > 0) then
@@ -2862,7 +2918,9 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
#ifdef GFS_PHYS
- if(id_delp > 0 .or. id_cape > 0 .or. id_cin > 0 .or. ((.not. Atm(n)%flagstruct%hydrostatic) .and. id_pfnh > 0)) then
+ if(id_delp > 0 .or. id_cape > 0 .or. id_cin > 0 .or. &
+ ((.not. Atm(n)%flagstruct%hydrostatic) .and. (id_pfnh > 0 .or. id_ppnh > 0)) .or. &
+ id_brn > 0 .or. id_shear06 > 0) then
do k=1,npz
do j=jsc,jec
do i=isc,iec
@@ -2872,49 +2930,66 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
if (id_delp > 0) used=send_data(id_delp, wk, Time)
endif
-
- if( ( (.not. Atm(n)%flagstruct%hydrostatic) .and. id_pfnh > 0) .or. id_cape > 0 .or. id_cin > 0) then
- do k=1,npz
- do j=jsc,jec
- do i=isc,iec
- wk(i,j,k) = -wk(i,j,k)/(Atm(n)%delz(i,j,k)*grav)*rdgas* &
- Atm(n)%pt(i,j,k)*(1.+zvir*Atm(n)%q(i,j,k,sphum))
- enddo
- enddo
- enddo
-! if (prt_minmax) then
-! call prt_maxmin(' PFNH (mb)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, npz, 1.E-2)
-! endif
- used=send_data(id_pfnh, wk, Time)
- endif
#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
- if( (.not. Atm(n)%flagstruct%hydrostatic) .and. (id_pfnh > 0 .or. id_cape > 0 .or. id_cin > 0)) then
- do k=1,npz
+ do k=1,npz
do j=jsc,jec
do i=isc,iec
+#ifdef GFS_PHYS
+ wk(i,j,k) = -wk(i,j,k)/(Atm(n)%delz(i,j,k)*grav)*rdgas* &
+ Atm(n)%pt(i,j,k)*(1.+zvir*Atm(n)%q(i,j,k,sphum))
+#else
wk(i,j,k) = -Atm(n)%delp(i,j,k)/(Atm(n)%delz(i,j,k)*grav)*rdgas* &
Atm(n)%pt(i,j,k)*(1.+zvir*Atm(n)%q(i,j,k,sphum))
+
+#endif
enddo
enddo
enddo
+! if (prt_minmax) then
+! call prt_maxmin(' PFNH (mb)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, npz, 1.E-2)
+! endif
used=send_data(id_pfnh, wk, Time)
- endif
+ 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)
+#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
#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
+ enddo
+ enddo
+ enddo
+ if (id_ppnh > 0) used=send_data(id_ppnh, wk, Time)
+ endif
+
+! if (allocated(a3)) deallocate(a3)
+
+ endif
- if( Atm(n)%flagstruct%hydrostatic .and. (id_pfhy > 0 .or. id_cape > 0 .or. id_cin > 0) ) then
+ 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
- wk(i,j,k) = 0.5 *(Atm(n)%pe(i,k,j)+Atm(n)%pe(i,k+1,j))
+#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) then
+ 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))
@@ -2946,6 +3021,10 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
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
+
deallocate(var2)
deallocate(a3)
@@ -3064,10 +3143,10 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if (.not. allocated(a3)) allocate(a3(isc:iec,jsc:jec,npz))
-! call dbzcalc_smithxue(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
- call dbzcalc(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
+ call rad_ref(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
a3, a2, allmax, Atm(n)%bd, npz, Atm(n)%ncnst, Atm(n)%flagstruct%hydrostatic, &
- zvir, .false., .false., .false., .true., Atm(n)%flagstruct%do_inline_mp ) ! GFDL MP has constant N_0 intercept
+ zvir, .false., .false., .false., .true., Atm(n)%flagstruct%do_inline_mp, &
+ sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top) ! GFDL MP has constant N_0 intercept
if (id_dbz > 0) used=send_data(id_dbz, a3, time)
if (id_maxdbz > 0) used=send_data(id_maxdbz, a2, time)
@@ -3248,19 +3327,19 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
if ( id_t_plev_ave > 0) then
do j=jsc,jec
- call mappm(npz, Atm(n)%peln(isc:iec,1:npz+1,j), Atm(n)%pt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 1, 4, ptop)
+ call mappm(npz, Atm(n)%peln(isc:iec,1:npz+1,j), Atm(n)%pt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 1, 4)
enddo
if (id_t_plev_ave > 0) used=send_data(id_t_plev_ave, a3, Time)
endif
if ( id_t_dt_gfdlmp_plev_ave > 0 ) then
do j=jsc,jec
- call mappm(npz, Atm(n)%peln(isc:iec,1:npz+1,j), Atm(n)%inline_mp%t_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 1, 4, ptop)
+ call mappm(npz, Atm(n)%peln(isc:iec,1:npz+1,j), Atm(n)%inline_mp%t_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 1, 4)
enddo
if (id_t_dt_gfdlmp_plev_ave > 0) used=send_data(id_t_dt_gfdlmp_plev_ave, a3, Time)
endif
if ( id_t_dt_phys_plev_ave > 0 ) then
do j=jsc,jec
- call mappm(npz, Atm(n)%peln(isc:iec,1:npz+1,j), Atm(n)%phys_diag%phys_t_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 1, 4, ptop)
+ call mappm(npz, Atm(n)%peln(isc:iec,1:npz+1,j), Atm(n)%phys_diag%phys_t_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 1, 4)
enddo
if (id_t_dt_phys_plev_ave > 0) used=send_data(id_t_dt_phys_plev_ave, a3, Time)
endif
@@ -3271,19 +3350,19 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
if ( id_q_plev_ave > 0 ) then
do j=jsc,jec
- call mappm(npz, Atm(n)%pe(isc:iec,1:npz+1,j), Atm(n)%q(isc:iec,j,:,sphum), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 0, 8, ptop)
+ call mappm(npz, Atm(n)%pe(isc:iec,1:npz+1,j), Atm(n)%q(isc:iec,j,:,sphum), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 0, 8)
enddo
if (id_q_plev_ave > 0) used=send_data(id_q_plev_ave, a3, Time)
endif
if ( id_qv_dt_gfdlmp_plev_ave > 0 ) then
do j=jsc,jec
- call mappm(npz, Atm(n)%pe(isc:iec,1:npz+1,j), Atm(n)%inline_mp%qv_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 0, 8, ptop)
+ call mappm(npz, Atm(n)%pe(isc:iec,1:npz+1,j), Atm(n)%inline_mp%qv_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 0, 8)
enddo
if (id_qv_dt_gfdlmp_plev_ave > 0) used=send_data(id_qv_dt_gfdlmp_plev_ave, a3, Time)
endif
if ( id_qv_dt_phys_plev_ave > 0 ) then
do j=jsc,jec
- call mappm(npz, Atm(n)%pe(isc:iec,1:npz+1,j), Atm(n)%phys_diag%phys_qv_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 0, 8, ptop)
+ call mappm(npz, Atm(n)%pe(isc:iec,1:npz+1,j), Atm(n)%phys_diag%phys_qv_dt(isc:iec,j,:), nplev_ave, a2, a3(isc:iec,j,:), isc, iec, 0, 8)
enddo
if (id_qv_dt_phys_plev_ave > 0) used=send_data(id_qv_dt_phys_plev_ave, a3, Time)
endif
@@ -3369,6 +3448,7 @@ 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)
allocate( a3(isc:iec,jsc:jec,npz) )
if(id_theta_e > 0 ) then
@@ -3458,8 +3538,6 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
deallocate ( pt1 )
endif
-
-#ifndef SW_DYNAMICS
do itrac=1, Atm(n)%ncnst
call get_tracer_names (MODEL_ATMOS, itrac, tname)
if (id_tracer(itrac) > 0 .and. itrac.gt.nq) then
@@ -3613,6 +3691,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
endif
+#ifndef SW_DYNAMICS
! terms related with vertical wind ( Atm(n)%w ):
if(.not.Atm(n)%flagstruct%hydrostatic) then
! vertical moisture flux
@@ -3693,6 +3772,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
deallocate ( a4 )
+#endif
! Maximum overlap cloud fraction
if ( .not. Atm(n)%gridstruct%bounded_domain ) then
@@ -3710,7 +3790,6 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
endif
-#endif
if (do_diag_debug) then
call debug_column(Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%q, &
@@ -3883,9 +3962,16 @@ subroutine range_check_3d(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, b
if( qminq_hi ) then
if(master) write(*,*) 'Range_check Warning:', qname, ' max = ', qmax, ' min = ', qmin
if (present(Time)) then
- call get_date(Time, year, month, day, hour, minute, second)
- if (master) write(*,999) year, month, day, hour, minute, second
-999 format(' Range violation on: ', I4, '/', I02, '/', I02, ' ', I02, ':', I02, ':', I02)
+ if (m_calendar) then
+ call get_date(Time, year, month, day, hour, minute, second)
+ if (master) write(*,999) year, month, day, hour, minute, second
+999 format(' Range violation on: ', I4, '/', I02, '/', I02, ' ', I02, ':', I02, ':', I02)
+ else
+ call get_time(Time, second, day)
+ year = 0 ; month = 0 ; hour = 0 ; minute = 0
+ if (master) write(*,996) day, second
+996 format(' Range violation on: ', I6, ' days ', I05, ' seconds')
+ endif
endif
if ( present(bad_range) ) then
bad_range = .true.
@@ -4419,11 +4505,11 @@ subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout,
real, parameter:: gcp = grav / cp_air
real:: qe(is:ie,km+1)
real, dimension(is:ie,km):: q2, dp
- real:: s0, a6
+ 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 private(k1,s0,a6,q2,dp,qe)
+!$OMP private(k1,s0,a6,q2,dp,qe,pbot,alpha,ts,t0,tmp)
do j=js,je
do i=is,ie
@@ -4445,11 +4531,32 @@ subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout,
elseif ( pout(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)) / &
- ( exp(kappa*pe(i,km,j)) - exp(kappa*pe(i,km-2,j)) )
+! qout(i,j,n) = gcp*exp(kappa*pout(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)
+ 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)
+ endif
+ if (tmp-ts.lt.0) then
+ alpha = 0
+ else
+ alpha = rdgas*(tmp-ts)/(wz(i,j,km+1)*grav)
+ endif
+ endif
+ qout(i,j,n) = ts*exp(alpha*(pout(n)-pe(i,km+1,j)))
+!-----------------------------------------------------------------------
else
qout(i,j,n) = qe(i,km+1)
endif
@@ -5086,27 +5193,27 @@ subroutine ppme(p,qe,delp,im,km)
km1 = km - 1
do k=2,km
- do i=1,im
- a6(i,k) = delp(i,k-1) + delp(i,k)
- enddo
+ do i=1,im
+ a6(i,k) = delp(i,k-1) + delp(i,k)
+ enddo
enddo
do k=1,km1
- do i=1,im
- delq(i,k) = p(i,k+1) - p(i,k)
- enddo
+ do i=1,im
+ delq(i,k) = p(i,k+1) - p(i,k)
+ enddo
enddo
do k=2,km1
- do i=1,im
- c1 = (delp(i,k-1)+0.5*delp(i,k))/a6(i,k+1)
- c2 = (delp(i,k+1)+0.5*delp(i,k))/a6(i,k)
- tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / &
+ do i=1,im
+ c1 = (delp(i,k-1)+0.5*delp(i,k))/a6(i,k+1)
+ c2 = (delp(i,k+1)+0.5*delp(i,k))/a6(i,k)
+ tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / &
(a6(i,k)+delp(i,k+1))
- qmax = max(p(i,k-1),p(i,k),p(i,k+1)) - p(i,k)
- qmin = p(i,k) - min(p(i,k-1),p(i,k),p(i,k+1))
- dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp)
- enddo
+ qmax = max(p(i,k-1),p(i,k),p(i,k+1)) - p(i,k)
+ qmin = p(i,k) - min(p(i,k-1),p(i,k),p(i,k+1))
+ dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp)
+ enddo
enddo
!****6***0*********0*********0*********0*********0*********0**********72
@@ -5450,210 +5557,78 @@ subroutine nh_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, &
end subroutine nh_total_energy
+ subroutine compute_brn(ua, va, delp, delz, cape, bd, npz, Time)
- subroutine dbzcalc(q, pt, delp, peln, delz, &
- dbz, maxdbz, allmax, bd, npz, ncnst, &
- hydrostatic, zvir, in0r, in0s, in0g, iliqskin, do_inline_mp)
+ type(fv_grid_bounds_type), intent(IN) :: bd
+ integer, intent(IN) :: npz
+ type(time_type), intent(in) :: Time
+ real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed, npz), intent(IN) :: ua, va, delp
+ real, dimension(bd%isc:bd%iec,bd%jsc:bd%jec, npz), intent(IN) :: delz
+ real, dimension(bd%isc:bd%iec,bd%jsc:bd%jec), intent(IN) :: cape
+ real, dimension(bd%isc:bd%iec,bd%jsc:bd%jec) :: brn, shear06
- !Code from Mark Stoelinga's dbzcalc.f from the RIP package.
- !Currently just using values taken directly from that code, which is
- ! consistent for the MM5 Reisner-2 microphysics. From that file:
+ real, dimension(bd%isc:bd%iec,bd%jsc:bd%jec) :: u06, u005, v06, v005, ht, m06, m005
+ real :: tmp1, tmp2
+ logical :: used
-! This routine computes equivalent reflectivity factor (in dBZ) at
-! each model grid point. In calculating Ze, the RIP algorithm makes
-! assumptions consistent with those made in an early version
-! (ca. 1996) of the bulk mixed-phase microphysical scheme in the MM5
-! model (i.e., the scheme known as "Resiner-2"). For each species:
-!
-! 1. Particles are assumed to be spheres of constant density. The
-! densities of rain drops, snow particles, and graupel particles are
-! taken to be rho_r = rho_l = 1000 kg m^-3, rho_s = 100 kg m^-3, and
-! rho_g = 400 kg m^-3, respectively. (l refers to the density of
-! liquid water.)
-!
-! 2. The size distribution (in terms of the actual diameter of the
-! particles, rather than the melted diameter or the equivalent solid
-! ice sphere diameter) is assumed to follow an exponential
-! distribution of the form N(D) = N_0 * exp( lambda*D ).
-!
-! 3. If in0X=0, the intercept parameter is assumed constant (as in
-! early Reisner-2), with values of 8x10^6, 2x10^7, and 4x10^6 m^-4,
-! for rain, snow, and graupel, respectively. Various choices of
-! in0X are available (or can be added). Currently, in0X=1 gives the
-! variable intercept for each species that is consistent with
-! Thompson, Rasmussen, and Manning (2004, Monthly Weather Review,
-! Vol. 132, No. 2, pp. 519-542.)
-!
-! 4. If iliqskin=1, frozen particles that are at a temperature above
-! freezing are assumed to scatter as a liquid particle.
-!
-! More information on the derivation of simulated reflectivity in RIP
-! can be found in Stoelinga (2005, unpublished write-up). Contact
-! Mark Stoelinga (stoeling@atmos.washington.edu) for a copy.
-
-! 22sep16: Modifying to use the GFDL MP parameters. If doing so remember
-! that the GFDL MP assumes a constant intercept (in0X = .false.)
-! Ferrier-Aligo has an option for fixed slope (rather than fixed intercept).
-! Thompson presumably is an extension of Reisner MP.
-
- use gfdl_cloud_microphys_mod, only : do_hail, rhor, rhos, rhog, rhoh, rnzr, rnzs, rnzg, rnzh
- use gfdl_mp_mod, only: do_hail_inline => do_hail ! assuming same densities and numbers in both inline and traditional GFDL MP
- implicit none
-
- type(fv_grid_bounds_type), intent(IN) :: bd
- integer, intent(IN) :: npz, ncnst
- real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz) :: pt, delp
- real, intent(IN), dimension(bd%is:, bd%js:, 1:) :: delz
- real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst) :: q
- real, intent(IN), dimension(bd%is :bd%ie, npz+1, bd%js:bd%je) :: peln
- real, intent(OUT), dimension(bd%is :bd%ie, bd%js :bd%je , npz) :: dbz
- real, intent(OUT), dimension(bd%is :bd%ie, bd%js :bd%je) :: maxdbz
- logical, intent(IN) :: hydrostatic, in0r, in0s, in0g, iliqskin, do_inline_mp
- real, intent(IN) :: zvir
- real, intent(OUT) :: allmax
-
- !Parameters for constant intercepts (in0[rsg] = .false.)
- !Using GFDL MP values
- real(kind=R_GRID), parameter:: vconr = 2503.23638966667
- real(kind=R_GRID), parameter:: vcong = 87.2382675
- real(kind=R_GRID), parameter:: vcons = 6.6280504
- real(kind=R_GRID), parameter:: vconh = vcong
- real(kind=R_GRID), parameter:: normr = 25132741228.7183
- real(kind=R_GRID), parameter:: normg = 5026548245.74367
- real(kind=R_GRID), parameter:: normh = pi*rhoh*rnzh
- real(kind=R_GRID), parameter:: norms = 942477796.076938
-
- !Constants for variable intercepts
- !Will need to be changed based on MP scheme
- real, parameter :: r1=1.e-15
- real, parameter :: ron=8.e6
- real, parameter :: ron2=1.e10
- real, parameter :: son=2.e7
- real, parameter :: gon=5.e7
- real, parameter :: ron_min = 8.e6
- real, parameter :: ron_qr0 = 0.00010
- real, parameter :: ron_delqr0 = 0.25*ron_qr0
- real, parameter :: ron_const1r = (ron2-ron_min)*0.5
- real, parameter :: ron_const2r = (ron2+ron_min)*0.5
-
- !Other constants
- real, parameter :: gamma_seven = 720.
- real, parameter :: alpha = 0.224
- real(kind=R_GRID), parameter :: factor_s = gamma_seven * 1.e18 * (1./(pi*rhos))**1.75 &
- * (rhos/rhor)**2 * alpha
- real, parameter :: qmin = 1.E-12
- real, parameter :: tice = 273.16
-
-! Double precision
- real(kind=R_GRID), dimension(bd%is:bd%ie) :: rhoair, denfac, z_e
- real(kind=R_GRID):: qr1, qs1, qg1, t1, t2, t3, rwat, vtr, vtg, vts
- real(kind=R_GRID):: factorb_s, factorb_g
- real(kind=R_GRID):: temp_c, pres, sonv, gonv, ronv
-
- real :: rhogh, vcongh, normgh
+ integer :: i,j,k
- integer :: i,j,k
- integer :: is, ie, js, je
-
- is = bd%is
- ie = bd%ie
- js = bd%js
- je = bd%je
- if (rainwat < 1) return
-
- dbz(:,:,1:mp_top) = -20.
- maxdbz(:,:) = -20. !Minimum value
- allmax = -20.
-
- if ((do_hail .and. .not. do_inline_mp) .or. (do_hail_inline .and. do_inline_mp)) then
- rhogh = rhoh
- vcongh = vconh
- normgh = normh
- else
- rhogh = rhog
- vcongh = vcong
- normgh = normg
- endif
-
-!$OMP parallel do default(shared) private(rhoair,t1,t2,t3,denfac,vtr,vtg,vts,z_e)
- do k=mp_top+1, npz
- do j=js, je
- if (hydrostatic) then
- do i=is, ie
- rhoair(i) = delp(i,j,k)/( (peln(i,k+1,j)-peln(i,k,j)) * rdgas * pt(i,j,k) * ( 1. + zvir*q(i,j,k,sphum) ) )
- denfac(i) = sqrt(min(10., 1.2/rhoair(i)))
- z_e(i) = 0.
- enddo
- else
- do i=is, ie
- rhoair(i) = -delp(i,j,k)/(grav*delz(i,j,k)) ! moist air density
- denfac(i) = sqrt(min(10., 1.2/rhoair(i)))
- z_e(i) = 0.
- enddo
- endif
- if (rainwat > 0) then
- do i=is, ie
-! The following form vectorizes better & more consistent with GFDL_MP
-! SJL notes: Marshall-Palmer, dBZ = 200*precip**1.6, precip = 3.6e6*t1/rhor*vtr ! [mm/hr]
-! GFDL_MP terminal fall speeds are used
-! Date modified 20170701
-! Account for excessively high cloud water -> autoconvert (diag only) excess cloud water
- t1 = rhoair(i)*max(qmin, q(i,j,k,rainwat)+dim(q(i,j,k,liq_wat), 1.0e-3))
- vtr = max(1.e-3, vconr*denfac(i)*exp(0.2 *log(t1/normr)))
- z_e(i) = 200.*exp(1.6*log(3.6e6*t1/rhor*vtr))
- ! z_e = 200.*(exp(1.6*log(3.6e6*t1/rhor*vtr)) + exp(1.6*log(3.6e6*t3/rhogh*vtg)) + exp(1.6*log(3.6e6*t2/rhos*vts)))
- enddo
- endif
- if (graupel > 0) then
- do i=is, ie
- t3 = rhoair(i)*max(qmin, q(i,j,k,graupel))
- vtg = max(1.e-3, vcongh*denfac(i)*exp(0.125 *log(t3/normgh)))
- z_e(i) = z_e(i) + 200.*exp(1.6*log(3.6e6*t3/rhogh*vtg))
- enddo
- endif
- if (snowwat > 0) then
- do i=is, ie
- t2 = rhoair(i)*max(qmin, q(i,j,k,snowwat))
- ! vts = max(1.e-3, vcons*denfac*exp(0.0625*log(t2/norms)))
- z_e(i) = z_e(i) + (factor_s/alpha)*t2*exp(0.75*log(t2/rnzs))
- ! z_e = 200.*(exp(1.6*log(3.6e6*t1/rhor*vtr)) + exp(1.6*log(3.6e6*t3/rhogh*vtg)) + exp(1.6*log(3.6e6*t2/rhos*vts)))
- enddo
- endif
- do i=is,ie
- dbz(i,j,k) = 10.*log10( max(0.01, z_e(i)) )
- enddo
- enddo
- enddo
+ integer :: isc, iec, jsc, jec
+ integer :: isd, ied, jsd, jed
-!$OMP parallel do default(shared)
- do j=js, je
- do k=mp_top+1, npz
- do i=is, ie
- maxdbz(i,j) = max(dbz(i,j,k), maxdbz(i,j))
- enddo
- enddo
- enddo
+ isc = bd%is
+ iec = bd%ie
+ jsc = bd%js
+ jec = bd%je
+ isd = bd%isd
+ ied = bd%ied
+ jsd = bd%jsd
+ jed = bd%jed
- do j=js, je
- do i=is, ie
- allmax = max(maxdbz(i,j), allmax)
- enddo
- enddo
- end subroutine dbzcalc
+ !Bulk-Richardson number: CAPE / 0.5* (U_{0--6km} - U_{0--500m})**2
+ do j=jsc,jec
+ do i=isc,iec
+ u06(i,j) = 0.
+ u005(i,j) = 0.
+ v06(i,j) = 0.
+ v005(i,j) = 0.
+ m06(i,j) = 0.
+ m005(i,j) = 0.
+ ht(i,j) = -delz(i,j,npz)*0.5
+ enddo
+ enddo
+ do k=npz,2,-1
+ do j=jsc,jec
+ do i=isc,iec
+ if (ht(i,j) <= 6000.) then
+ u06(i,j) = u06(i,j) + delp(i,j,k)*ua(i,j,k)
+ v06(i,j) = v06(i,j) + delp(i,j,k)*va(i,j,k)
+ m06(i,j) = m06(i,j) + delp(i,j,k)
+ endif
+ if (ht(i,j) <= 500.) then
+ u005(i,j) = u005(i,j) + delp(i,j,k)*ua(i,j,k)
+ v005(i,j) = v005(i,j) + delp(i,j,k)*va(i,j,k)
+ m005(i,j) = m005(i,j) + delp(i,j,k)
+ endif
+ ht(i,j) = ht(i,j) - 0.5*(delz(i,j,k) + delz(i,j,k-1))
+ enddo
+ enddo
+ enddo
+ do j=jsc,jec
+ do i=isc,iec
+ tmp1 = u005(i,j)/m005(i,j) - u06(i,j)/m06(i,j)
+ tmp2 = v005(i,j)/m005(i,j) - v06(i,j)/m06(i,j)
+ shear06(i,j) = sqrt(tmp1*tmp1 + tmp2*tmp2)
+ brn(i,j) = cape(i,j)/(0.5*max(0.1,shear06(i,j)*shear06(i,j)))
+ enddo
+ enddo
- subroutine max_vorticity_hy1(is, ie, js, je, km, vort, maxvorthy1)
- integer, intent(in):: is, ie, js, je, km
- real, intent(in), dimension(is:ie,js:je,km):: vort
- real, intent(inout), dimension(is:ie,js:je):: maxvorthy1
- integer i, j, k
+ if (id_brn > 0) used=send_data(id_brn, brn, Time)
+ if (id_shear06 > 0) used=send_data(id_shear06, shear06, Time)
- do j=js,je
- do i=is,ie
- maxvorthy1(i,j)=max(maxvorthy1(i,j),vort(i,j,km))
- enddo ! i-loop
- enddo ! j-loop
- end subroutine max_vorticity_hy1
+
+ end subroutine compute_brn
subroutine max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostatic, &
pt, peln, phis, grav, vort, maxvort, z_bot, z_top)
diff --git a/tools/fv_diagnostics.h b/tools/fv_diagnostics.h
index ac73e99af..099d4c290 100644
--- a/tools/fv_diagnostics.h
+++ b/tools/fv_diagnostics.h
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -33,7 +33,7 @@
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_ctz, id_w1km, id_wmaxup, id_wmaxdn, id_cape, id_cin
+ 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
@@ -66,6 +66,10 @@
integer ic_ps, ic_ua, ic_va, ic_ppt
integer ic_sphum
integer, allocatable :: id_tracer(:)
+
+! dissipation estimates
+ integer :: id_diss
+
! ESM requested diagnostics - dry mass/volume mixing ratios
integer, allocatable :: id_tracer_dmmr(:)
integer, allocatable :: id_tracer_dvmr(:)
@@ -75,7 +79,7 @@
real, allocatable :: zsurf(:,:)
real, allocatable :: pt1(:)
- integer :: id_prer, id_prei, id_pres, id_preg, id_cond, id_dep, id_reevap, id_sub
+ integer :: id_prec, id_prer, id_prei, id_pres, id_preg, id_cond, id_dep, id_reevap, id_sub
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
@@ -92,7 +96,6 @@
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
-
#endif _FV_DIAG__
diff --git a/tools/fv_eta.F90 b/tools/fv_eta.F90
index 426331273..3315846f1 100644
--- a/tools/fv_eta.F90
+++ b/tools/fv_eta.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_eta_mod
use constants_mod, only: kappa, grav, cp_air, rdgas
use fv_mp_mod, only: is_master
@@ -40,7 +41,7 @@ subroutine set_eta(km, ks, ptop, ak, bk, npz_type)
integer, intent(in):: km ! vertical dimension
integer, intent(out):: ks ! number of pure p layers
real:: a60(61),b60(61)
-! Thfollowing L63 setting is the same as NCEP GFS's L64 except the top
+! The following L63 setting is the same as NCEP GFS's L64 except the top
! 3 layers
data a60/300.0000, 430.00000, 558.00000, &
700.00000, 863.05803, 1051.07995, &
@@ -609,6 +610,15 @@ subroutine set_eta(km, ks, ptop, ak, bk, npz_type,fv_eta_file)
enddo
endif
+
+ ! xi chen's l65
+ case (65)
+ ks = 29
+ do k=1,km+1
+ ak(k) = a65(k)
+ bk(k) = b65(k)
+ enddo
+
!-->cjg
case (68)
ks = 27
@@ -621,11 +631,24 @@ subroutine set_eta(km, ks, ptop, ak, bk, npz_type,fv_eta_file)
ptop = 1.
stretch_fac = 1.03
auto_routine = 1
- case (75) ! HS-SGO test configuration
- pint = 100.E2
- ptop = 10.E2
- stretch_fac = 1.035
- auto_routine = 6
+
+ ! kgao: introduce EMC's L75 config
+ case (75)
+ if (trim(npz_type) == 'emc') then
+ ! EMC's L75 config
+ ks = 12
+ do k=1,km+1
+ ak(k) = a75(k)
+ bk(k) = b75(k)
+ enddo
+ else
+ ! HS-SGO test configuration
+ pint = 100.E2
+ ptop = 10.E2
+ stretch_fac = 1.035
+ auto_routine = 6
+ endif
+
case (79) ! N = 10, M=5
if (trim(npz_type) == 'gcrm') then
pint = 100.E2
@@ -664,6 +687,14 @@ subroutine set_eta(km, ks, ptop, ak, bk, npz_type,fv_eta_file)
enddo
!<--cjg
+ ! kgao L88
+ case (88)
+ ks = 20 !19 bug fix
+ do k=1,km+1
+ ak(k) = a88(k)
+ bk(k) = b88(k)
+ enddo
+
case (100)
ks = 38
do k=1,km+1
@@ -693,6 +724,14 @@ subroutine set_eta(km, ks, ptop, ak, bk, npz_type,fv_eta_file)
ptop = 1.
stretch_fac = 1.03
auto_routine = 2
+ elseif (trim(npz_type) == 'gfs') then
+ ks = 39
+ ptop = a127(1)
+ pint = a127(ks+1)
+ do k=1,km+1
+ ak(k) = a127(k)
+ bk(k) = b127(k)
+ enddo
else
ptop = 1.
pint = 75.E2
diff --git a/tools/fv_eta.h b/tools/fv_eta.h
index dbb73a235..66660fb96 100644
--- a/tools/fv_eta.h
+++ b/tools/fv_eta.h
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
#ifndef _FV_ETA_
#define _FV_ETA__
@@ -42,11 +43,15 @@
real a63meso(64),b63meso(64)
real a64(65),b64(65)
real a64gfs(65),b64gfs(65)
+ real a65(66),b65(66) ! kgao: L65 with enhanced surface resolution by xi chen
real a68(69),b68(69) ! cjg: grid with enhanced PBL resolution
real a96(97),b96(97) ! cjg: grid with enhanced PBL resolution
+ real a88(89),b88(89) ! kgao: grid with enhanced PBL resolution
+ real a75(76),b75(76) ! kgao: emc grid with enhanced PBL resolution
real a100(101),b100(101)
real a104(105),b104(105)
real a125(126),b125(126)
+ real a127(128),b127(128)
!-----------------------------------------------
! GFDL AM2-L24: modified by SJL at the model top
@@ -501,7 +506,7 @@
1.0000000000e+00 /
! This is activated by USE_GFSL63
-! Thfollowing L63 setting is the same as NCEP GFS's L64 except the top
+! The following L63 setting is the same as NCEP GFS's L64 except the top
! 3 layers
data a63/64.247, 137.790, 221.958, &
318.266, 428.434, 554.424, &
@@ -682,6 +687,51 @@
0.87352, 0.91502, 0.95235, &
0.98511, 1.00000 /
+ data a65/1.00000000, 5.13470268, 14.04240036, &
+ 30.72783852, 53.79505539, 82.45489502, &
+ 117.05598450, 158.62843323, 208.79000854, &
+ 270.02725220, 345.50848389, 438.41940308, &
+ 551.85266113, 689.25054932, 854.40936279, &
+ 1051.47802734, 1284.95031738, 1559.65148926, &
+ 1880.71691895, 2253.56542969, 2683.86547852, &
+ 3177.49560547, 3740.49951172, 4379.03613281, &
+ 5099.32617188, 5907.59326172, 6810.00781250, &
+ 7812.62353516, 8921.31933594, 10141.73632812,&
+ 11285.93066406, 12188.79101562, 12884.30078125,&
+ 13400.11523438, 13758.84960938, 13979.10351562,&
+ 14076.26074219, 14063.13085938, 13950.45507812,&
+ 13747.31445312, 13461.45410156, 13099.54199219,&
+ 12667.38183594, 12170.08203125, 11612.18847656,&
+ 10997.79980469, 10330.65039062, 9611.05468750, &
+ 8843.30371094, 8045.85009766, 7236.31152344, &
+ 6424.55712891, 5606.50927734, 4778.05908203, &
+ 3944.97241211, 3146.77514648, 2416.63354492, &
+ 1778.22607422, 1246.21462402, 826.51950684, &
+ 511.21385254, 290.74072876, 150.00000000, &
+ 68.89300000, 14.99899865, 0.00000000 /
+
+ data b65/0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, &
+ 0.00193294, 0.00749994, 0.01640714, &
+ 0.02841953, 0.04334756, 0.06103661, &
+ 0.08135860, 0.10420541, 0.12948355, &
+ 0.15711005, 0.18700911, 0.21910952, &
+ 0.25334257, 0.28964061, 0.32793567, &
+ 0.36815873, 0.41023913, 0.45429301, &
+ 0.50016892, 0.54688859, 0.59356427, &
+ 0.63976413, 0.68518244, 0.72950502, &
+ 0.77231618, 0.81251526, 0.84921405, &
+ 0.88174411, 0.90978803, 0.93327247, &
+ 0.95249488, 0.96783525, 0.97980107, &
+ 0.98896214, 0.99575002, 1.00000000 /
!-->cjg
data a68/1.00000, 2.68881, 5.15524, &
8.86683, 14.20349, 22.00278, &
@@ -799,6 +849,129 @@
0.97918, 0.98723, 0.99460, &
1.00000 /
!<--cjg
+
+!---> kgao: remove top layers from l96
+ data a88/65.28397, &
+ 95.48274, 137.90344, 196.76073, &
+ 277.45330, 386.81095, 533.37018, &
+ 727.67600, 982.60677, 1313.71685, &
+ 1739.59104, 2282.20281, 2967.26766, &
+ 3824.58158, 4888.33404, 6197.38450, &
+ 7795.49158, 9731.48414, 11969.71024, &
+ 14502.88894, 17304.52434, 20134.76139, &
+ 22536.63814, 24252.54459, 25230.65591, &
+ 25585.72044, 25539.91412, 25178.87141, &
+ 24644.84493, 23978.98781, 23245.49366, &
+ 22492.11600, 21709.93990, 20949.64473, &
+ 20225.94258, 19513.31158, 18829.32485, &
+ 18192.62250, 17589.39396, 17003.45386, &
+ 16439.01774, 15903.91204, 15396.39758, &
+ 14908.02140, 14430.65897, 13967.88643, &
+ 13524.16667, 13098.30227, 12687.56457, &
+ 12287.08757, 11894.41553, 11511.54106, &
+ 11139.22483, 10776.01912, 10419.75711, &
+ 10067.11881, 9716.63489, 9369.61967, &
+ 9026.69066, 8687.29884, 8350.04978, &
+ 8013.20925, 7677.12187, 7343.12994, &
+ 7011.62844, 6681.98102, 6353.09764, &
+ 6025.10535, 5699.10089, 5375.54503, &
+ 5053.63074, 4732.62740, 4413.38037, &
+ 4096.62775, 3781.79777, 3468.45371, &
+ 3157.19882, 2848.25306, 2541.19150, &
+ 2236.21942, 1933.50628, 1632.83741, &
+ 1334.35954, 1038.16655, 744.22318, &
+ 452.71094, 194.91899, 0.00000, &
+ 0.00000 /
+
+ data b88/0.00000, &
+ 0.00000, 0.00000, 0.00000, &
+ 0.00000, 0.00000, 0.00000, &
+ 0.00000, 0.00000, 0.00000, &
+ 0.00000, 0.00000, 0.00000, &
+ 0.00000, 0.00000, 0.00000, &
+ 0.00000, 0.00000, 0.00000, &
+ 0.00000, 0.00000, 0.00193, &
+ 0.00974, 0.02538, 0.04876, &
+ 0.07817, 0.11081, 0.14514, &
+ 0.18007, 0.21486, 0.24866, &
+ 0.28088, 0.31158, 0.34030, &
+ 0.36701, 0.39210, 0.41554, &
+ 0.43733, 0.45774, 0.47707, &
+ 0.49540, 0.51275, 0.52922, &
+ 0.54495, 0.56007, 0.57459, &
+ 0.58850, 0.60186, 0.61471, &
+ 0.62715, 0.63922, 0.65095, &
+ 0.66235, 0.67348, 0.68438, &
+ 0.69510, 0.70570, 0.71616, &
+ 0.72651, 0.73675, 0.74691, &
+ 0.75700, 0.76704, 0.77701, &
+ 0.78690, 0.79672, 0.80649, &
+ 0.81620, 0.82585, 0.83542, &
+ 0.84492, 0.85437, 0.86375, &
+ 0.87305, 0.88229, 0.89146, &
+ 0.90056, 0.90958, 0.91854, &
+ 0.92742, 0.93623, 0.94497, &
+ 0.95364, 0.96223, 0.97074, &
+ 0.97918, 0.98723, 0.99460, &
+ 1.00000 /
+!<--- kgao: end of a88/b88
+
+!---> kgao: EMC L75 config
+
+ data a75/200.0, 572.419, 1104.437, &
+ 1760.239, 2499.052, 3300.438, &
+ 4161.36, 5090.598, 6114.272, &
+ 7241.963, 8489.481, 9855.825, &
+ 11338.34, 12682.56, 13688.97, &
+ 14422.61, 14934.2, 15263.88, &
+ 15443.77, 15499.9, 15453.61, &
+ 15322.6, 15121.64, 14863.23, &
+ 14557.97, 14214.93, 13841.91, &
+ 13445.62, 13031.86, 12605.65, &
+ 12171.31, 11732.57, 11292.65, &
+ 10854.29, 10419.82, 9991.243, &
+ 9570.207, 9158.088, 8756.019, &
+ 8364.893, 7985.424, 7618.15, &
+ 7263.452, 6921.581, 6592.674, &
+ 6276.763, 5963.31, 5652.806, &
+ 5345.765, 5042.658, 4743.966, &
+ 4450.172, 4161.769, 3879.194, &
+ 3602.911, 3333.365, 3071.016, &
+ 2816.274, 2569.556, 2331.264, &
+ 2101.816, 1881.57, 1670.887, &
+ 1470.119, 1279.627, 1099.702, &
+ 930.651, 772.757, 626.305, &
+ 491.525, 368.641, 257.862, &
+ 159.399, 73.396, 0.001, &
+ 0.0/
+ data b75/0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, &
+ 0.0, 0.00250213, 0.00944449,&
+ 0.02010732, 0.03390246, 0.0503391, &
+ 0.06899972, 0.08952269, 0.1115907, &
+ 0.134922, 0.1592647, 0.1843923, &
+ 0.2101002, 0.2362043, 0.2625384, &
+ 0.2889538, 0.3153166, 0.3415084, &
+ 0.3674242, 0.3929729, 0.4180741, &
+ 0.4426602, 0.4666739, 0.4900666, &
+ 0.5127994, 0.5348418, 0.5561699, &
+ 0.5767674, 0.5966232, 0.6157322, &
+ 0.6340936, 0.6517111, 0.668592, &
+ 0.6847468, 0.7007225, 0.7164985, &
+ 0.7320531, 0.7473667, 0.7624187, &
+ 0.7771889, 0.7916558, 0.8058007, &
+ 0.819604, 0.8330461, 0.8461072, &
+ 0.8587694, 0.8710147, 0.8828254, &
+ 0.8941834, 0.9050727, 0.9154776, &
+ 0.9253828, 0.9347721, 0.9436326, &
+ 0.9519511, 0.9597148, 0.966911, &
+ 0.9735298, 0.9795609, 0.9849954, &
+ 0.9898235, 0.9940391, 0.9976355, &
+ 1.0/
+! <--- kgao: end of a75/b75
+
!
! Ultra high troposphere resolution
data a100/100.00000, 300.00000, 800.00000, &
@@ -873,79 +1046,79 @@
0.99223, 1.00000 /
data a104/ &
- 1.8827062944e-01, 7.7977549145e-01, 2.1950593583e+00, &
- 4.9874566624e+00, 9.8041418997e+00, 1.7019717163e+01, &
- 2.7216579591e+01, 4.0518628401e+01, 5.6749646818e+01, &
- 7.5513868331e+01, 9.6315093333e+01, 1.1866706195e+02, &
- 1.4216835396e+02, 1.6653733709e+02, 1.9161605772e+02, &
- 2.1735580129e+02, 2.4379516604e+02, 2.7103771847e+02, &
- 2.9923284173e+02, 3.2856100952e+02, 3.5922338766e+02, &
- 3.9143507908e+02, 4.2542117983e+02, 4.6141487902e+02, &
- 4.9965698106e+02, 5.4039638379e+02, 5.8389118154e+02, &
- 6.3041016829e+02, 6.8023459505e+02, 7.3366009144e+02, &
- 7.9099869949e+02, 8.5258099392e+02, 9.1875827946e+02, &
- 9.8990486716e+02, 1.0664204381e+03, 1.1487325074e+03, &
- 1.2372990044e+03, 1.3326109855e+03, 1.4351954993e+03, &
- 1.5456186222e+03, 1.6644886848e+03, 1.7924597105e+03, &
- 1.9302350870e+03, 2.0785714934e+03, 2.2382831070e+03, &
- 2.4102461133e+03, 2.5954035462e+03, 2.7947704856e+03, &
- 3.0094396408e+03, 3.2405873512e+03, 3.4894800360e+03, &
- 3.7574811281e+03, 4.0460585279e+03, 4.3567926151e+03, &
- 4.6913848588e+03, 5.0516670674e+03, 5.4396113207e+03, &
- 5.8573406270e+03, 6.3071403487e+03, 6.7914704368e+03, &
- 7.3129785102e+03, 7.8745138115e+03, 8.4791420557e+03, &
- 9.1301611750e+03, 9.8311179338e+03, 1.0585825354e+04, &
- 1.1398380836e+04, 1.2273184781e+04, 1.3214959424e+04, &
- 1.4228767429e+04, 1.5320029596e+04, 1.6494540743e+04, &
- 1.7758482452e+04, 1.9118430825e+04, 2.0422798801e+04, &
- 2.1520147587e+04, 2.2416813461e+04, 2.3118184510e+04, &
- 2.3628790785e+04, 2.3952411814e+04, 2.4092209011e+04, &
- 2.4050892106e+04, 2.3830930156e+04, 2.3434818358e+04, &
- 2.2865410898e+04, 2.2126326004e+04, 2.1222420323e+04, &
- 2.0160313690e+04, 1.8948920926e+04, 1.7599915822e+04, &
- 1.6128019809e+04, 1.4550987232e+04, 1.2889169132e+04, &
- 1.1164595563e+04, 9.4227665517e+03, 7.7259097899e+03, &
- 6.1538244381e+03, 4.7808126007e+03, 3.5967415552e+03, &
- 2.5886394104e+03, 1.7415964865e+03, 1.0393721271e+03, &
- 4.6478852032e+02, 7.0308342481e-13, 0.0000000000e+00 /
+ 1.8827062944e-01, 7.7977549145e-01, 2.1950593583e+00, &
+ 4.9874566624e+00, 9.8041418997e+00, 1.7019717163e+01, &
+ 2.7216579591e+01, 4.0518628401e+01, 5.6749646818e+01, &
+ 7.5513868331e+01, 9.6315093333e+01, 1.1866706195e+02, &
+ 1.4216835396e+02, 1.6653733709e+02, 1.9161605772e+02, &
+ 2.1735580129e+02, 2.4379516604e+02, 2.7103771847e+02, &
+ 2.9923284173e+02, 3.2856100952e+02, 3.5922338766e+02, &
+ 3.9143507908e+02, 4.2542117983e+02, 4.6141487902e+02, &
+ 4.9965698106e+02, 5.4039638379e+02, 5.8389118154e+02, &
+ 6.3041016829e+02, 6.8023459505e+02, 7.3366009144e+02, &
+ 7.9099869949e+02, 8.5258099392e+02, 9.1875827946e+02, &
+ 9.8990486716e+02, 1.0664204381e+03, 1.1487325074e+03, &
+ 1.2372990044e+03, 1.3326109855e+03, 1.4351954993e+03, &
+ 1.5456186222e+03, 1.6644886848e+03, 1.7924597105e+03, &
+ 1.9302350870e+03, 2.0785714934e+03, 2.2382831070e+03, &
+ 2.4102461133e+03, 2.5954035462e+03, 2.7947704856e+03, &
+ 3.0094396408e+03, 3.2405873512e+03, 3.4894800360e+03, &
+ 3.7574811281e+03, 4.0460585279e+03, 4.3567926151e+03, &
+ 4.6913848588e+03, 5.0516670674e+03, 5.4396113207e+03, &
+ 5.8573406270e+03, 6.3071403487e+03, 6.7914704368e+03, &
+ 7.3129785102e+03, 7.8745138115e+03, 8.4791420557e+03, &
+ 9.1301611750e+03, 9.8311179338e+03, 1.0585825354e+04, &
+ 1.1398380836e+04, 1.2273184781e+04, 1.3214959424e+04, &
+ 1.4228767429e+04, 1.5320029596e+04, 1.6494540743e+04, &
+ 1.7758482452e+04, 1.9118430825e+04, 2.0422798801e+04, &
+ 2.1520147587e+04, 2.2416813461e+04, 2.3118184510e+04, &
+ 2.3628790785e+04, 2.3952411814e+04, 2.4092209011e+04, &
+ 2.4050892106e+04, 2.3830930156e+04, 2.3434818358e+04, &
+ 2.2865410898e+04, 2.2126326004e+04, 2.1222420323e+04, &
+ 2.0160313690e+04, 1.8948920926e+04, 1.7599915822e+04, &
+ 1.6128019809e+04, 1.4550987232e+04, 1.2889169132e+04, &
+ 1.1164595563e+04, 9.4227665517e+03, 7.7259097899e+03, &
+ 6.1538244381e+03, 4.7808126007e+03, 3.5967415552e+03, &
+ 2.5886394104e+03, 1.7415964865e+03, 1.0393721271e+03, &
+ 4.6478852032e+02, 7.0308342481e-13, 0.0000000000e+00 /
data b104/ &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
- 0.0000000000e+00, 0.0000000000e+00, 1.5648447298e-03, &
- 6.2617046389e-03, 1.4104157933e-02, 2.5118187415e-02, &
- 3.9340510972e-02, 5.6816335609e-02, 7.7596328431e-02, &
- 1.0173255472e-01, 1.2927309709e-01, 1.6025505622e-01, &
- 1.9469566981e-01, 2.3258141217e-01, 2.7385520518e-01, &
- 3.1840233814e-01, 3.6603639170e-01, 4.1648734767e-01, &
- 4.6939496013e-01, 5.2431098738e-01, 5.8071350676e-01, &
- 6.3803478105e-01, 6.9495048840e-01, 7.4963750338e-01, &
- 7.9975208897e-01, 8.4315257576e-01, 8.8034012292e-01, &
- 9.1184389721e-01, 9.3821231526e-01, 9.6000677644e-01, &
- 9.7779792223e-01, 9.9216315122e-01, 1.0000000000e+00 /
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, &
+ 0.0000000000e+00, 0.0000000000e+00, 1.5648447298e-03, &
+ 6.2617046389e-03, 1.4104157933e-02, 2.5118187415e-02, &
+ 3.9340510972e-02, 5.6816335609e-02, 7.7596328431e-02, &
+ 1.0173255472e-01, 1.2927309709e-01, 1.6025505622e-01, &
+ 1.9469566981e-01, 2.3258141217e-01, 2.7385520518e-01, &
+ 3.1840233814e-01, 3.6603639170e-01, 4.1648734767e-01, &
+ 4.6939496013e-01, 5.2431098738e-01, 5.8071350676e-01, &
+ 6.3803478105e-01, 6.9495048840e-01, 7.4963750338e-01, &
+ 7.9975208897e-01, 8.4315257576e-01, 8.8034012292e-01, &
+ 9.1184389721e-01, 9.3821231526e-01, 9.6000677644e-01, &
+ 9.7779792223e-01, 9.9216315122e-01, 1.0000000000e+00 /
! IFS-like L125(top 12 levels removed from IFSL137)
data a125/ 64., &
@@ -994,5 +1167,74 @@
0.984542, 0.988500, 0.991984, 0.995003, 0.997630, 1.000000 /
+ data a127/ &
+ 0.99900, 1.60500, 2.53200, 3.92400, &
+ 5.97600, 8.94700, 13.17700, 19.09600, &
+ 27.24300, 38.27600, 52.98400, 72.29300, &
+ 97.26900, 129.11000, 169.13500, 218.76700, &
+ 279.50600, 352.89400, 440.48100, 543.78200, &
+ 664.23600, 803.16400, 961.73400, 1140.93100, &
+ 1341.53800, 1564.11900, 1809.02800, 2076.41500, &
+ 2366.25200, 2678.37200, 3012.51000, 3368.36300, &
+ 3745.64600, 4144.16400, 4563.88100, 5004.99500, &
+ 5468.01700, 5953.84800, 6463.86400, 7000.00000, &
+ 7563.49400, 8150.66100, 8756.52900, 9376.14100, &
+ 10004.55300, 10636.85100, 11268.15700, 11893.63900, &
+ 12508.51900, 13108.09100, 13687.72700, 14242.89000, &
+ 14769.15300, 15262.20200, 15717.85900, 16132.09000, &
+ 16501.01800, 16820.93800, 17088.32400, 17299.85200, &
+ 17453.08400, 17548.35000, 17586.77100, 17569.69700, &
+ 17498.69700, 17375.56100, 17202.29900, 16981.13700, &
+ 16714.50400, 16405.02000, 16055.48500, 15668.86000, &
+ 15248.24700, 14796.86800, 14318.04000, 13815.15000, &
+ 13291.62900, 12750.92400, 12196.46800, 11631.65900, &
+ 11059.82700, 10484.20800, 9907.92700, 9333.96700, &
+ 8765.15500, 8204.14200, 7653.38700, 7115.14700, &
+ 6591.46800, 6084.17600, 5594.87600, 5124.94900, &
+ 4675.55400, 4247.63300, 3841.91800, 3458.93300, &
+ 3099.01000, 2762.29700, 2448.76800, 2158.23800, &
+ 1890.37500, 1644.71200, 1420.66100, 1217.52800, &
+ 1034.52400, 870.77800, 725.34800, 597.23500, &
+ 485.39200, 388.73400, 306.14900, 236.50200, &
+ 178.65100, 131.44700, 93.74000, 64.39200, &
+ 42.27400, 26.27400, 15.30200, 8.28700, &
+ 4.19000, 1.99400, 0.81000, 0.23200, &
+ 0.02900, 0.00000, 0.00000, 0.00000 /
+
+
+ data b127/ &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000010180, 0.000081410, 0.000274690, 0.000650780, &
+ 0.001270090, 0.002192480, 0.003477130, 0.005182280, &
+ 0.007365040, 0.010081200, 0.013384920, 0.017328570, &
+ 0.021962390, 0.027334280, 0.033489540, 0.040470560, &
+ 0.048316610, 0.057063580, 0.066743720, 0.077385480, &
+ 0.089006290, 0.101593970, 0.115126180, 0.129576220, &
+ 0.144912940, 0.161100800, 0.178099890, 0.195866050, &
+ 0.214351120, 0.233503070, 0.253266330, 0.273582160, &
+ 0.294388980, 0.315622900, 0.337218050, 0.359107230, &
+ 0.381222370, 0.403495070, 0.425857160, 0.448241260, &
+ 0.470581260, 0.492812960, 0.514874340, 0.536706210, &
+ 0.558252450, 0.579460500, 0.600281540, 0.620670740, &
+ 0.640587510, 0.659995680, 0.678863350, 0.697163110, &
+ 0.714872000, 0.731971260, 0.748446460, 0.764287110, &
+ 0.779486660, 0.794042170, 0.807954130, 0.821226300, &
+ 0.833865170, 0.845880090, 0.857282640, 0.868086640, &
+ 0.878307700, 0.887963240, 0.897071780, 0.905653240, &
+ 0.913728360, 0.921318710, 0.928446350, 0.935133760, &
+ 0.941403690, 0.947278860, 0.952782090, 0.957935990, &
+ 0.962762950, 0.967285100, 0.971524000, 0.975500880, &
+ 0.979236420, 0.982750770, 0.986062530, 0.989185090, &
+ 0.992129920, 0.994907680, 0.997528200, 1.000000000 /
+
#endif _FV_ETA_
diff --git a/tools/fv_grid_tools.F90 b/tools/fv_grid_tools.F90
index 0e8d5393b..bd20be904 100644
--- a/tools/fv_grid_tools.F90
+++ b/tools/fv_grid_tools.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,9 +18,12 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_grid_tools_mod
- use constants_mod, only: grav, omega, pi=>pi_8, cnst_radius=>radius, small_fac
+ use constants_mod, only: grav, pi=>pi_8
+ use fv_arrays_mod, only: radius, omega ! scaled for small earth
+! use test_cases_mod, only: small_earth_scale
use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_grid_bounds_type, R_GRID
use fv_grid_utils_mod, only: gnomonic_grids, great_circle_dist, &
mid_pt_sphere, spherical_angle, &
@@ -29,7 +32,7 @@ module fv_grid_tools_mod
spherical_linear_interpolation, big_number
use fv_timing_mod, only: timing_on, timing_off
use fv_mp_mod, only: is_master, fill_corners, XDir, YDir
- use fv_mp_mod, only: mp_bcst, mp_reduce_max, mp_stop, grids_master_procs
+ use fv_mp_mod, only: grids_master_procs
use sorted_index_mod, only: sorted_inta, sorted_intb
use mpp_mod, only: mpp_error, FATAL, get_unit, mpp_chksum, mpp_pe, stdout, &
mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_npes, &
@@ -59,8 +62,6 @@ module fv_grid_tools_mod
private
#include
- real(kind=R_GRID), parameter:: radius = cnst_radius
-
real(kind=R_GRID) , parameter:: todeg = 180.0d0/pi ! convert to degrees
real(kind=R_GRID) , parameter:: torad = pi/180.0d0 ! convert to radians
real(kind=R_GRID) , parameter:: missing = 1.d25
@@ -604,7 +605,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions,
call setup_aligned_nest(Atm)
else
- if( trim(grid_file) == 'INPUT/grid_spec.nc' .or. Atm%flagstruct%grid_type < 0 ) then
+ if( trim(grid_file) == 'INPUT/grid_spec.nc' .or. Atm%flagstruct%grid_type < 0 ) then
call read_grid(Atm, grid_file, ndims, nregions, ng)
! Here if we are reading from grid_spec and the grid has a nest we need to assemble
@@ -626,19 +627,6 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions,
grid(isection_s:isection_e,jsection_s:jsection_e,1),grid_global(1-ng:npx+ng,1-ng:npy+ng,1,1),is_master(),ng,ng)
call mpp_gather(isection_s,isection_e,jsection_s,jsection_e,atm%pelist, &
grid(isection_s:isection_e,jsection_s:jsection_e,2),grid_global(1-ng:npx+ng,1-ng:npy+ng,2,1),is_master(),ng,ng)
- !do we need the haloes?!
- !do j=jsd,jed
- !do i=isd,ied
- !grid_global(i,j,1,1)=grid(i,j,1)
- !grid_global(i,j,2,1)=grid(i,j,2)
- !enddo
- !enddo
- !do j=1,npy
- !do i=1,npx
- !call mpp_max(grid_global(i,j,1,1),atm%pelist)
- !call mpp_max(grid_global(i,j,2,1),atm%pelist)
- !enddo
- !enddo
endif
else
@@ -939,38 +927,6 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions,
enddo
endif
- if ( sw_corner ) then
- i=1; j=1
- p1(1:2) = grid(i,j,1:2)
- call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
- p3(1:2) = agrid(i,j,1:2)
- call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p4)
- area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
- endif
- if ( se_corner ) then
- i=npx; j=1
- call mid_pt_sphere(grid(i-1,j,1:2), grid(i,j,1:2), p1)
- p2(1:2) = grid(i,j,1:2)
- call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p3)
- p4(1:2) = agrid(i,j,1:2)
- area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
- endif
- if ( ne_corner ) then
- i=npx; j=npy
- p1(1:2) = agrid(i-1,j-1,1:2)
- call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,1:2), p2)
- p3(1:2) = grid(i,j,1:2)
- call mid_pt_sphere(grid(i-1,j,1:2), grid(i,j,1:2), p4)
- area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
- endif
- if ( nw_corner ) then
- i=1; j=npy
- call mid_pt_sphere(grid(i,j-1,1:2), grid(i,j,1:2), p1)
- p2(1:2) = agrid(i,j-1,1:2)
- call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p3)
- p4(1:2) = grid(i,j,1:2)
- area_c(i,j) = 3.*get_area(p1, p4, p2, p3, radius)
- endif
endif
!-----------------
@@ -1113,7 +1069,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions,
dxAV = dxAV / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) )
aspAV = aspAV / ( (ceiling(npy/2.0))*(ceiling(npx/2.0)) )
write(*,* ) ''
- write(*,*) ' Radius is ', radius, ', omega is ', omega, ' small_fac = ', small_fac
+ write(*,*) ' Radius is ', radius, ', omega is ', omega!, ' small_earth_scale = ', small_earth_scale
write(*,* ) ' Cubed-Sphere Grid Stats : ', npx,'x',npy,'x',nregions
print*, dxN, dxM, dxAV, dxN, dxM
write(*,'(A,f11.2,A,f11.2,A,f11.2,A,f11.2)') ' Grid Length : min: ', dxN,' max: ', dxM,' avg: ', dxAV, ' min/max: ',dxN/dxM
@@ -2449,8 +2405,13 @@ subroutine grid_area(nx, ny, ndims, nregions, bounded_domain, gridstruct, domain
minarea = mpp_global_min(domain, area)
if (is_master()) write(*,209) 'MAX AREA (m*m):', maxarea, ' MIN AREA (m*m):', minarea
- if (is_master()) write(*,209) 'GLOBAL AREA (m*m):', globalarea, ' IDEAL GLOBAL AREA (m*m):', 4.0*pi*radius**2
+ if (bounded_domain) then
+ if (is_master()) write(*,210) 'REGIONAL AREA (m*m):', globalarea
+ else
+ if (is_master()) write(*,209) 'GLOBAL AREA (m*m):', globalarea, ' IDEAL GLOBAL AREA (m*m):', 4.0*pi*radius**2
+ endif
209 format(A,e21.14,A,e21.14)
+ 210 format(A,e21.14)
if (bounded_domain) then
nh = ng-1 !cannot get rarea_c on boundary directly
diff --git a/tools/fv_iau_mod.F90 b/tools/fv_iau_mod.F90
new file mode 100644
index 000000000..f8840f60e
--- /dev/null
+++ b/tools/fv_iau_mod.F90
@@ -0,0 +1,521 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!-------------------------------------------------------------------------------
+!> @brief incremental analysis update module
+!> @author Xi.Chen - author of fv_treat_da_inc.F90
+!> @author Philip Pegion
+!> @date 09/13/2017
+!
+!> REVISION HISTORY:
+!> 09/13/2017 - Initial Version based on fv_treat_da_inc.F90
+!-------------------------------------------------------------------------------
+
+#ifdef OVERLOAD_R4
+#define _GET_VAR1 get_var1_real
+#else
+#define _GET_VAR1 get_var1_double
+#endif
+
+module fv_iau_mod
+
+ use fms_mod, only: file_exist
+ use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe
+ use mpp_domains_mod, only: domain2d
+
+ use constants_mod, only: pi=>pi_8
+ use fv_arrays_mod, only: fv_atmos_type, &
+ fv_grid_type, &
+ fv_grid_bounds_type, &
+ R_GRID
+ use fv_mp_mod, only: is_master
+ use sim_nc_mod, only: open_ncfile, &
+ close_ncfile, &
+ get_ncdim1, &
+ get_var1_double, &
+ get_var3_r4, &
+ get_var1_real, check_var_exists
+#ifdef GFS_PHYS
+ use IPD_typedefs, only: IPD_init_type, IPD_control_type, &
+ kind_phys
+#endif
+ use block_control_mod, only: block_control_type
+ use fv_treat_da_inc_mod, only: remap_coef
+ use tracer_manager_mod, only: get_tracer_names,get_tracer_index, get_number_tracers
+ use field_manager_mod, only: MODEL_ATMOS
+ implicit none
+
+ private
+
+#ifndef GFS_PHYS
+ integer, parameter :: kind_phys = 8
+#endif
+
+ real,allocatable::s2c(:,:,:)
+! real:: s2c(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je,4)
+! integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je):: &
+! id1, id2, jdc
+ integer,allocatable,dimension(:,:) :: id1,id2,jdc
+
+ real :: deg2rad,dt,rdt
+ integer :: im,jm,km,nfiles,ncid
+ integer :: is, ie, js, je
+ integer :: npz,ntracers
+ character(len=32), allocatable :: tracer_names(:)
+ integer, allocatable :: tracer_indicies(:)
+
+ real(kind=4), allocatable:: wk3(:,:,:)
+ type iau_internal_data_type
+ real,allocatable :: ua_inc(:,:,:)
+ real,allocatable :: va_inc(:,:,:)
+ real,allocatable :: temp_inc(:,:,:)
+ real,allocatable :: delp_inc(:,:,:)
+ real,allocatable :: delz_inc(:,:,:)
+ real,allocatable :: tracer_inc(:,:,:,:)
+ end type iau_internal_data_type
+ type iau_external_data_type
+ real,allocatable :: ua_inc(:,:,:)
+ real,allocatable :: va_inc(:,:,:)
+ real,allocatable :: temp_inc(:,:,:)
+ real,allocatable :: delp_inc(:,:,:)
+ real,allocatable :: delz_inc(:,:,:)
+ real,allocatable :: tracer_inc(:,:,:,:)
+ logical :: in_interval = .false.
+ logical :: drymassfixer = .false.
+ end type iau_external_data_type
+ type iau_state_type
+ type(iau_internal_data_type):: inc1
+ type(iau_internal_data_type):: inc2
+ real(kind=kind_phys) :: hr1
+ real(kind=kind_phys) :: hr2
+ real(kind=kind_phys) :: wt
+ real(kind=kind_phys) :: wt_normfact
+ end type iau_state_type
+ type(iau_state_type) :: IAU_state
+
+ public iau_external_data_type
+
+#ifdef GFS_PHYS
+ public IAU_initialize, getiauforcing
+
+contains
+subroutine IAU_initialize (IPD_Control, IAU_Data,Init_parm)
+ type (IPD_control_type), intent(in) :: IPD_Control
+ type (IAU_external_data_type), intent(inout) :: IAU_Data
+ type (IPD_init_type), intent(in) :: Init_parm
+ ! local
+
+ character(len=128) :: fname
+ real, dimension(:,:,:), allocatable:: u_inc, v_inc
+ real, allocatable:: lat(:), lon(:),agrid(:,:,:)
+ real(kind=kind_phys) sx,wx,wt,normfact,dtp
+
+ integer:: i, j, k, nstep, kstep
+ integer:: i1, i2, j1
+ integer:: jbeg, jend
+
+ logical:: found
+ integer nfilesall
+ integer, allocatable :: idt(:)
+
+ is = IPD_Control%isc
+ ie = is + IPD_Control%nx-1
+ js = IPD_Control%jsc
+ je = js + IPD_Control%ny-1
+ call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers)
+ allocate (tracer_names(ntracers))
+ allocate (tracer_indicies(ntracers))
+ do i = 1, ntracers
+ call get_tracer_names(MODEL_ATMOS, i, tracer_names(i))
+ tracer_indicies(i) = get_tracer_index(MODEL_ATMOS,tracer_names(i))
+ enddo
+ allocate(s2c(is:ie,js:je,4))
+ allocate(id1(is:ie,js:je))
+ allocate(id2(is:ie,js:je))
+ allocate(jdc(is:ie,js:je))
+ allocate(agrid(is:ie,js:je,2))
+! determine number of increment files to read, and the valid forecast hours
+
+ nfilesall = size(IPD_Control%iau_inc_files)
+ nfiles = 0
+ if (is_master()) print*,'in iau_init',trim(IPD_Control%iau_inc_files(1)),IPD_Control%iaufhrs(1)
+ do k=1,nfilesall
+ if (trim(IPD_Control%iau_inc_files(k)) .eq. '' .or. IPD_Control%iaufhrs(k) .lt. 0) exit
+ if (is_master()) then
+ print *,k,trim(adjustl(IPD_Control%iau_inc_files(k)))
+ endif
+ nfiles = nfiles + 1
+ enddo
+ if (is_master()) print *,'nfiles = ',nfiles
+ if (nfiles < 1) then
+ return
+ endif
+ if (nfiles > 1) then
+ allocate(idt(nfiles-1))
+ idt = IPD_Control%iaufhrs(2:nfiles)-IPD_Control%iaufhrs(1:nfiles-1)
+ do k=1,nfiles-1
+ if (idt(k) .ne. IPD_Control%iaufhrs(2)-IPD_Control%iaufhrs(1)) then
+ print *,'forecast intervals in iaufhrs must be constant'
+ call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant')
+ endif
+ enddo
+ deallocate(idt)
+ endif
+ if (is_master()) print *,'iau interval = ',IPD_Control%iau_delthrs,' hours'
+ dt = (IPD_Control%iau_delthrs*3600.)
+ rdt = 1.0/dt
+
+! set up interpolation weights to go from GSI's gaussian grid to cubed sphere
+ deg2rad = pi/180.
+
+ npz = IPD_Control%levs
+ fname = 'INPUT/'//trim(IPD_Control%iau_inc_files(1))
+
+ if( file_exist(fname) ) then
+ call open_ncfile( fname, ncid ) ! open the file
+ call get_ncdim1( ncid, 'lon', im)
+ call get_ncdim1( ncid, 'lat', jm)
+ call get_ncdim1( ncid, 'lev', km)
+
+ if (km.ne.npz) then
+ if (is_master()) print *, 'km = ', km
+ call mpp_error(FATAL, &
+ '==> Error in IAU_initialize: km is not equal to npz')
+ endif
+
+ if(is_master()) write(*,*) fname, ' DA increment dimensions:', im,jm,km
+
+ allocate ( lon(im) )
+ allocate ( lat(jm) )
+
+ call _GET_VAR1 (ncid, 'lon', im, lon )
+ call _GET_VAR1 (ncid, 'lat', jm, lat )
+ call close_ncfile(ncid)
+
+ ! Convert to radians
+ do i=1,im
+ lon(i) = lon(i) * deg2rad
+ enddo
+ do j=1,jm
+ lat(j) = lat(j) * deg2rad
+ enddo
+
+ else
+ call mpp_error(FATAL,'==> Error in IAU_initialize: Expected file '&
+ //trim(fname)//' for DA increment does not exist')
+ endif
+
+ ! Initialize lat-lon to Cubed bi-linear interpolation coeff:
+ ! populate agrid
+! print*,'is,ie,js,je=',is,ie,js,ie
+! print*,'size xlon=',size(Init_parm%xlon(:,1)),size(Init_parm%xlon(1,:))
+! print*,'size agrid=',size(agrid(:,1,1)),size(agrid(1,:,1)),size(agrid(1,1,:))
+ do j = 1,size(Init_parm%xlon,2)
+ do i = 1,size(Init_parm%xlon,1)
+! print*,i,j,is-1+j,js-1+j
+ agrid(is-1+i,js-1+j,1)=Init_parm%xlon(i,j)
+ agrid(is-1+i,js-1+j,2)=Init_parm%xlat(i,j)
+ enddo
+ enddo
+ call remap_coef( is, ie, js, je, is, ie, js, je, &
+ im, jm, lon, lat, id1, id2, jdc, s2c, &
+ agrid)
+ deallocate ( lon, lat,agrid )
+
+ allocate(IAU_Data%ua_inc(is:ie, js:je, km))
+ allocate(IAU_Data%va_inc(is:ie, js:je, km))
+ allocate(IAU_Data%temp_inc(is:ie, js:je, km))
+ allocate(IAU_Data%delp_inc(is:ie, js:je, km))
+ allocate(IAU_Data%delz_inc(is:ie, js:je, km))
+ allocate(IAU_Data%tracer_inc(is:ie, js:je, km,ntracers))
+! allocate arrays that will hold iau state
+ allocate (iau_state%inc1%ua_inc(is:ie, js:je, km))
+ allocate (iau_state%inc1%va_inc(is:ie, js:je, km))
+ allocate (iau_state%inc1%temp_inc (is:ie, js:je, km))
+ allocate (iau_state%inc1%delp_inc (is:ie, js:je, km))
+ allocate (iau_state%inc1%delz_inc (is:ie, js:je, km))
+ allocate (iau_state%inc1%tracer_inc(is:ie, js:je, km,ntracers))
+
+ iau_state%hr1=IPD_Control%iaufhrs(1)
+ iau_state%wt = 1.0 ! IAU increment filter weights (default 1.0)
+ if (IPD_Control%iau_filter_increments) then
+ ! compute increment filter weights, sum to obtain normalization factor
+ dtp=IPD_control%dtp
+ nstep = 0.5*IPD_Control%iau_delthrs*3600/dtp
+ ! compute normalization factor for filter weights
+ normfact = 0.
+ do k=1,2*nstep+1
+ kstep = k-1-nstep
+ sx = acos(-1.)*kstep/nstep
+ wx = acos(-1.)*kstep/(nstep+1)
+ if (kstep .ne. 0) then
+ wt = sin(wx)/wx*sin(sx)/sx
+ else
+ wt = 1.0
+ endif
+ normfact = normfact + wt
+ if (is_master()) print *,'filter wts',k,kstep,wt
+ enddo
+ iau_state%wt_normfact = (2*nstep+1)/normfact
+ endif
+ call read_iau_forcing(IPD_Control,iau_state%inc1,'INPUT/'//trim(IPD_Control%iau_inc_files(1)))
+ if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window
+ call setiauforcing(IPD_Control,IAU_Data,iau_state%wt)
+ endif
+
+ if (nfiles.GT.1) then !have multiple files, but only read in 2 at a time and interpoalte between them
+ allocate (iau_state%inc2%ua_inc(is:ie, js:je, km))
+ allocate (iau_state%inc2%va_inc(is:ie, js:je, km))
+ allocate (iau_state%inc2%temp_inc (is:ie, js:je, km))
+ allocate (iau_state%inc2%delp_inc (is:ie, js:je, km))
+ allocate (iau_state%inc2%delz_inc (is:ie, js:je, km))
+ allocate (iau_state%inc2%tracer_inc(is:ie, js:je, km,ntracers))
+ iau_state%hr2=IPD_Control%iaufhrs(2)
+ call read_iau_forcing(IPD_Control,iau_state%inc2,'INPUT/'//trim(IPD_Control%iau_inc_files(2)))
+ endif
+! print*,'in IAU init',dt,rdt
+ IAU_data%drymassfixer = IPD_control%iau_drymassfixer
+
+end subroutine IAU_initialize
+
+subroutine getiauforcing(IPD_Control,IAU_Data)
+
+ implicit none
+ type (IPD_control_type), intent(in) :: IPD_Control
+ type(IAU_external_data_type), intent(inout) :: IAU_Data
+ real(kind=kind_phys) t1,t2,sx,wx,wt,dtp
+ integer n,i,j,k,sphum,kstep,nstep
+
+ IAU_Data%in_interval=.false.
+ if (nfiles.LE.0) then
+ return
+ endif
+
+ t1=iau_state%hr1 - IPD_Control%iau_delthrs*0.5
+ t2=iau_state%hr1 + IPD_Control%iau_delthrs*0.5
+ if (IPD_Control%iau_filter_increments) then
+ ! compute increment filter weight
+ ! t1 beginning of window, t2 end of window
+ ! IPD_Control%fhour current time
+ ! in window kstep=-nstep,nstep (2*nstep+1 total)
+ ! time step IPD_control%dtp
+ dtp=IPD_control%dtp
+ nstep = 0.5*IPD_Control%iau_delthrs*3600/dtp
+ ! compute normalized filter weight
+ kstep = (IPD_Control%fhour-(t1+IPD_Control%iau_delthrs*0.5))*3600./dtp
+ if (kstep .ge. -nstep .and. kstep .le. nstep) then
+ sx = acos(-1.)*kstep/nstep
+ wx = acos(-1.)*kstep/(nstep+1)
+ if (kstep .ne. 0) then
+ wt = (sin(wx)/wx*sin(sx)/sx)
+ else
+ wt = 1.
+ endif
+ iau_state%wt = iau_state%wt_normfact*wt
+ if (is_master()) print *,'filter wt',kstep,IPD_Control%fhour,iau_state%wt
+ else
+ iau_state%wt = 0.
+ endif
+ endif
+
+ if (nfiles.EQ.1) then
+! on check to see if we are in the IAU window, no need to update the
+! tendencies since they are fixed over the window
+ if ( IPD_Control%fhour < t1 .or. IPD_Control%fhour >= t2 ) then
+! if (is_master()) print *,'no iau forcing',t1,IPD_Control%fhour,t2
+ IAU_Data%in_interval=.false.
+ else
+ if (IPD_Control%iau_filter_increments) call setiauforcing(IPD_Control,IAU_Data,iau_state%wt)
+ if (is_master()) print *,'apply iau forcing',t1,IPD_Control%fhour,t2
+ IAU_Data%in_interval=.true.
+ endif
+ return
+ endif
+
+ if (nfiles > 1) then
+ t2=2
+ if (IPD_Control%fhour < IPD_Control%iaufhrs(1) .or. IPD_Control%fhour >= IPD_Control%iaufhrs(nfiles)) then
+! if (is_master()) print *,'no iau forcing',IPD_Control%iaufhrs(1),IPD_Control%fhour,IPD_Control%iaufhrs(nfiles)
+ IAU_Data%in_interval=.false.
+ else
+ IAU_Data%in_interval=.true.
+ do k=nfiles,1,-1
+ if (IPD_Control%iaufhrs(k) > IPD_Control%fhour) then
+ t2=k
+ endif
+ enddo
+! if (is_master()) print *,'t2=',t2
+ if (IPD_Control%fhour >= iau_state%hr2) then ! need to read in next increment file
+ iau_state%hr1=iau_state%hr2
+ iau_state%hr2=IPD_Control%iaufhrs(t2)
+ iau_state%inc1=iau_state%inc2
+ if (is_master()) print *,'reading next increment file',trim(IPD_Control%iau_inc_files(t2))
+ call read_iau_forcing(IPD_Control,iau_state%inc2,'INPUT/'//trim(IPD_Control%iau_inc_files(t2)))
+ endif
+ call updateiauforcing(IPD_Control,IAU_Data,iau_state%wt)
+ endif
+ endif
+ sphum=get_tracer_index(MODEL_ATMOS,'sphum')
+ end subroutine getiauforcing
+
+subroutine updateiauforcing(IPD_Control,IAU_Data,wt)
+
+ implicit none
+ type (IPD_control_type), intent(in) :: IPD_Control
+ type(IAU_external_data_type), intent(inout) :: IAU_Data
+ real(kind_phys) delt,wt
+ integer i,j,k,l
+
+! if (is_master()) print *,'in updateiauforcing',nfiles,IPD_Control%iaufhrs(1:nfiles)
+ delt = (iau_state%hr2-(IPD_Control%fhour))/(IAU_state%hr2-IAU_state%hr1)
+ do j = js,je
+ do i = is,ie
+ do k = 1,npz
+ IAU_Data%ua_inc(i,j,k) =(delt*IAU_state%inc1%ua_inc(i,j,k) + (1.-delt)* IAU_state%inc2%ua_inc(i,j,k))*rdt*wt
+ IAU_Data%va_inc(i,j,k) =(delt*IAU_state%inc1%va_inc(i,j,k) + (1.-delt)* IAU_state%inc2%va_inc(i,j,k))*rdt*wt
+ IAU_Data%temp_inc(i,j,k) =(delt*IAU_state%inc1%temp_inc(i,j,k) + (1.-delt)* IAU_state%inc2%temp_inc(i,j,k))*rdt*wt
+ IAU_Data%delp_inc(i,j,k) =(delt*IAU_state%inc1%delp_inc(i,j,k) + (1.-delt)* IAU_state%inc2%delp_inc(i,j,k))*rdt*wt
+ IAU_Data%delz_inc(i,j,k) =(delt*IAU_state%inc1%delz_inc(i,j,k) + (1.-delt)* IAU_state%inc2%delz_inc(i,j,k))*rdt*wt
+ do l=1,ntracers
+ IAU_Data%tracer_inc(i,j,k,l) =(delt*IAU_state%inc1%tracer_inc(i,j,k,l) + (1.-delt)* IAU_state%inc2%tracer_inc(i,j,k,l))*rdt*wt
+ enddo
+ enddo
+ enddo
+ enddo
+ end subroutine updateiauforcing
+
+
+ subroutine setiauforcing(IPD_Control,IAU_Data,wt)
+
+ implicit none
+ type (IPD_control_type), intent(in) :: IPD_Control
+ type(IAU_external_data_type), intent(inout) :: IAU_Data
+ real(kind_phys) delt, dt,wt
+ integer i,j,k,l,sphum
+! this is only called if using 1 increment file
+ if (is_master()) print *,'in setiauforcing',rdt
+ do j = js,je
+ do i = is,ie
+ do k = 1,npz
+ IAU_Data%ua_inc(i,j,k) =wt*IAU_state%inc1%ua_inc(i,j,k)*rdt
+ IAU_Data%va_inc(i,j,k) =wt*IAU_state%inc1%va_inc(i,j,k)*rdt
+ IAU_Data%temp_inc(i,j,k) =wt*IAU_state%inc1%temp_inc(i,j,k)*rdt
+ IAU_Data%delp_inc(i,j,k) =wt*IAU_state%inc1%delp_inc(i,j,k)*rdt
+ IAU_Data%delz_inc(i,j,k) =wt*IAU_state%inc1%delz_inc(i,j,k)*rdt
+ do l = 1,ntracers
+ IAU_Data%tracer_inc(i,j,k,l) =wt*IAU_state%inc1%tracer_inc(i,j,k,l)*rdt
+ enddo
+ enddo
+ enddo
+ enddo
+ sphum=get_tracer_index(MODEL_ATMOS,'sphum')
+ end subroutine setiauforcing
+
+subroutine read_iau_forcing(IPD_Control,increments,fname)
+ type (IPD_control_type), intent(in) :: IPD_Control
+ type(iau_internal_data_type), intent(inout):: increments
+ character(len=*), intent(in) :: fname
+!locals
+ real, dimension(:,:,:), allocatable:: u_inc, v_inc
+
+ integer:: i, j, k, l, npz
+ integer:: i1, i2, j1
+ integer:: jbeg, jend
+ real(kind=R_GRID), dimension(2):: p1, p2, p3
+ real(kind=R_GRID), dimension(3):: e1, e2, ex, ey
+
+ logical:: found
+ integer :: is, ie, js, je
+
+ is = IPD_Control%isc
+ ie = is + IPD_Control%nx-1
+ js = IPD_Control%jsc
+ je = js + IPD_Control%ny-1
+
+ deg2rad = pi/180.
+
+ npz = IPD_Control%levs
+
+ if( file_exist(fname) ) then
+ call open_ncfile( fname, ncid ) ! open the file
+ else
+ call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '&
+ //trim(fname)//' for DA increment does not exist')
+ endif
+
+ ! Find bounding latitudes:
+ jbeg = jm-1; jend = 2
+ do j=js,je
+ do i=is,ie
+ j1 = jdc(i,j)
+ jbeg = min(jbeg, j1)
+ jend = max(jend, j1+1)
+ enddo
+ enddo
+
+ allocate ( wk3(1:im,jbeg:jend, 1:km) )
+ ! read in 1 time level
+ call interp_inc('T_inc',increments%temp_inc(:,:,:),jbeg,jend)
+ call interp_inc('delp_inc',increments%delp_inc(:,:,:),jbeg,jend)
+ call interp_inc('delz_inc',increments%delz_inc(:,:,:),jbeg,jend)
+ call interp_inc('u_inc',increments%ua_inc(:,:,:),jbeg,jend) ! can these be treated as scalars?
+ call interp_inc('v_inc',increments%va_inc(:,:,:),jbeg,jend)
+ do l=1,ntracers
+ call interp_inc(trim(tracer_names(l))//'_inc',increments%tracer_inc(:,:,:,l),jbeg,jend)
+ enddo
+ call close_ncfile(ncid)
+ deallocate (wk3)
+
+
+end subroutine read_iau_forcing
+
+subroutine interp_inc(field_name,var,jbeg,jend)
+! interpolate increment from GSI gaussian grid to cubed sphere
+! everying is on the A-grid, earth relative
+ character(len=*), intent(in) :: field_name
+ real, dimension(is:ie,js:je,1:km), intent(inout) :: var
+ integer, intent(in) :: jbeg,jend
+ integer:: i1, i2, j1, k,j,i,ierr
+ call check_var_exists(ncid, field_name, ierr)
+ if (ierr == 0) then
+ call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 )
+ else
+ if (is_master()) print *,'warning: no increment for ',trim(field_name),' found, assuming zero'
+ wk3 = 0.
+ endif
+ do k=1,km
+ do j=js,je
+ do i=is,ie
+ i1 = id1(i,j)
+ i2 = id2(i,j)
+ j1 = jdc(i,j)
+ var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+&
+ s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
+ enddo
+ enddo
+ enddo
+end subroutine interp_inc
+
+#endif
+
+end module fv_iau_mod
+
+
diff --git a/tools/fv_io.F90 b/tools/fv_io.F90
index 499a0b8ea..dd03ae3d5 100644
--- a/tools/fv_io.F90
+++ b/tools/fv_io.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
!!!NOTE: Merging in the seasonal forecast initialization code
!!!! has proven problematic in the past, since many conflicts
!!!! occur. Leaving this for now --- lmh 10aug15
@@ -125,7 +126,9 @@ subroutine fv_io_register_axis(file_obj, numx, xpos, numy, ypos, numz, zsize)
call register_axis(file_obj, axisname, 'X', domain_position=xpos(i))
if (.not. file_obj%is_readonly) then !if writing file
call register_field(file_obj, axisname, "double", (/axisname/))
- call register_variable_attribute(file_obj,axisname, "axis", "X", str_len=1)
+ call register_variable_attribute(file_obj,axisname, "long_name", axisname, str_len=len(axisname))
+ call register_variable_attribute(file_obj,axisname, "units", "none", str_len=len("none"))
+ call register_variable_attribute(file_obj,axisname, "cartesian_axis", "X", str_len=1)
call get_global_io_domain_indices(file_obj, axisname, is, ie, buffer)
call write_data(file_obj, axisname, buffer)
endif
@@ -139,7 +142,9 @@ subroutine fv_io_register_axis(file_obj, numx, xpos, numy, ypos, numz, zsize)
call register_axis(file_obj, axisname, 'Y', domain_position=ypos(i))
if (.not. file_obj%is_readonly) then !if writing file
call register_field(file_obj, axisname, "double", (/axisname/))
- call register_variable_attribute(file_obj,axisname, "axis", "Y", str_len=1)
+ call register_variable_attribute(file_obj,axisname, "long_name", axisname, str_len=len(axisname))
+ call register_variable_attribute(file_obj,axisname, "units", "none", str_len=len("none"))
+ call register_variable_attribute(file_obj,axisname, "cartesian_axis", "Y", str_len=1)
call get_global_io_domain_indices(file_obj, axisname, is, ie, buffer)
call write_data(file_obj, axisname, buffer)
endif
@@ -153,7 +158,9 @@ subroutine fv_io_register_axis(file_obj, numx, xpos, numy, ypos, numz, zsize)
call register_axis(file_obj, axisname, zsize(i))
if (.not. file_obj%is_readonly) then !if writing file
call register_field(file_obj, axisname, "double", (/axisname/))
- call register_variable_attribute(file_obj,axisname, "axis", "Z", str_len=1)
+ call register_variable_attribute(file_obj,axisname, "long_name", axisname, str_len=len(axisname))
+ call register_variable_attribute(file_obj,axisname, "units", "none", str_len=len("none"))
+ call register_variable_attribute(file_obj,axisname, "cartesian_axis", "Z", str_len=1)
if (allocated(buffer)) deallocate(buffer)
allocate(buffer(zsize(i)))
do j = 1, zsize(i)
@@ -168,11 +175,11 @@ subroutine fv_io_register_axis(file_obj, numx, xpos, numy, ypos, numz, zsize)
call register_axis(file_obj, "Time", unlimited)
if (.not. file_obj%is_readonly) then !if writing file
call register_field(file_obj, "Time", "double", (/"Time"/))
- call register_variable_attribute(file_obj, "Time", "cartesian_axis", "T", str_len=1)
- call register_variable_attribute(file_obj, "Time", "units", "time level", &
- str_len=len("time level"))
call register_variable_attribute(file_obj, "Time", "long_name", "Time", &
str_len=len("Time"))
+ call register_variable_attribute(file_obj, "Time", "units", "time level", &
+ str_len=len("time level"))
+ call register_variable_attribute(file_obj, "Time", "cartesian_axis", "T", str_len=1)
call write_data(file_obj, "Time", 1)
endif
@@ -234,23 +241,31 @@ subroutine fv_io_register_restart(Atm)
call register_axis(Atm%Fv_restart, "xaxis_1", size(Atm%ak(:), 1))
call register_axis(Atm%Fv_restart, "Time", unlimited)
if (.not. Atm%Fv_restart%is_readonly) then !if writing file
- call register_field(Atm%Fv_restart, "xaxis_1", "double", (/"xaxis_1"/))
- call register_variable_attribute(Atm%Fv_restart,"xaxis_1", "axis", "X", str_len=1)
+ call register_field(Atm%Fv_restart, dim_names_2d(1), "double", (/dim_names_2d(1)/))
+ call register_variable_attribute(Atm%Fv_restart, dim_names_2d(1), "long_name", dim_names_2d(1), str_len=len(dim_names_2d(1)))
+ call register_variable_attribute(Atm%Fv_restart, dim_names_2d(1), "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Fv_restart, dim_names_2d(1), "cartesian_axis", "X", str_len=1)
if (allocated(buffer)) deallocate(buffer)
allocate(buffer(size(Atm%ak(:), 1)))
do j = 1, size(Atm%ak(:), 1)
buffer(j) = j
end do
- call write_data(Atm%Fv_restart, "xaxis_1", buffer)
+ call write_data(Atm%Fv_restart, dim_names_2d(1), buffer)
deallocate(buffer)
- call register_field(Atm%Fv_restart, "Time", "double", (/"Time"/))
- call register_variable_attribute(Atm%Fv_restart, dim_names_2d(2), "cartesian_axis", "T", str_len=1)
- call register_variable_attribute(Atm%Fv_restart, dim_names_2d(2), "units", "time level", str_len=len("time level"))
+ call register_field(Atm%Fv_restart, dim_names_2d(2), "double", (/dim_names_2d(2)/))
call register_variable_attribute(Atm%Fv_restart, dim_names_2d(2), "long_name", dim_names_2d(2), str_len=len(dim_names_2d(2)))
- call write_data(Atm%Fv_restart, "Time", 1)
+ call register_variable_attribute(Atm%Fv_restart, dim_names_2d(2), "units", "time level", str_len=len("time level"))
+ call register_variable_attribute(Atm%Fv_restart, dim_names_2d(2), "cartesian_axis", "T", str_len=1)
+ call write_data(Atm%Fv_restart, dim_names_2d(2), 1)
endif
call register_restart_field (Atm%Fv_restart, 'ak', Atm%ak(:), dim_names_2d)
call register_restart_field (Atm%Fv_restart, 'bk', Atm%bk(:), dim_names_2d)
+ if (.not. Atm%Fv_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Fv_restart, 'ak', "long_name", "ak", str_len=len("ak"))
+ call register_variable_attribute(Atm%Fv_restart, 'ak', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Fv_restart, 'bk', "long_name", "bk", str_len=len("bk"))
+ call register_variable_attribute(Atm%Fv_restart, 'bk', "units", "none", str_len=len("none"))
+ endif
! fname= 'fv_core.res'//trim(stile_name)//'.nc'
elseif (Atm%Fv_restart_tile_is_open) then
@@ -279,11 +294,42 @@ subroutine fv_io_register_restart(Atm)
call register_restart_field(Atm%Fv_restart_tile, 'phis', Atm%phis, dim_names_3d)
!--- include agrid winds in restarts for use in data assimilation
- if (Atm%flagstruct%agrid_vel_rst) then
+ if (Atm%flagstruct%agrid_vel_rst) then
call register_restart_field(Atm%Fv_restart_tile, 'ua', Atm%ua, dim_names_4d3)
call register_restart_field(Atm%Fv_restart_tile, 'va', Atm%va, dim_names_4d3)
endif
+ if (.not. Atm%Fv_restart_tile%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Fv_restart_tile, 'u', "long_name", "u", str_len=len("u"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'u', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'v', "long_name", "v", str_len=len("v"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'v', "units", "none", str_len=len("none"))
+ if (variable_exists(Atm%Fv_restart_tile, 'W')) then
+ call register_variable_attribute(Atm%Fv_restart_tile, 'W', "long_name", "W", str_len=len("W"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'W', "units", "none", str_len=len("none"))
+ endif
+ if (variable_exists(Atm%Fv_restart_tile, 'DZ')) then
+ call register_variable_attribute(Atm%Fv_restart_tile, 'DZ', "long_name", "DZ", str_len=len("DZ"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'DZ', "units", "none", str_len=len("none"))
+ endif
+ if ( Atm%flagstruct%hybrid_z .and. variable_exists(Atm%Fv_restart_tile, 'ZEO')) then
+ call register_variable_attribute(Atm%Fv_restart_tile, 'ZE0', "long_name", "ZE0", str_len=len("ZEO"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'ZEO', "units", "none", str_len=len("none"))
+ endif
+ call register_variable_attribute(Atm%Fv_restart_tile, 'T', "long_name", "T", str_len=len("T"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'T', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'delp', "long_name", "delp", str_len=len("delp"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'delp', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'phis', "long_name", "phis", str_len=len("phis"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'phis', "units", "none", str_len=len("none"))
+ if (Atm%flagstruct%agrid_vel_rst) then
+ call register_variable_attribute(Atm%Fv_restart_tile, 'ua', "long_name", "ua", str_len=len("ua"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'ua', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'va', "long_name", "va", str_len=len("va"))
+ call register_variable_attribute(Atm%Fv_restart_tile, 'va', "units", "none", str_len=len("none"))
+ endif
+ endif
+
! fname = 'fv_srf_wnd.res'//trim(stile_name)//'.nc
elseif (Atm%Rsf_restart_is_open) then
call fv_io_register_axis(Atm%Rsf_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos)
@@ -292,16 +338,35 @@ subroutine fv_io_register_restart(Atm)
#ifdef SIM_PHYS
call register_restart_field(Atm%Rsf_restart, 'ts', Atm%ts, dim_names_3d2)
#endif
+ if (.not. Atm%Rsf_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Rsf_restart, 'u_srf', "long_name", "u_srf", str_len=len("u_srf"))
+ call register_variable_attribute(Atm%Rsf_restart, 'u_srf', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Rsf_restart, 'v_srf', "long_name", "v_srf", str_len=len("v_srf"))
+ call register_variable_attribute(Atm%Rsf_restart, 'v_srf', "units", "none", str_len=len("none"))
+#ifdef SIM_PHYS
+ call register_variable_attribute(Atm%Rsf_restart, 'ts', "long_name", "ts", str_len=len("ts"))
+ call register_variable_attribute(Atm%Rsf_restart, 'ts', "units", "none", str_len=len("none"))
+#endif
+ endif
+
! fname = 'mg_drag.res'//trim(stile_name)//'.nc'
elseif (Atm%Mg_restart_is_open) then
call fv_io_register_axis(Atm%Mg_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos)
call register_restart_field (Atm%Mg_restart, 'ghprime', Atm%sgh, dim_names_3d2)
+ if (.not. Atm%Mg_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Mg_restart, 'ghprime', "long_name", "ghprime", str_len=len("ghprime"))
+ call register_variable_attribute(Atm%Mg_restart, 'ghprime', "units", "none", str_len=len("none"))
+ endif
! fname = 'fv_land.res'//trim(stile_name)//'.nc'
elseif (Atm%Lnd_restart_is_open) then
call fv_io_register_axis(Atm%Lnd_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos)
call register_restart_field (Atm%Lnd_restart, 'oro', Atm%oro, dim_names_3d2)
+ if (.not. Atm%Lnd_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Lnd_restart, 'oro', "long_name", "oro", str_len=len("oro"))
+ call register_variable_attribute(Atm%Lnd_restart, 'oro', "units", "none", str_len=len("none"))
+ endif
! fname = 'fv_tracer.res'//trim(stile_name)//'.nc'
elseif (Atm%Tra_restart_is_open) then
@@ -309,21 +374,21 @@ subroutine fv_io_register_restart(Atm)
call fv_io_register_axis(Atm%Tra_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos, numz=numz, zsize=zsize)
do nt = 1, ntprog
call get_tracer_names(MODEL_ATMOS, nt, tracer_name)
- if(Atm%Tra_restart%is_readonly) then !if reading file (don't do this if writing)
- ! set all tracers to an initial profile value
- call set_tracer_profile (MODEL_ATMOS, nt, Atm%q(:,:,:,nt) )
- endif
call register_restart_field(Atm%Tra_restart, tracer_name, Atm%q(:,:,:,nt), &
dim_names_4d, is_optional=.true.)
+ if (variable_exists(Atm%Tra_restart, tracer_name) .and. .not. Atm%Tra_restart%is_readonly) then
+ call register_variable_attribute(Atm%Tra_restart, tracer_name, "long_name", tracer_name, str_len=len(tracer_name))
+ call register_variable_attribute(Atm%Tra_restart, tracer_name, "units", "none", str_len=len("none"))
+ endif
enddo
do nt = ntprog+1, ntracers
call get_tracer_names(MODEL_ATMOS, nt, tracer_name)
- if(Atm%Tra_restart%is_readonly) then !if reading file (don't do this if writing)
- ! set all tracers to an initial profile value
- call set_tracer_profile (MODEL_ATMOS, nt, Atm%qdiag(:,:,:,nt) )
- endif
call register_restart_field(Atm%Tra_restart, tracer_name, Atm%qdiag(:,:,:,nt), &
dim_names_4d, is_optional=.true.)
+ if (variable_exists(Atm%Tra_restart, tracer_name) .and. .not. Atm%Tra_restart%is_readonly) then
+ call register_variable_attribute(Atm%Tra_restart, tracer_name, "long_name", tracer_name, str_len=len(tracer_name))
+ call register_variable_attribute(Atm%Tra_restart, tracer_name, "units", "none", str_len=len("none"))
+ endif
enddo
endif
end subroutine fv_io_register_restart
@@ -336,9 +401,11 @@ end subroutine fv_io_register_restart
!
! Write the fv core restart quantities
!
- subroutine fv_io_read_restart(fv_domain,Atm)
+ subroutine fv_io_read_restart(fv_domain,Atm,prefix,directory)
type(domain2d), intent(inout) :: fv_domain
type(fv_atmos_type), intent(inout) :: Atm(:)
+ character(len=*), optional, intent(in) :: prefix
+ character(len=*), optional, intent(in) :: directory
character(len=64) :: tracer_name
integer :: isc, iec, jsc, jec, n, nt, nk, ntracers
@@ -346,17 +413,21 @@ subroutine fv_io_read_restart(fv_domain,Atm)
integer :: ks, ntiles
real :: ptop
+ character (len=:), allocatable :: dir, pre, suffix, fname
character(len=128) :: tracer_longname, tracer_units
- character(len=120) :: fname
- character(len=20) :: suffix
character(len=1) :: tile_num
integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist
+ pre = ''
+ if (present(prefix)) pre = ''//trim(prefix)//'.'
+ dir = 'INPUT'
+ if (present(directory)) dir = trim(directory)
+
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
suffix = ''
- fname = 'INPUT/fv_core.res.nc'
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_core.res.nc'
Atm(1)%Fv_restart_is_open = open_file(Atm(1)%Fv_restart,fname,"read", is_restart=.true., pelist=pes)
if (Atm(1)%Fv_restart_is_open) then
call fv_io_register_restart(Atm(1))
@@ -381,7 +452,7 @@ subroutine fv_io_read_restart(fv_domain,Atm)
suffix = ''//trim(suffix)//'.tile1'
endif
- fname = 'INPUT/fv_core.res'//trim(suffix)//'.nc'
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_core.res'//trim(suffix)//'.nc'
Atm(1)%Fv_restart_tile_is_open = open_file(Atm(1)%Fv_restart_tile, fname, "read", fv_domain, is_restart=.true.)
if (Atm(1)%Fv_restart_tile_is_open) then
call fv_io_register_restart(Atm(1))
@@ -391,7 +462,7 @@ subroutine fv_io_read_restart(fv_domain,Atm)
endif
!--- restore data for fv_tracer - if it exists
- fname = 'INPUT/fv_tracer.res'//trim(suffix)//'.nc'
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_tracer.res'//trim(suffix)//'.nc'
Atm(1)%Tra_restart_is_open = open_file(Atm(1)%Tra_restart, fname, "read", fv_domain, is_restart=.true.)
if (Atm(1)%Tra_restart_is_open) then
call fv_io_register_restart(Atm(1))
@@ -403,7 +474,7 @@ subroutine fv_io_read_restart(fv_domain,Atm)
endif
!--- restore data for surface winds - if it exists
- fname = 'INPUT/fv_srf_wnd.res'//trim(suffix)//'.nc'
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_srf_wnd.res'//trim(suffix)//'.nc'
Atm(1)%Rsf_restart_is_open = open_file(Atm(1)%Rsf_restart, fname, "read", fv_domain, is_restart=.true.)
if (Atm(1)%Rsf_restart_is_open) then
Atm(1)%flagstruct%srf_init = .true.
@@ -418,7 +489,7 @@ subroutine fv_io_read_restart(fv_domain,Atm)
if ( Atm(1)%flagstruct%fv_land ) then
!--- restore data for mg_drag - if it exists
- fname = 'INPUT/mg_drag.res'//trim(suffix)//'.nc'
+ fname = ''//trim(dir)//'/'//trim(pre)//'mg_drag.res'//trim(suffix)//'.nc'
Atm(1)%Mg_restart_is_open = open_file(Atm(1)%Mg_restart, fname, "read", fv_domain, is_restart=.true.)
if (Atm(1)%Mg_restart_is_open) then
call fv_io_register_restart(Atm(1))
@@ -429,7 +500,7 @@ subroutine fv_io_read_restart(fv_domain,Atm)
call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
endif
!--- restore data for fv_land - if it exists
- fname = 'INPUT/fv_land.res'//trim(suffix)//'.nc'
+ fname = ''//trim(dir)//'/'//trim(pre)//'/fv_land.res'//trim(suffix)//'.nc'
Atm(1)%Lnd_restart_is_open = open_file(Atm(1)%Lnd_restart, fname, "read", fv_domain, is_restart=.true.)
if (Atm(1)%Lnd_restart_is_open) then
call fv_io_register_restart(Atm(1))
@@ -659,8 +730,7 @@ subroutine remap_restart(fv_domain,Atm)
j = (jsc + jec)/2
k = npz_rst/2
if( is_master() ) write(*,*) 'Calling read_da_inc',pt_r(i,j,k)
- call read_da_inc(Atm(1), Atm(1)%domain, Atm(1)%bd, npz_rst, ntprog, &
- u_r, v_r, q_r, delp_r, pt_r, isc, jsc, iec, jec )
+ call read_da_inc(Atm(n), Atm(n)%domain)
if( is_master() ) write(*,*) 'Back from read_da_inc',pt_r(i,j,k)
endif
! ====== end PJP added DA functionailty======
@@ -706,9 +776,8 @@ subroutine fv_io_register_nudge_restart(Atm)
call mpp_error(NOTE, 'READING FROM SST_restart DISABLED')
end subroutine fv_io_register_nudge_restart
- ! NAME="fv_io_register_nudge_restart"
-
+ ! NAME="fv_io_register_nudge_restart"
!#####################################################################
!
@@ -716,15 +785,16 @@ end subroutine fv_io_register_nudge_restart
!
! Write the fv core restart quantities
!
- subroutine fv_io_write_restart(Atm, timestamp)
+ subroutine fv_io_write_restart(Atm, prefix, directory)
type(fv_atmos_type), intent(inout) :: Atm
- character(len=*), optional, intent(in) :: timestamp
+ character(len=*), optional, intent(in) :: prefix
+ character(len=*), optional, intent(in) :: directory
+
+ character (len=:), allocatable :: dir, pre, fname, suffix
integer :: ntiles
logical :: tile_file_exists
type(domain2d) :: fv_domain
- character(len=120) :: fname
- character(len=20) :: suffix
character(len=1) :: tile_num
integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist
fv_domain = Atm%domain
@@ -733,12 +803,14 @@ subroutine fv_io_write_restart(Atm, timestamp)
!call save_restart(Atm%SST_restart, timestamp)
endif
+ pre = ''
+ dir = 'RESTART'
+ if (present(prefix)) pre = ''//trim(prefix)//'.'
+ if (present(directory)) dir = trim(directory)
+
suffix = ''
- if (present(timestamp)) then
- fname = 'RESTART/'//trim(timestamp)//'.fv_core.res'//trim(suffix)//'.nc'
- else
- fname = 'RESTART/fv_core.res'//trim(suffix)//'.nc'
- endif
+
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_core.res.nc'
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
Atm%Fv_restart_is_open = open_file(Atm%Fv_restart, fname, "overwrite", is_restart=.true., pelist=pes)
@@ -756,12 +828,7 @@ subroutine fv_io_write_restart(Atm, timestamp)
suffix = ''//trim(suffix)//'.tile1'
endif
- if (present(timestamp)) then
- fname = 'RESTART/'//trim(timestamp)//'.fv_core.res'//trim(suffix)//'.nc'
- else
- fname = 'RESTART/fv_core.res'//trim(suffix)//'.nc'
- endif
-
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_core.res'//trim(suffix)//'.nc'
Atm%Fv_restart_tile_is_open = open_file(Atm%Fv_restart_tile, fname, "overwrite", fv_domain, is_restart=.true.)
if (Atm%Fv_restart_tile_is_open) then
call fv_io_register_restart(Atm)
@@ -770,11 +837,7 @@ subroutine fv_io_write_restart(Atm, timestamp)
Atm%Fv_restart_tile_is_open = .false.
endif
- if (present(timestamp)) then
- fname = 'RESTART/'//trim(timestamp)//'.fv_srf_wnd.res'//trim(suffix)//'.nc'
- else
- fname = 'RESTART/fv_srf_wnd.res'//trim(suffix)//'.nc'
- endif
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_srf_wnd.res'//trim(suffix)//'.nc'
Atm%Rsf_restart_is_open = open_file(Atm%Rsf_restart, fname, "overwrite", fv_domain, is_restart=.true.)
if (Atm%Rsf_restart_is_open) then
call fv_io_register_restart(Atm)
@@ -784,11 +847,7 @@ subroutine fv_io_write_restart(Atm, timestamp)
endif
if ( Atm%flagstruct%fv_land ) then
- if (present(timestamp)) then
- fname = 'RESTART/'//trim(timestamp)//'.mg_drag.res'//trim(suffix)//'.nc'
- else
- fname = 'RESTART/mg_drag.res'//trim(suffix)//'.nc'
- endif
+ fname = ''//trim(dir)//'/'//trim(pre)//'mg_drag.res'//trim(suffix)//'.nc'
Atm%Mg_restart_is_open = open_file(Atm%Mg_restart, fname, "overwrite", fv_domain, is_restart=.true.)
if (Atm%Mg_restart_is_open) then
call fv_io_register_restart(Atm)
@@ -797,11 +856,7 @@ subroutine fv_io_write_restart(Atm, timestamp)
Atm%Mg_restart_is_open = .false.
endif
- if (present(timestamp)) then
- fname = 'RESTART'//trim(timestamp)//'./fv_land.res'//trim(suffix)//'.nc'
- else
- fname = 'RESTART/fv_land.res'//trim(suffix)//'.nc'
- endif
+ fname = ''//trim(dir)//'/'//trim(pre)//'/fv_land.res'//trim(suffix)//'.nc'
Atm%Lnd_restart_is_open = open_file(Atm%Lnd_restart, fname, "overwrite", fv_domain, is_restart=.true.)
if (Atm%Lnd_restart_is_open) then
call fv_io_register_restart(Atm)
@@ -811,11 +866,7 @@ subroutine fv_io_write_restart(Atm, timestamp)
endif
endif
- if (present(timestamp)) then
- fname = 'RESTART/'//trim(timestamp)//'.fv_tracer.res'//trim(suffix)//'.nc'
- else
- fname = 'RESTART/fv_tracer.res'//trim(suffix)//'.nc'
- endif
+ fname = ''//trim(dir)//'/'//trim(pre)//'fv_tracer.res'//trim(suffix)//'.nc'
Atm%Tra_restart_is_open = open_file(Atm%Tra_restart, fname, "overwrite", fv_domain, is_restart=.true.)
if (Atm%Tra_restart_is_open) then
call fv_io_register_restart(Atm)
@@ -824,7 +875,8 @@ subroutine fv_io_write_restart(Atm, timestamp)
Atm%Tra_restart_is_open = .false.
endif
- end subroutine fv_io_write_restart
+ end subroutine fv_io_write_restart
+
subroutine register_bcs_2d(Atm, BCfile_ne, BCfile_sw, fname_ne, fname_sw, &
var_name, var, var_bc, istag, jstag)
@@ -887,36 +939,66 @@ subroutine register_bcs_2d(Atm, BCfile_ne, BCfile_sw, fname_ne, fname_sw, &
is_root_pe = .FALSE.
if (is.eq.1 .and. js.eq.1) is_root_pe = .TRUE.
!register west halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_west_t1', &
- var_bc%west_t1, &
- indices, global_size, y2_pelist, &
- is_root_pe, jshift=y_halo)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_west_t1', &
+ var_bc%west_t1, indices, global_size, &
+ y2_pelist, is_root_pe, jshift=y_halo)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west_t1', &
+ "long_name", trim(var_name)//'_west_t1', &
+ str_len=len(trim(var_name)//'_west_t1'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!register west prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_west', &
- var, indices, global_size, &
- y2_pelist, is_root_pe, jshift=y_halo)
+ if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_west', &
+ var, indices, global_size, &
+ y2_pelist, is_root_pe, jshift=y_halo)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west', &
+ "long_name", trim(var_name)//'_west', &
+ str_len=len(trim(var_name)//'_west'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!define east root_pe
is_root_pe = .FALSE.
if (ie.eq.npx-1 .and. je.eq.npy-1) is_root_pe = .TRUE.
!register east halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_east_t1', &
- var_bc%east_t1, &
- indices, global_size, y1_pelist, &
- is_root_pe, jshift=y_halo)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_east_t1', &
+ var_bc%east_t1, indices, global_size, &
+ y1_pelist, is_root_pe, jshift=y_halo)
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east_t1', &
+ "long_name", trim(var_name)//'_east_t1', &
+ str_len=len(trim(var_name)//'_east_t1'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!reset indices for prognostic variables in the east halo
indices(1) = ied-x_halo+1+i_stag
indices(2) = ied+i_stag
!register east prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_east', &
- var, indices, global_size, &
- y1_pelist, is_root_pe, jshift=y_halo, &
- x_halo=(size(var,1)-x_halo), ishift=-(ie+i_stag))
+ if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_east', &
+ var, indices, global_size, &
+ y1_pelist, is_root_pe, jshift=y_halo, &
+ x_halo=(size(var,1)-x_halo), ishift=-(ie+i_stag))
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east', &
+ "long_name", trim(var_name)//'_east', &
+ str_len=len(trim(var_name)//'_east'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!NORTH & SOUTH
!set defaults for north/south halo regions
@@ -936,36 +1018,66 @@ subroutine register_bcs_2d(Atm, BCfile_ne, BCfile_sw, fname_ne, fname_sw, &
is_root_pe = .FALSE.
if (is.eq.1 .and. js.eq.1) is_root_pe = .TRUE.
!register south halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_south_t1', &
- var_bc%south_t1, &
- indices, global_size, x2_pelist, &
- is_root_pe, x_halo=x_halo_ns)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_south_t1', &
+ var_bc%south_t1, indices, global_size, &
+ x2_pelist, is_root_pe, x_halo=x_halo_ns)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south_t1', &
+ "long_name", trim(var_name)//'_south_t1', &
+ str_len=len(trim(var_name)//'_south_t1'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!register south prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_south', &
- var, indices, global_size, &
- x2_pelist, is_root_pe, x_halo=x_halo_ns)
+ if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_south', &
+ var, indices, global_size, &
+ x2_pelist, is_root_pe, x_halo=x_halo_ns)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south', &
+ "long_name", trim(var_name)//'_south', &
+ str_len=len(trim(var_name)//'_south'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!define north root_pe
is_root_pe = .FALSE.
if (ie.eq.npx-1 .and. je.eq.npy-1) is_root_pe = .TRUE.
!register north halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_north_t1', &
- var_bc%north_t1, &
- indices, global_size, x1_pelist, &
- is_root_pe, x_halo=x_halo_ns)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_north_t1', &
+ var_bc%north_t1, indices, global_size, &
+ x1_pelist, is_root_pe, x_halo=x_halo_ns)
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north_t1', &
+ "long_name", trim(var_name)//'_north_t1', &
+ str_len=len(trim(var_name)//'_north_t1'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!reset indices for prognostic variables in the north halo
indices(3) = jed-y_halo+1+j_stag
indices(4) = jed+j_stag
!register north prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_north', &
- var, indices, global_size, &
- x1_pelist, is_root_pe, x_halo=x_halo_ns, &
- y_halo=(size(var,2)-y_halo), jshift=-(je+j_stag))
+ if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_north', &
+ var, indices, global_size, &
+ x1_pelist, is_root_pe, x_halo=x_halo_ns, &
+ y_halo=(size(var,2)-y_halo), jshift=-(je+j_stag))
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north', &
+ "long_name", trim(var_name)//'_north', &
+ str_len=len(trim(var_name)//'_north'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
deallocate (x1_pelist)
deallocate (y1_pelist)
@@ -1042,36 +1154,71 @@ subroutine register_bcs_3d(Atm, BCfile_ne, BCfile_sw, fname_ne, fname_sw, &
is_root_pe = .FALSE.
if (is.eq.1 .and. js.eq.1) is_root_pe = .TRUE.
!register west halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_west_t1', &
- var_bc%west_t1, &
- indices, global_size, y2_pelist, &
- is_root_pe, jshift=y_halo, is_optional=.not.mandatory_flag)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_west_t1', &
+ var_bc%west_t1, indices, global_size, &
+ y2_pelist, is_root_pe, jshift=y_halo, &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west_t1', &
+ "long_name", trim(var_name)//'_west_t1', &
+ str_len=len(trim(var_name)//'_west_t1'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
+
!register west prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_west', &
- var, indices, global_size, &
- y2_pelist, is_root_pe, jshift=y_halo, is_optional=.not.mandatory_flag)
+ if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_west', &
+ var, indices, global_size, &
+ y2_pelist, is_root_pe, jshift=y_halo, &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west', &
+ "long_name", trim(var_name)//'_west', &
+ str_len=len(trim(var_name)//'_west'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_west', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!define east root_pe
is_root_pe = .FALSE.
if (ie.eq.npx-1 .and. je.eq.npy-1) is_root_pe = .TRUE.
!register east halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_east_t1', &
- var_bc%east_t1, &
- indices, global_size, y1_pelist, &
- is_root_pe, jshift=y_halo, is_optional=.not.mandatory_flag)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_east_t1', &
+ var_bc%east_t1, indices, global_size, &
+ y1_pelist, is_root_pe, jshift=y_halo, &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east_t1', &
+ "long_name", trim(var_name)//'_east_t1', &
+ str_len=len(trim(var_name)//'_east_t1'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!reset indices for prognostic variables in the east halo
indices(1) = ied-x_halo+1+i_stag
indices(2) = ied+i_stag
!register east prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_east', &
- var, indices, global_size, &
- y1_pelist, is_root_pe, jshift=y_halo, &
- x_halo=(size(var,1)-x_halo), ishift=-(ie+i_stag), is_optional=.not.mandatory_flag)
+ if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_east', &
+ var, indices, global_size, &
+ y1_pelist, is_root_pe, jshift=y_halo, &
+ x_halo=(size(var,1)-x_halo), ishift=-(ie+i_stag), &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east', &
+ "long_name", trim(var_name)//'_east', &
+ str_len=len(trim(var_name)//'_east'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_east', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!NORTH & SOUTH
!set defaults for north/south halo regions
@@ -1092,36 +1239,70 @@ subroutine register_bcs_3d(Atm, BCfile_ne, BCfile_sw, fname_ne, fname_sw, &
is_root_pe = .FALSE.
if (is.eq.1 .and. js.eq.1) is_root_pe = .TRUE.
!register south halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_south_t1', &
- var_bc%south_t1, &
- indices, global_size, x2_pelist, &
- is_root_pe, x_halo=x_halo_ns, is_optional=.not.mandatory_flag)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_south_t1', &
+ var_bc%south_t1, indices, global_size, &
+ x2_pelist, is_root_pe, x_halo=x_halo_ns, &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south_t1', &
+ "long_name", trim(var_name)//'_south_t1', &
+ str_len=len(trim(var_name)//'_south_t1'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!register south prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) call register_restart_field(BCfile_sw, &
- trim(var_name)//'_south', &
- var, indices, global_size, &
- x2_pelist, is_root_pe, x_halo=x_halo_ns, is_optional=.not.mandatory_flag)
+ if (present(var) .and. Atm%neststruct%BCfile_sw_is_open) then
+ call register_restart_field(BCfile_sw, trim(var_name)//'_south', &
+ var, indices, global_size, &
+ x2_pelist, is_root_pe, x_halo=x_halo_ns, &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_sw%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south', &
+ "long_name", trim(var_name)//'_south', &
+ str_len=len(trim(var_name)//'_south'))
+ call register_variable_attribute(BCfile_sw, trim(var_name)//'_south', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!define north root_pe
is_root_pe = .FALSE.
if (ie.eq.npx-1 .and. je.eq.npy-1) is_root_pe = .TRUE.
!register north halo data in t1
- if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_north_t1', &
- var_bc%north_t1, &
- indices, global_size, x1_pelist, &
- is_root_pe, x_halo=x_halo_ns, is_optional=.not.mandatory_flag)
+ if (present(var_bc) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_north_t1', &
+ var_bc%north_t1, indices, global_size, &
+ x1_pelist, is_root_pe, x_halo=x_halo_ns, &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north_t1', &
+ "long_name", trim(var_name)//'_north_t1', &
+ str_len=len(trim(var_name)//'_north_t1'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north_t1', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
!reset indices for prognostic variables in the north halo
indices(3) = jed-y_halo+1+j_stag
indices(4) = jed+j_stag
!register north prognostic halo data
- if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) call register_restart_field(BCfile_ne, &
- trim(var_name)//'_north', &
- var, indices, global_size, &
- x1_pelist, is_root_pe, x_halo=x_halo_ns, &
- y_halo=(size(var,2)-y_halo), jshift=-(je+j_stag), is_optional=.not.mandatory_flag)
+ if (present(var) .and. Atm%neststruct%BCfile_ne_is_open) then
+ call register_restart_field(BCfile_ne, trim(var_name)//'_north', &
+ var, indices, global_size, &
+ x1_pelist, is_root_pe, x_halo=x_halo_ns, &
+ y_halo=(size(var,2)-y_halo), jshift=-(je+j_stag), &
+ is_optional=.not.mandatory_flag)
+ if (.not. BCfile_ne%is_readonly) then !if writing file
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north', &
+ "long_name", trim(var_name)//'_north', &
+ str_len=len(trim(var_name)//'_north'))
+ call register_variable_attribute(BCfile_ne, trim(var_name)//'_north', &
+ "units", "none", str_len=len("none"))
+ endif
+ endif
deallocate (x1_pelist)
deallocate (y1_pelist)
deallocate (x2_pelist)
diff --git a/tools/fv_mp_mod.F90 b/tools/fv_mp_mod.F90
index 79eb259ef..ee081fd1b 100644
--- a/tools/fv_mp_mod.F90
+++ b/tools/fv_mp_mod.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
!------------------------------------------------------------------------------
!BOP
!
@@ -32,6 +33,7 @@ module fv_mp_mod
use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_sync
use mpp_mod, only : mpp_clock_begin, mpp_clock_end, mpp_clock_id
use mpp_mod, only : mpp_chksum, stdout, stderr, mpp_broadcast
+ use mpp_mod, only : mpp_min, mpp_max, mpp_sum
use mpp_mod, only : mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_gather
use mpp_domains_mod, only : GLOBAL_DATA_DOMAIN, BITWISE_EXACT_SUM, BGRID_NE, FOLD_NORTH_EDGE, CGRID_NE
use mpp_domains_mod, only : MPP_DOMAIN_TIME, CYCLIC_GLOBAL_DOMAIN, NUPDATE,EUPDATE, XUPDATE, YUPDATE, SCALAR_PAIR
@@ -93,7 +95,7 @@ module fv_mp_mod
type(nest_domain_type) :: global_nest_domain !ONE structure for ALL levels of nesting
public mp_start, mp_assign_gid, mp_barrier, mp_stop!, npes
- public domain_decomp, mp_bcst, mp_reduce_max, mp_reduce_sum, mp_gather
+ public domain_decomp, mp_reduce_max, mp_reduce_sum, mp_gather
public mp_reduce_min
public fill_corners, XDir, YDir
public switch_current_domain, switch_current_Atm, broadcast_domains
@@ -134,18 +136,6 @@ module fv_mp_mod
MODULE PROCEDURE fill_corners_dgrid_r8
END INTERFACE
- INTERFACE mp_bcst
- MODULE PROCEDURE mp_bcst_i4
- MODULE PROCEDURE mp_bcst_r4
- MODULE PROCEDURE mp_bcst_r8
- MODULE PROCEDURE mp_bcst_3d_r4
- MODULE PROCEDURE mp_bcst_3d_r8
- MODULE PROCEDURE mp_bcst_4d_r4
- MODULE PROCEDURE mp_bcst_4d_r8
- MODULE PROCEDURE mp_bcst_3d_i8
- MODULE PROCEDURE mp_bcst_4d_i8
- END INTERFACE
-
INTERFACE mp_reduce_min
MODULE PROCEDURE mp_reduce_min_r4
MODULE PROCEDURE mp_reduce_min_r8
@@ -162,8 +152,12 @@ module fv_mp_mod
INTERFACE mp_reduce_sum
MODULE PROCEDURE mp_reduce_sum_r4
MODULE PROCEDURE mp_reduce_sum_r4_1d
+ MODULE PROCEDURE mp_reduce_sum_r4_1darr
+ MODULE PROCEDURE mp_reduce_sum_r4_2darr
MODULE PROCEDURE mp_reduce_sum_r8
MODULE PROCEDURE mp_reduce_sum_r8_1d
+ MODULE PROCEDURE mp_reduce_sum_r8_1darr
+ MODULE PROCEDURE mp_reduce_sum_r8_2darr
END INTERFACE
INTERFACE mp_gather !WARNING only works with one level (ldim == 1)
@@ -1463,7 +1457,6 @@ subroutine mp_gather_4d_r4(q, i1,i2, j1,j2, idim, jdim, kdim, ldim)
Ldispl(l) = 5*(l-1)
enddo
call mpp_gather(Ldims, Gdims)
-! call MPI_GATHERV(Ldims, 5, MPI_INTEGER, Gdims, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
Lsize = ( (i2 - i1 + 1) * (j2 - j1 + 1) ) * kdim
do l=1,npes_this_grid
@@ -1473,7 +1466,6 @@ subroutine mp_gather_4d_r4(q, i1,i2, j1,j2, idim, jdim, kdim, ldim)
LsizeS(:)=1
Lsize_buf(1) = Lsize
call mpp_gather(Lsize_buf, LsizeS)
-! call MPI_GATHERV(Lsize, 1, MPI_INTEGER, LsizeS, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
allocate ( larr(Lsize) )
icnt = 1
@@ -1486,18 +1478,15 @@ subroutine mp_gather_4d_r4(q, i1,i2, j1,j2, idim, jdim, kdim, ldim)
enddo
enddo
Ldispl(1) = 0.0
-! call mp_bcst(LsizeS(1))
call mpp_broadcast(LsizeS, npes_this_grid, masterproc)
Gsize = LsizeS(1)
do l=2,npes_this_grid
-! call mp_bcst(LsizeS(l))
Ldispl(l) = Ldispl(l-1) + LsizeS(l-1)
Gsize = Gsize + LsizeS(l)
enddo
allocate ( garr(Gsize) )
call mpp_gather(larr, Lsize, garr, LsizeS)
-! call MPI_GATHERV(larr, Lsize, MPI_REAL, garr, LsizeS, Ldispl, MPI_REAL, masterproc, commglobal, ierror)
if (gid==masterproc) then
do n=2,npes_this_grid
@@ -1548,7 +1537,6 @@ subroutine mp_gather_3d_r4(q, i1,i2, j1,j2, idim, jdim, ldim)
cnts(l) = 5
Ldispl(l) = 5*(l-1)
enddo
-! call MPI_GATHERV(Ldims, 5, MPI_INTEGER, Gdims, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
call mpp_gather(Ldims, Gdims)
Lsize = ( (i2 - i1 + 1) * (j2 - j1 + 1) )
@@ -1559,7 +1547,6 @@ subroutine mp_gather_3d_r4(q, i1,i2, j1,j2, idim, jdim, ldim)
LsizeS(:)=1
Lsize_buf(1) = Lsize
call mpp_gather(Lsize_buf, LsizeS)
-! call MPI_GATHERV(Lsize, 1, MPI_INTEGER, LsizeS, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
allocate ( larr(Lsize) )
icnt = 1
@@ -1570,17 +1557,14 @@ subroutine mp_gather_3d_r4(q, i1,i2, j1,j2, idim, jdim, ldim)
enddo
enddo
Ldispl(1) = 0.0
-! call mp_bcst(LsizeS(1))
call mpp_broadcast(LsizeS, npes_this_grid, masterproc)
Gsize = LsizeS(1)
do l=2,npes_this_grid
-! call mp_bcst(LsizeS(l))
Ldispl(l) = Ldispl(l-1) + LsizeS(l-1)
Gsize = Gsize + LsizeS(l)
enddo
allocate ( garr(Gsize) )
call mpp_gather(larr, Lsize, garr, LsizeS)
-! call MPI_GATHERV(larr, Lsize, MPI_REAL, garr, LsizeS, Ldispl, MPI_REAL, masterproc, commglobal, ierror)
if (gid==masterproc) then
do n=2,npes_this_grid
icnt=1
@@ -1636,7 +1620,6 @@ subroutine mp_gather_3d_r8(q, i1,i2, j1,j2, idim, jdim, ldim)
enddo
LsizeS(:)=0.
-! call MPI_GATHERV(Lsize, 1, MPI_INTEGER, LsizeS, cnts, Ldispl, MPI_INTEGER, masterproc, commglobal, ierror)
Lsize_buf(1) = Lsize
call mpp_gather(Lsize_buf, LsizeS)
@@ -1650,17 +1633,14 @@ subroutine mp_gather_3d_r8(q, i1,i2, j1,j2, idim, jdim, ldim)
enddo
Ldispl(1) = 0.0
call mpp_broadcast(LsizeS, npes_this_grid, masterproc)
-! call mp_bcst(LsizeS(1))
Gsize = LsizeS(1)
do l=2,npes_this_grid
-! call mp_bcst(LsizeS(l))
Ldispl(l) = Ldispl(l-1) + LsizeS(l-1)
Gsize = Gsize + LsizeS(l)
enddo
allocate ( garr(Gsize) )
call mpp_gather(larr, Lsize, garr, LsizeS)
-! call MPI_GATHERV(larr, Lsize, MPI_DOUBLE_PRECISION, garr, LsizeS, Ldispl, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)
if (gid==masterproc) then
do n=2,npes_this_grid
icnt=1
@@ -1682,147 +1662,6 @@ end subroutine mp_gather_3d_r8
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_i4 :: Call SPMD broadcast
-!
- subroutine mp_bcst_i4(q)
- integer, intent(INOUT) :: q
-
- call MPI_BCAST(q, 1, MPI_INTEGER, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_i4
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_r4 :: Call SPMD broadcast
-!
- subroutine mp_bcst_r4(q)
- real(kind=4), intent(INOUT) :: q
-
- call MPI_BCAST(q, 1, MPI_REAL, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_r4
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_r8 :: Call SPMD broadcast
-!
- subroutine mp_bcst_r8(q)
- real(kind=8), intent(INOUT) :: q
-
- call MPI_BCAST(q, 1, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_r8
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_3d_r4 :: Call SPMD broadcast
-!
- subroutine mp_bcst_3d_r4(q, idim, jdim, kdim)
- integer, intent(IN) :: idim, jdim, kdim
- real(kind=4), intent(INOUT) :: q(idim,jdim,kdim)
-
- call MPI_BCAST(q, idim*jdim*kdim, MPI_REAL, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_3d_r4
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_3d_r8 :: Call SPMD broadcast
-!
- subroutine mp_bcst_3d_r8(q, idim, jdim, kdim)
- integer, intent(IN) :: idim, jdim, kdim
- real(kind=8), intent(INOUT) :: q(idim,jdim,kdim)
-
- call MPI_BCAST(q, idim*jdim*kdim, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_3d_r8
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_4d_r4 :: Call SPMD broadcast
-!
- subroutine mp_bcst_4d_r4(q, idim, jdim, kdim, ldim)
- integer, intent(IN) :: idim, jdim, kdim, ldim
- real(kind=4), intent(INOUT) :: q(idim,jdim,kdim,ldim)
-
- call MPI_BCAST(q, idim*jdim*kdim*ldim, MPI_REAL, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_4d_r4
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_4d_r8 :: Call SPMD broadcast
-!
- subroutine mp_bcst_4d_r8(q, idim, jdim, kdim, ldim)
- integer, intent(IN) :: idim, jdim, kdim, ldim
- real(kind=8), intent(INOUT) :: q(idim,jdim,kdim,ldim)
-
- call MPI_BCAST(q, idim*jdim*kdim*ldim, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_4d_r8
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_3d_i8 :: Call SPMD broadcast
-!
- subroutine mp_bcst_3d_i8(q, idim, jdim, kdim)
- integer, intent(IN) :: idim, jdim, kdim
- integer, intent(INOUT) :: q(idim,jdim,kdim)
-
- call MPI_BCAST(q, idim*jdim*kdim, MPI_INTEGER, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_3d_i8
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
-!
-! mp_bcst_4d_i8 :: Call SPMD broadcast
-!
- subroutine mp_bcst_4d_i8(q, idim, jdim, kdim, ldim)
- integer, intent(IN) :: idim, jdim, kdim, ldim
- integer, intent(INOUT) :: q(idim,jdim,kdim,ldim)
-
- call MPI_BCAST(q, idim*jdim*kdim*ldim, MPI_INTEGER, masterproc, commglobal, ierror)
-
- end subroutine mp_bcst_4d_i8
-!
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
-!-------------------------------------------------------------------------------
-
!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
@@ -1835,10 +1674,11 @@ subroutine mp_reduce_max_r4_1d(mymax,npts)
real(kind=4) :: gmax(npts)
- call MPI_ALLREDUCE( mymax, gmax, npts, MPI_REAL, MPI_MAX, &
- commglobal, ierror )
-
- mymax = gmax
+ call mpp_max (mymax, npts)
+! call MPI_ALLREDUCE( mymax, gmax, npts, MPI_REAL, MPI_MAX, &
+! commglobal, ierror )
+!
+! mymax = gmax
end subroutine mp_reduce_max_r4_1d
!
@@ -1857,10 +1697,11 @@ subroutine mp_reduce_max_r8_1d(mymax,npts)
real(kind=8) :: gmax(npts)
- call MPI_ALLREDUCE( mymax, gmax, npts, MPI_DOUBLE_PRECISION, MPI_MAX, &
- commglobal, ierror )
-
- mymax = gmax
+ call mpp_max (mymax, npts)
+! call MPI_ALLREDUCE( mymax, gmax, npts, MPI_DOUBLE_PRECISION, MPI_MAX, &
+! commglobal, ierror )
+!
+! mymax = gmax
end subroutine mp_reduce_max_r8_1d
!
@@ -1878,10 +1719,11 @@ subroutine mp_reduce_max_r4(mymax)
real(kind=4) :: gmax
- call MPI_ALLREDUCE( mymax, gmax, 1, MPI_REAL, MPI_MAX, &
- commglobal, ierror )
-
- mymax = gmax
+ call mpp_max (mymax)
+! call MPI_ALLREDUCE( mymax, gmax, 1, MPI_REAL, MPI_MAX, &
+! commglobal, ierror )
+!
+! mymax = gmax
end subroutine mp_reduce_max_r4
@@ -1895,10 +1737,11 @@ subroutine mp_reduce_max_r8(mymax)
real(kind=8) :: gmax
- call MPI_ALLREDUCE( mymax, gmax, 1, MPI_DOUBLE_PRECISION, MPI_MAX, &
- commglobal, ierror )
-
- mymax = gmax
+ call mpp_max (mymax)
+! call MPI_ALLREDUCE( mymax, gmax, 1, MPI_DOUBLE_PRECISION, MPI_MAX, &
+! commglobal, ierror )
+!
+! mymax = gmax
end subroutine mp_reduce_max_r8
@@ -1907,10 +1750,11 @@ subroutine mp_reduce_min_r4(mymin)
real(kind=4) :: gmin
- call MPI_ALLREDUCE( mymin, gmin, 1, MPI_REAL, MPI_MIN, &
- commglobal, ierror )
-
- mymin = gmin
+ call mpp_min (mymin)
+! call MPI_ALLREDUCE( mymin, gmin, 1, MPI_REAL, MPI_MIN, &
+! commglobal, ierror )
+!
+! mymin = gmin
end subroutine mp_reduce_min_r4
@@ -1919,10 +1763,11 @@ subroutine mp_reduce_min_r8(mymin)
real(kind=8) :: gmin
- call MPI_ALLREDUCE( mymin, gmin, 1, MPI_DOUBLE_PRECISION, MPI_MIN, &
- commglobal, ierror )
-
- mymin = gmin
+ call mpp_min (mymin)
+! call MPI_ALLREDUCE( mymin, gmin, 1, MPI_DOUBLE_PRECISION, MPI_MIN, &
+! commglobal, ierror )
+!
+! mymin = gmin
end subroutine mp_reduce_min_r8
!
@@ -1932,17 +1777,18 @@ end subroutine mp_reduce_min_r8
!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
-! mp_bcst_4d_i4 :: Call SPMD REDUCE_MAX
+! mp_reduce_max_i4 :: Call SPMD REDUCE_MAX
!
subroutine mp_reduce_max_i4(mymax)
integer, intent(INOUT) :: mymax
integer :: gmax
- call MPI_ALLREDUCE( mymax, gmax, 1, MPI_INTEGER, MPI_MAX, &
- commglobal, ierror )
-
- mymax = gmax
+ call mpp_max(mymax)
+! call MPI_ALLREDUCE( mymax, gmax, 1, MPI_INTEGER, MPI_MAX, &
+! commglobal, ierror )
+!
+! mymax = gmax
end subroutine mp_reduce_max_i4
!
@@ -1959,10 +1805,11 @@ subroutine mp_reduce_sum_r4(mysum)
real(kind=4) :: gsum
- call MPI_ALLREDUCE( mysum, gsum, 1, MPI_REAL, MPI_SUM, &
- commglobal, ierror )
-
- mysum = gsum
+ call mpp_sum(mysum)
+! call MPI_ALLREDUCE( mysum, gsum, 1, MPI_REAL, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
end subroutine mp_reduce_sum_r4
!
@@ -1979,10 +1826,11 @@ subroutine mp_reduce_sum_r8(mysum)
real(kind=8) :: gsum
- call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
- commglobal, ierror )
-
- mysum = gsum
+ call mpp_sum (mysum)
+! call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
end subroutine mp_reduce_sum_r8
!
@@ -2007,10 +1855,11 @@ subroutine mp_reduce_sum_r4_1d(mysum, sum1d, npts)
mysum = mysum + sum1d(i)
enddo
- call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
- commglobal, ierror )
-
- mysum = gsum
+ call mpp_sum (mysum)
+! call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
end subroutine mp_reduce_sum_r4_1d
!
@@ -2035,15 +1884,107 @@ subroutine mp_reduce_sum_r8_1d(mysum, sum1d, npts)
mysum = mysum + sum1d(i)
enddo
- call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
- commglobal, ierror )
-
- mysum = gsum
+ call mpp_sum (mysum)
+! call MPI_ALLREDUCE( mysum, gsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
end subroutine mp_reduce_sum_r8_1d
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------
+! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
+!
+! mp_reduce_sum_r4_1darr :: Call SPMD REDUCE_SUM
+!
+ subroutine mp_reduce_sum_r4_1darr(mysum, npts)
+ integer, intent(in) :: npts
+ real(kind=4), intent(inout) :: mysum(npts)
+ real(kind=4) :: gsum(npts)
+
+ call mpp_sum (mysum, npts)
+! gsum = 0.0
+! call MPI_ALLREDUCE( mysum, gsum, npts, MPI_REAL, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
+
+ end subroutine mp_reduce_sum_r4_1darr
+!
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
+!-------------------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------
+! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
+!
+! mp_reduce_sum_r4_2darr :: Call SPMD REDUCE_SUM
+!
+ subroutine mp_reduce_sum_r4_2darr(mysum, npts1,npts2)
+ integer, intent(in) :: npts1,npts2
+ real(kind=4), intent(inout) :: mysum(npts1,npts2)
+ real(kind=4) :: gsum(npts1,npts2)
+
+ call mpp_sum (mysum, npts1*npts2)
+! gsum = 0.0
+! call MPI_ALLREDUCE( mysum, gsum, npts1*npts2, MPI_REAL, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
+
+ end subroutine mp_reduce_sum_r4_2darr
+!
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
+!-------------------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------
+! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
+!
+! mp_reduce_sum_r8_1darr :: Call SPMD REDUCE_SUM
+!
+ subroutine mp_reduce_sum_r8_1darr(mysum, npts)
+ integer, intent(in) :: npts
+ real(kind=8), intent(inout) :: mysum(npts)
+ real(kind=8) :: gsum(npts)
+
+ call mpp_sum (mysum, npts)
+! gsum = 0.0
+! call MPI_ALLREDUCE( mysum, gsum, npts, MPI_DOUBLE_PRECISION, &
+! MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
+
+ end subroutine mp_reduce_sum_r8_1darr
+!
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
+!-------------------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------
+! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
+!
+! mp_reduce_sum_r8_2darr :: Call SPMD REDUCE_SUM
+!
+ subroutine mp_reduce_sum_r8_2darr(mysum, npts1,npts2)
+ integer, intent(in) :: npts1,npts2
+ real(kind=8), intent(inout) :: mysum(npts1,npts2)
+ real(kind=8) :: gsum(npts1,npts2)
+
+ call mpp_sum (mysum, npts1*npts2)
+! gsum = 0.0
+! call MPI_ALLREDUCE( mysum, gsum, npts1*npts2, &
+! MPI_DOUBLE_PRECISION, MPI_SUM, &
+! commglobal, ierror )
+!
+! mysum = gsum
+
+ end subroutine mp_reduce_sum_r8_2darr
+!
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
+!-------------------------------------------------------------------------------
+
#else
implicit none
private
diff --git a/tools/fv_nggps_diag.F90 b/tools/fv_nggps_diag.F90
index 8e68b2e44..63b086699 100644
--- a/tools/fv_nggps_diag.F90
+++ b/tools/fv_nggps_diag.F90
@@ -11,7 +11,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -71,11 +71,12 @@ module fv_nggps_diags_mod
use diag_util_mod, only: find_input_field
use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
- use fv_diagnostics_mod, only: range_check, dbzcalc,max_vv,get_vorticity, &
- max_uh,max_vorticity,bunkers_vector, &
- helicity_relative_CAPS,max_vorticity_hy1
+ use fv_diagnostics_mod, only: range_check, max_vv, get_vorticity, &
+ max_uh, bunkers_vector, helicity_relative_CAPS
use fv_arrays_mod, only: fv_atmos_type
use mpp_domains_mod, only: domain1d, domainUG
+ use rad_ref_mod, only: rad_ref
+ use fv_eta_mod, only: get_eta_level
#ifdef MULTI_GASES
use multi_gases_mod, only: virq
#endif
@@ -107,6 +108,7 @@ module fv_nggps_diags_mod
integer :: id_maxvort02,kstt_maxvort02,kend_maxvort02
integer :: isco, ieco, jsco, jeco, npzo, ncnsto
integer :: isdo, iedo, jsdo, jedo
+ integer :: mp_top
integer :: nlevs
logical :: hydrostatico
integer, allocatable :: id_tracer(:), all_axes(:)
@@ -149,7 +151,9 @@ subroutine fv_nggps_diag_init(Atm, axes, Time)
type(fv_atmos_type), intent(inout), target :: Atm(:)
integer, intent(in) :: axes(4)
type(time_type), intent(in) :: Time
+
integer :: n, i, j, nz
+ real, allocatable, dimension(:) :: pfull, phalf
n = 1
ncnsto = Atm(1)%ncnst
@@ -168,6 +172,20 @@ subroutine fv_nggps_diag_init(Atm, axes, Time)
snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat')
graupel = get_tracer_index (MODEL_ATMOS, 'graupel')
+ allocate ( pfull(npzo) )
+ allocate ( phalf(npzo+1) )
+ call get_eta_level(Atm(1)%npz, Atm(1)%flagstruct%p_ref, pfull, phalf, Atm(1)%ak, Atm(1)%bk, 0.01)
+
+ mp_top = 1
+ do i=1,npzo
+ if ( pfull(i) > 30.e2 ) then
+ mp_top = i
+ exit
+ endif
+ enddo
+ deallocate (phalf)
+ deallocate (pfull)
+
!--------------------------------------------------------------
! Register main prognostic fields: ps, (u,v), t, omega (dp/dt)
!--------------------------------------------------------------
@@ -639,9 +657,10 @@ subroutine fv_nggps_diag(Atm, zvir, Time)
!--- 3-D Reflectivity field
if ( rainwat > 0 .and. id_dbz>0) then
- call dbzcalc(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
+ call rad_ref(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
wk, wk2, allmax, Atm(n)%bd, npzo, Atm(n)%ncnst, Atm(n)%flagstruct%hydrostatic, &
- zvir, .false., .false., .false., .true., Atm(n)%flagstruct%do_inline_mp ) ! GFDL MP has constant N_0 intercept
+ zvir, .false., .false., .false., .true., Atm(n)%flagstruct%do_inline_mp, &
+ sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top) ! GFDL MP has constant N_0 intercept
call store_data(id_dbz, wk, Time, kstt_dbz, kend_dbz)
endif
@@ -819,6 +838,75 @@ subroutine fv_nggps_tavg(Atm, Time_step_atmos,avg_max_length,zvir)
endif
endif
end subroutine fv_nggps_tavg
+!
+ subroutine max_vorticity_hy1(is, ie, js, je, km, vort, maxvorthy1)
+ integer, intent(in):: is, ie, js, je, km
+ real, intent(in), dimension(is:ie,js:je,km):: vort
+ real, intent(inout), dimension(is:ie,js:je):: maxvorthy1
+ integer i, j, k
+
+ do j=js,je
+ do i=is,ie
+ maxvorthy1(i,j)=max(maxvorthy1(i,j),vort(i,j,km))
+ enddo ! i-loop
+ enddo ! j-loop
+ end subroutine max_vorticity_hy1
+!
+ subroutine max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostatic, &
+ pt, peln, phis, grav, vort, maxvort, z_bot, z_top)
+ integer, intent(in):: is, ie, js, je, ng, km, sphum
+ real, intent(in):: grav, zvir, z_bot, z_top
+ real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt
+ real, intent(in), dimension(is:ie,js:je,km):: vort
+ real, intent(in):: delz(is:ie,js:je,km)
+ real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
+ real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
+ real, intent(in):: peln(is:ie,km+1,js:je)
+ logical, intent(in):: hydrostatic
+ real, intent(inout), dimension(is:ie,js:je):: maxvort
+
+ real:: rdg
+ real, dimension(is:ie):: zh, dz, zh0
+ integer i, j, k,klevel
+ logical below(is:ie)
+
+ rdg = rdgas / grav
+
+ do j=js,je
+
+ do i=is,ie
+ zh(i) = 0.
+ below(i) = .true.
+ zh0(i) = 0.
+
+ K_LOOP:do k=km,1,-1
+ if ( hydrostatic ) then
+#ifdef MULTI_GASES
+ dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j))
+#else
+ dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
+#endif
+ else
+ dz(i) = - delz(i,j,k)
+ endif
+ zh(i) = zh(i) + dz(i)
+ if (zh(i) <= z_bot ) continue
+ if (zh(i) > z_bot .and. below(i)) then
+ maxvort(i,j) = max(maxvort(i,j),vort(i,j,k))
+ below(i) = .false.
+ elseif ( zh(i) < z_top ) then
+ maxvort(i,j) = max(maxvort(i,j),vort(i,j,k))
+ else
+ maxvort(i,j) = max(maxvort(i,j),vort(i,j,k))
+ EXIT K_LOOP
+ endif
+ enddo K_LOOP
+! maxvorthy1(i,j)=max(maxvorthy1(i,j),vort(i,j,km))
+ enddo ! i-loop
+ enddo ! j-loop
+
+
+ end subroutine max_vorticity
!
subroutine store_data(id, work, Time, nstt, nend)
integer, intent(in) :: id
diff --git a/tools/fv_nudge.F90 b/tools/fv_nudge.F90
index a00d87f0f..15cbe5f4e 100644
--- a/tools/fv_nudge.F90
+++ b/tools/fv_nudge.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
#ifdef OVERLOAD_R4
#define _GET_VAR1 get_var1_real
#else
@@ -227,7 +228,7 @@ module fv_nwp_nudge_mod
contains
- subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, zvir, ptop, &
+ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, zvir, &
ak, bk, ts, ps, delp, ua, va, pt, nwat, q, phis, gridstruct, &
bd, domain )
@@ -236,7 +237,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt
integer, intent(in):: npz ! vertical dimension
integer, intent(in):: nwat
real, intent(in):: dt
- real, intent(in):: zvir, ptop
+ real, intent(in):: zvir
type(domain2d), intent(INOUT), target :: domain
type(fv_grid_bounds_type), intent(IN) :: bd
real, intent(in ), dimension(npz+1):: ak, bk
@@ -434,7 +435,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt
call get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_obs, v_obs, t_obs, q_obs, &
- phis, ua, va, u_dt, v_dt, npx, npy, npz, factor, factor_nwp, mask, ptop, bd, gridstruct, domain)
+ phis, ua, va, u_dt, v_dt, npx, npy, npz, factor, factor_nwp, mask, bd, gridstruct, domain)
! *t_obs* is virtual temperature
if ( no_obs ) then
@@ -1029,10 +1030,10 @@ end subroutine compute_slp
subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_obs, v_obs, t_obs, q_obs, &
- phis, ua, va, u_dt, v_dt, npx, npy, npz, factor, factor_nwp, mask, ptop, bd, gridstruct, domain)
+ phis, ua, va, u_dt, v_dt, npx, npy, npz, factor, factor_nwp, mask, bd, gridstruct, domain)
type(time_type), intent(in):: Time
integer, intent(in):: npz, nwat, npx, npy
- real, intent(in):: zvir, ptop
+ real, intent(in):: zvir
real, intent(in):: dt, factor, factor_nwp
real, intent(in), dimension(npz+1):: ak, bk
type(fv_grid_bounds_type), intent(IN) :: bd
@@ -1160,26 +1161,26 @@ subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_
if ( nudge_winds ) then
call remap_uv(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,1), u_dat(:,:,:,1), v_dat(:,:,:,1), ptop )
+ km, ps_dat(is:ie,js:je,1), u_dat(:,:,:,1), v_dat(:,:,:,1) )
u_obs(:,:,:) = alpha*ut(:,:,:)
v_obs(:,:,:) = alpha*vt(:,:,:)
call remap_uv(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,2), u_dat(:,:,:,2), v_dat(:,:,:,2), ptop )
+ km, ps_dat(is:ie,js:je,2), u_dat(:,:,:,2), v_dat(:,:,:,2) )
u_obs(:,:,:) = u_obs(:,:,:) + beta*ut(:,:,:)
v_obs(:,:,:) = v_obs(:,:,:) + beta*vt(:,:,:)
endif
call remap_tq(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,1), t_dat(:,:,:,1), q_dat(:,:,:,1), zvir, ptop)
+ km, ps_dat(is:ie,js:je,1), t_dat(:,:,:,1), q_dat(:,:,:,1), zvir)
t_obs(:,:,:) = alpha*ut(:,:,:)
q_obs(:,:,:) = alpha*vt(:,:,:)
call remap_tq(npz, ak, bk, ps(is:ie,js:je), delp, ut, vt, &
- km, ps_dat(is:ie,js:je,2), t_dat(:,:,:,2), q_dat(:,:,:,2), zvir, ptop)
+ km, ps_dat(is:ie,js:je,2), t_dat(:,:,:,2), q_dat(:,:,:,2), zvir)
t_obs(:,:,:) = t_obs(:,:,:) + beta*ut(:,:,:)
q_obs(:,:,:) = q_obs(:,:,:) + beta*vt(:,:,:)
@@ -1865,9 +1866,9 @@ end subroutine get_int_hght
subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
- kmd, ps0, ta, qa, zvir, ptop)
+ kmd, ps0, ta, qa, zvir)
integer, intent(in):: npz, kmd
- real, intent(in):: zvir, ptop
+ real, intent(in):: zvir
real, intent(in):: ak(npz+1), bk(npz+1)
real, intent(in), dimension(is:ie,js:je):: ps0
real, intent(inout), dimension(is:ie,js:je):: ps
@@ -1918,7 +1919,7 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
qp(i,k) = qa(i,j,k)
enddo
enddo
- call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_data, ptop)
+ call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_data)
do k=1,npz
do i=is,ie
q(i,j,k) = qn1(i,k)
@@ -1931,7 +1932,7 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
tp(i,k) = ta(i,j,k)
enddo
enddo
- call mappm(kmd, pn0, tp, npz, pn1, qn1, is,ie, 1, kord_data, ptop)
+ call mappm(kmd, pn0, tp, npz, pn1, qn1, is,ie, 1, kord_data)
do k=1,npz
do i=is,ie
@@ -1944,9 +1945,8 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, &
end subroutine remap_tq
- subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, ptop)
+ subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0)
integer, intent(in):: npz
- real, intent(IN):: ptop
real, intent(in):: ak(npz+1), bk(npz+1)
real, intent(inout):: ps(is:ie,js:je)
real, intent(in), dimension(isd:ied,jsd:jed,npz):: delp
@@ -1994,7 +1994,7 @@ subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, ptop)
qt(i,k) = u0(i,j,k)
enddo
enddo
- call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data, ptop)
+ call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data)
do k=1,npz
do i=is,ie
u(i,j,k) = qn1(i,k)
@@ -2008,7 +2008,7 @@ subroutine remap_uv(npz, ak, bk, ps, delp, u, v, kmd, ps0, u0, v0, ptop)
qt(i,k) = v0(i,j,k)
enddo
enddo
- call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data, ptop)
+ call mappm(kmd, pe0, qt, npz, pe1, qn1, is,ie, -1, kord_data)
do k=1,npz
do i=is,ie
v(i,j,k) = qn1(i,k)
diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90
index 73bbd6f4f..a78b65dfc 100644
--- a/tools/fv_restart.F90
+++ b/tools/fv_restart.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_restart_mod
!
@@ -29,38 +30,37 @@ module fv_restart_mod
! for the model.
!
- use constants_mod, only: kappa, pi=>pi_8, omega, rdgas, grav, rvgas, cp_air, radius
+ use constants_mod, only: kappa, pi=>pi_8, rdgas, grav, rvgas, cp_air
+ use fv_arrays_mod, only: radius, omega ! scaled for small earth
use fv_arrays_mod, only: fv_atmos_type, fv_nest_type, fv_grid_bounds_type, R_GRID
use fv_io_mod, only: fv_io_init, fv_io_read_restart, fv_io_write_restart, &
- remap_restart, fv_io_register_nudge_restart, &
- fv_io_register_restart_BCs, fv_io_write_BCs, fv_io_read_BCs
+ remap_restart, fv_io_write_BCs, fv_io_read_BCs
use fv_grid_utils_mod, only: ptop_min, fill_ghost, g_sum, &
make_eta_level, cubed_to_latlon, great_circle_dist
use fv_diagnostics_mod, only: prt_maxmin
use init_hydro_mod, only: p_var
use mpp_domains_mod, only: mpp_update_domains, domain2d, DGRID_NE
+ use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain
+ use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST, mpp_get_C2F_index, WEST, SOUTH
+ use mpp_domains_mod, only: mpp_global_field
use mpp_mod, only: mpp_chksum, stdout, mpp_error, FATAL, NOTE
- use mpp_mod, only: get_unit, mpp_sum, mpp_broadcast, mpp_max, mpp_npes
+ use mpp_mod, only: get_unit, mpp_sum, mpp_broadcast, mpp_max
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_set_current_pelist
+ use mpp_mod, only: mpp_send, mpp_recv, mpp_sync_self, mpp_pe, mpp_sync
+ use fms2_io_mod, only: file_exists, set_filename_appendix, FmsNetcdfFile_t, open_file, close_file
+ use fms_io_mod, only: fmsset_filename_appendix=> set_filename_appendix
use test_cases_mod, only: alpha, init_case, init_double_periodic!, init_latlon
use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max, corners_YDir => YDir, fill_corners, tile_fine, global_nest_domain
use fv_surf_map_mod, only: sgh_g, oro_g
- use tracer_manager_mod, only: get_tracer_names
+ use tracer_manager_mod, only: get_tracer_index, get_tracer_names, set_tracer_profile
use field_manager_mod, only: MODEL_ATMOS
use external_ic_mod, only: get_external_ic
use fv_eta_mod, only: compute_dz_var, compute_dz_L32, set_hybrid_z
use fv_surf_map_mod, only: del2_cubed_sphere, del4_cubed_sphere
use boundary_mod, only: fill_nested_grid, nested_grid_BC, update_coarse_grid
- use tracer_manager_mod, only: get_tracer_index
- use field_manager_mod, only: MODEL_ATMOS
use fv_timing_mod, only: timing_on, timing_off
- use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain
- use mpp_mod, only: mpp_send, mpp_recv, mpp_sync_self, mpp_set_current_pelist, mpp_get_current_pelist, mpp_npes, mpp_pe, mpp_sync
- use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST, mpp_get_C2F_index, WEST, SOUTH
- use mpp_domains_mod, only: mpp_global_field
use fv_treat_da_inc_mod, only: read_da_inc
- use fms2_io_mod, only: file_exists, set_filename_appendix, FmsNetcdfFile_t, open_file, close_file
- use fms_io_mod, only: fmsset_filename_appendix=> set_filename_appendix
+ use fv_regional_mod, only: write_full_fields
use coarse_grained_restart_files_mod, only: fv_io_write_restart_coarse
implicit none
@@ -97,7 +97,8 @@ end subroutine fv_restart_init
! The fv core restart facility
!
!
- subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_type, this_grid)
+ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_type, &
+ this_grid)
type(domain2d), intent(inout) :: fv_domain
type(fv_atmos_type), intent(inout) :: Atm(:)
real, intent(in) :: dt_atmos
@@ -106,7 +107,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
logical, intent(inout) :: cold_start
integer, intent(in) :: grid_type, this_grid
- integer :: i, j, k, n, ntileMe, nt, iq
+ integer :: i, j, k, l, m, n, ntileMe, nt, iq
integer :: isc, iec, jsc, jec, ncnst, ntprog, ntdiag
integer :: isd, ied, jsd, jed, npz
integer isd_p, ied_p, jsd_p, jed_p, isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg,jeg, npx_p, npy_p
@@ -119,12 +120,13 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
character(len=128):: tname, errstring, fname, tracer_name
character(len=120):: fname_ne, fname_sw
character(len=3) :: gn
+ character(len=10) :: inputdir
character(len=6) :: gnn
integer :: npts, sphum
integer, allocatable :: pelist(:), global_pelist(:), smoothed_topo(:)
real :: sumpertn
- real :: zvir
+ real :: zvir, nbg_inv
type(FmsNetcdfFile_t) :: fileobj
logical :: do_read_restart = .false.
@@ -161,7 +163,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
ntprog = size(Atm(n)%q,4)
ntdiag = size(Atm(n)%qdiag,4)
- !1. sort out restart, external_ic, and cold-start (idealized)
+ !1. sort out restart, external_ic, and cold-start (idealized) plus initialize tracers
if (Atm(n)%neststruct%nested) then
write(fname, '(A, I2.2, A)') 'INPUT/fv_core.res.nest', Atm(n)%grid_number, '.nc'
write(fname_ne,'(A, I2.2, A)') 'INPUT/fv_BC_ne.res.nest', Atm(n)%grid_number, '.nc'
@@ -181,6 +183,18 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
if (is_master()) print*, 'FV_RESTART: ', n, do_read_restart, do_read_restart_bc
endif
+ !initialize tracers
+ do nt = 1, ntprog
+ call get_tracer_names(MODEL_ATMOS, nt, tracer_name)
+ ! set all tracers to an initial profile value
+ call set_tracer_profile (MODEL_ATMOS, nt, Atm(n)%q(:,:,:,nt))
+ enddo
+ do nt = ntprog+1, ntprog+ntdiag
+ call get_tracer_names(MODEL_ATMOS, nt, tracer_name)
+ ! set all tracers to an initial profile value
+ call set_tracer_profile (MODEL_ATMOS, nt, Atm(n)%qdiag(:,:,:,nt))
+ enddo
+
!2. Register restarts
!No longer need to register restarts in fv_restart_mod with fms2_io implementation
@@ -249,7 +263,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
call get_external_ic(Atm(n), Atm(n)%domain, .not. do_read_restart)
if( is_master() ) write(*,*) 'IC generated from the specified external source'
- !4. Restart
+ !4. Restart
elseif (do_read_restart) then
if ( Atm(n)%flagstruct%npz_rst /= 0 .and. Atm(n)%flagstruct%npz_rst /= Atm(n)%npz ) then
@@ -273,8 +287,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
j = (Atm(n)%bd%jsc + Atm(n)%bd%jec)/2
k = Atm(n)%npz/2
if( is_master() ) write(*,*) 'Calling read_da_inc',Atm(n)%pt(i,j,k)
- call read_da_inc(Atm(n), Atm(n)%domain, Atm(n)%bd, Atm(n)%npz, Atm(n)%ncnst, &
- Atm(n)%u, Atm(n)%v, Atm(n)%q, Atm(n)%delp, Atm(n)%pt, isd, jsd, ied, jed)
+ call read_da_inc(Atm(n), Atm(n)%domain)
if( is_master() ) write(*,*) 'Back from read_da_inc',Atm(n)%pt(i,j,k)
endif
!====== end PJP added DA functionailty======
@@ -509,7 +522,6 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
ntprog = size(Atm(n)%q,4)
ntdiag = size(Atm(n)%qdiag,4)
-
if (ideal_test_case(n) == 0) then
#ifdef SW_DYNAMICS
Atm(n)%pt(:,:,:)=1.
@@ -691,7 +703,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
!--------------------------------------------
! Initialize surface winds for flux coupler:
!--------------------------------------------
- if ( .not. Atm(n)%flagstruct%srf_init ) then
+ if ( .not. Atm(n)%flagstruct%srf_init ) then
call cubed_to_latlon(Atm(n)%u, Atm(n)%v, Atm(n)%ua, Atm(n)%va, &
Atm(n)%gridstruct, &
Atm(n)%npx, Atm(n)%npy, npz, 1, &
@@ -704,7 +716,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
enddo
enddo
Atm(n)%flagstruct%srf_init = .true.
- endif
+ endif
end do ! n_tile
@@ -1253,10 +1265,10 @@ subroutine fv_write_restart(Atm, timestamp)
if (Atm%coarse_graining%write_coarse_restart_files) then
call fv_io_write_restart_coarse(Atm, timestamp)
if (.not. Atm%coarse_graining%write_only_coarse_intermediate_restarts) then
- call fv_io_write_restart(Atm, timestamp)
+ call fv_io_write_restart(Atm, prefix=timestamp)
endif
else
- call fv_io_write_restart(Atm, timestamp)
+ call fv_io_write_restart(Atm, prefix=timestamp)
endif
if (Atm%neststruct%nested) then
@@ -1346,13 +1358,15 @@ subroutine fv_restart_end(Atm)
! Write4 energy correction term
#endif
+ call fv_io_write_restart(Atm)
if (Atm%coarse_graining%write_coarse_restart_files) then
call fv_io_write_restart_coarse(Atm)
endif
- call fv_io_write_restart(Atm)
if (Atm%neststruct%nested) call fv_io_write_BCs(Atm)
+ if (Atm%flagstruct%write_restart_with_bcs) call write_full_fields(Atm)
+
module_is_initialized = .FALSE.
#ifdef EFLUX_OUT
@@ -1412,4 +1426,5 @@ subroutine pmaxmn_g(qname, q, is, ie, js, je, km, fac, area, domain)
if(is_master()) write(6,*) qname, qmax*fac, qmin*fac, gmean*fac
end subroutine pmaxmn_g
+
end module fv_restart_mod
diff --git a/tools/fv_surf_map.F90 b/tools/fv_surf_map.F90
index 84252bec9..5a634dec5 100644
--- a/tools/fv_surf_map.F90
+++ b/tools/fv_surf_map.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_surf_map_mod
use fms_mod, only: check_nml_error, stdlog, &
@@ -25,7 +26,7 @@ module fv_surf_map_mod
use fms2_io_mod, only: file_exists
use mpp_mod, only: get_unit, input_nml_file, mpp_error
use mpp_domains_mod, only: mpp_update_domains, domain2d
- use constants_mod, only: grav, radius, pi=>pi_8
+ use constants_mod, only: grav, pi=>pi_8
use fv_grid_utils_mod, only: great_circle_dist, latlon2xyz, v_prod, normalize_vect
use fv_grid_utils_mod, only: g_sum, global_mx, vect_cross
diff --git a/tools/fv_timing.F90 b/tools/fv_timing.F90
index 3740a7ab8..6b55b2fdb 100644
--- a/tools/fv_timing.F90
+++ b/tools/fv_timing.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module fv_timing_mod
use mpp_mod, only: mpp_error, FATAL
diff --git a/tools/fv_treat_da_inc.F90 b/tools/fv_treat_da_inc.F90
index 7165b4a84..6e1be2e85 100644
--- a/tools/fv_treat_da_inc.F90
+++ b/tools/fv_treat_da_inc.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -47,8 +47,9 @@ module fv_treat_da_inc_mod
get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
- use constants_mod, only: pi=>pi_8, omega, grav, kappa, &
+ use constants_mod, only: pi=>pi_8, grav, kappa, &
rdgas, rvgas, cp_air
+ use fv_arrays_mod, only: omega ! scaled for small earth
use fv_arrays_mod, only: fv_atmos_type, &
fv_grid_type, &
fv_grid_bounds_type, &
@@ -68,7 +69,8 @@ module fv_treat_da_inc_mod
get_var1_double, &
get_var2_real, &
get_var3_r4, &
- get_var1_real
+ get_var1_real, &
+ check_var_exists
implicit none
private
@@ -82,17 +84,9 @@ module fv_treat_da_inc_mod
!> Do NOT Have delz increment available yet
!> EMC reads in delz increments but does NOT use them!!
- subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in, js_in, ie_in, je_in )
- type(fv_atmos_type), intent(inout) :: Atm
- type(domain2d), intent(inout) :: fv_domain
- type(fv_grid_bounds_type), intent(IN) :: bd
- integer, intent(IN) :: npz_in, nq, is_in, js_in, ie_in, je_in
- real, intent(inout), dimension(is_in:ie_in, js_in:je_in+1,npz_in):: u ! D grid zonal wind (m/s)
- real, intent(inout), dimension(is_in:ie_in+1,js_in:je_in ,npz_in):: v ! D grid meridional wind (m/s)
- real, intent(inout) :: delp(is_in:ie_in ,js_in:je_in ,npz_in) ! pressure thickness (pascal)
- real, intent(inout) :: pt( is_in:ie_in ,js_in:je_in ,npz_in) ! temperature (K)
- real, intent(inout) :: q( is_in:ie_in ,js_in:je_in ,npz_in, nq) !
-
+ subroutine read_da_inc(Atm, fv_domain)
+ type(fv_atmos_type), intent(inout) :: Atm
+ type(domain2d), intent(inout) :: fv_domain
! local
real :: deg2rad
character(len=128) :: fname
@@ -112,17 +106,19 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1)::&
id1_d, id2_d, jdc_d
- integer:: i, j, k, im, jm, km, npt
+ integer:: i, j, k, im, jm, km, npz, npt
integer:: i1, i2, j1, ncid
integer:: jbeg, jend
integer tsize(3)
real(kind=R_GRID), dimension(2):: p1, p2, p3
real(kind=R_GRID), dimension(3):: e1, e2, ex, ey
- logical:: found
+ logical:: found, cliptracers
integer :: is, ie, js, je
integer :: isd, ied, jsd, jed
- integer :: sphum, liq_wat, o3mr
+ integer :: isc, iec, jsc, jec
+ integer :: sphum, liq_wat, o3mr, ice_wat
+ integer :: snowwat, rainwat, graupel
is = Atm%bd%is
ie = Atm%bd%ie
@@ -132,9 +128,18 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
ied = Atm%bd%ied
jsd = Atm%bd%jsd
jed = Atm%bd%jed
+ isc = Atm%bd%isc
+ iec = Atm%bd%iec
+ jsc = Atm%bd%jsc
+ jec = Atm%bd%jec
+
deg2rad = pi/180.
+ npz = Atm%npz
+
+ cliptracers = .true.
+
fname = 'INPUT/'//Atm%flagstruct%res_latlon_dynamics
if( file_exists(fname) ) then
@@ -145,10 +150,10 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
im = tsize(1); jm = tsize(2); km = tsize(3)
- if (km.ne.npz_in) then
+ if (km.ne.npz) then
if (is_master()) print *, 'km = ', km
call mpp_error(FATAL, &
- '==> Error in read_da_inc: km is not equal to npz_in')
+ '==> Error in read_da_inc: km is not equal to npz')
endif
if(is_master()) write(*,*) fname, ' DA increment dimensions:', tsize
@@ -190,16 +195,30 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
sphum = get_tracer_index(MODEL_ATMOS, 'sphum')
o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr')
liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat')
+ ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat')
+ rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat')
+ snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat')
+ graupel = get_tracer_index(MODEL_ATMOS, 'graupel')
+
+ if (is_master()) print *, 'index: sphum,o3mr,ql,qi,qr,qs,qg,nq=', &
+ sphum,o3mr,liq_wat,ice_wat,rainwat,snowwat,graupel,Atm%ncnst
! perform increments on scalars
allocate ( wk3(1:im,jbeg:jend, 1:km) )
allocate ( tp(is:ie,js:je,km) )
- call apply_inc_on_3d_scalar('T_inc',pt, is_in, js_in, ie_in, je_in)
- call apply_inc_on_3d_scalar('delp_inc',delp, is_in, js_in, ie_in, je_in)
- call apply_inc_on_3d_scalar('sphum_inc',q(:,:,:,sphum), is_in, js_in, ie_in, je_in)
- call apply_inc_on_3d_scalar('liq_wat_inc',q(:,:,:,liq_wat), is_in, js_in, ie_in, je_in)
- call apply_inc_on_3d_scalar('o3mr_inc',q(:,:,:,o3mr), is_in, js_in, ie_in, je_in)
+ call apply_inc_on_3d_scalar('T_inc',Atm%pt,isd,jsd,ied,jed)
+ call apply_inc_on_3d_scalar('delp_inc',Atm%delp,isd,jsd,ied,jed)
+ if (.not. Atm%flagstruct%hydrostatic) then
+ call apply_inc_on_3d_scalar('delz_inc',Atm%delz,isc,jsc,iec,jec)
+ endif
+ call apply_inc_on_3d_scalar('sphum_inc',Atm%q(:,:,:,sphum),isd,jsd,ied,jed,cliptracers)
+ call apply_inc_on_3d_scalar('liq_wat_inc',Atm%q(:,:,:,liq_wat),isd,jsd,ied,jed,cliptracers)
+ if(ice_wat > 0) call apply_inc_on_3d_scalar('icmr_inc',Atm%q(:,:,:,ice_wat),isd,jsd,ied,jed,cliptracers)
+ if(rainwat > 0) call apply_inc_on_3d_scalar('rwmr_inc',Atm%q(:,:,:,rainwat),isd,jsd,ied,jed,cliptracers)
+ if(snowwat > 0) call apply_inc_on_3d_scalar('snmr_inc',Atm%q(:,:,:,snowwat),isd,jsd,ied,jed,cliptracers)
+ if(graupel > 0) call apply_inc_on_3d_scalar('grle_inc',Atm%q(:,:,:,graupel),isd,jsd,ied,jed,cliptracers)
+ call apply_inc_on_3d_scalar('o3mr_inc',Atm%q(:,:,:,o3mr),isd,jsd,ied,jed,cliptracers)
deallocate ( tp )
deallocate ( wk3 )
@@ -260,7 +279,7 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
call get_latlon_vector(p3, ex, ey)
vd_inc(i,j,k) = u_inc(i,j,k)*inner_prod(e2,ex) + &
v_inc(i,j,k)*inner_prod(e2,ey)
- v(i,j,k) = v(i,j,k) + vd_inc(i,j,k)
+ Atm%v(i,j,k) = Atm%v(i,j,k) + vd_inc(i,j,k)
enddo
enddo
enddo
@@ -313,7 +332,7 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
call get_latlon_vector(p3, ex, ey)
ud_inc(i,j,k) = u_inc(i,j,k)*inner_prod(e1,ex) + &
v_inc(i,j,k)*inner_prod(e1,ey)
- u(i,j,k) = u(i,j,k) + ud_inc(i,j,k)
+ Atm%u(i,j,k) = Atm%u(i,j,k) + ud_inc(i,j,k)
enddo
enddo
enddo
@@ -335,14 +354,30 @@ subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, is_in,
contains
!---------------------------------------------------------------------------
- subroutine apply_inc_on_3d_scalar(field_name,var, is_in, js_in, ie_in, je_in)
+ subroutine apply_inc_on_3d_scalar(field_name,var,is_in,js_in,ie_in,je_in, &
+ cliptracers)
character(len=*), intent(in) :: field_name
integer, intent(IN) :: is_in, js_in, ie_in, je_in
real, dimension(is_in:ie_in,js_in:je_in,1:km), intent(inout) :: var
+ logical, intent(in), optional :: cliptracers
+ integer :: ierr
+ real :: clip
+
+ if (field_name == 'sphum_inc' .or. field_name == 'o3mr_inc') then
+ clip=tiny(0.0)
+ else
+ clip=0.0
+ endif
if (is_master()) print*, 'Reading increments ', field_name
- call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 )
- if (is_master()) print*,trim(field_name),'before=',var(4,4,30)
+ call check_var_exists(ncid, field_name, ierr)
+ if (ierr == 0) then
+ call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 )
+ else
+ if (is_master()) print *,'warning: no increment for ', &
+ trim(field_name),' found, assuming zero'
+ wk3 = 0.
+ endif
do k=1,km
do j=js,je
@@ -353,10 +388,11 @@ subroutine apply_inc_on_3d_scalar(field_name,var, is_in, js_in, ie_in, je_in)
tp(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+&
s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k)
var(i,j,k) = var(i,j,k)+tp(i,j,k)
+ if (present(cliptracers) .and. cliptracers .and. var(i,j,k) < clip) &
+ var(i,j,k)=clip
enddo
enddo
enddo
- if (is_master()) print*,trim(field_name),'after=',var(4,4,30),tp(4,4,30)
end subroutine apply_inc_on_3d_scalar
!---------------------------------------------------------------------------
diff --git a/tools/init_hydro.F90 b/tools/init_hydro.F90
index ca472c460..765741879 100644
--- a/tools/init_hydro.F90
+++ b/tools/init_hydro.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,7 +18,6 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
-! $Id$
module init_hydro_mod
@@ -34,7 +33,7 @@ module init_hydro_mod
implicit none
private
- public :: p_var, hydro_eq
+ public :: p_var, hydro_eq, hydro_eq_ext
contains
@@ -314,7 +313,7 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, &
z1 = 10.E3 * grav
t1 = 200.
t0 = 300. ! sea-level temp.
- a0 = (t1-t0)/z1
+ a0 = (t1-t0)/z1*0.5
c0 = t0/a0
if ( hybrid_z ) then
@@ -330,7 +329,8 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, &
mslp = 100917.4
do j=js,je
do i=is,ie
- ps(i,j) = mslp*( c0/(hs(i,j)+c0))**(1./(a0*rdgas))
+ !ps(i,j) = mslp*( c0/(hs(i,j)+c0))**(1./(a0*rdgas))
+ ps(i,j) = mslp*exp(-1./(a0*rdgas)*hs(i,j)/(hs(i,j)+c0))
enddo
enddo
psm = g_sum(domain, ps(is:ie,js:je), is, ie, js, je, ng, area, 1, .true.)
@@ -378,7 +378,8 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, &
ph(i,k) = ptop*exp( (gz(i,1)-gz(i,k))/(rdgas*t1) )
else
! Constant lapse rate region (troposphere)
- ph(i,k) = ps(i,j)*((hs(i,j)+c0)/(gz(i,k)+c0))**(1./(a0*rdgas))
+ !ph(i,k) = ps(i,j)*((hs(i,j)+c0)/(gz(i,k)+c0))**(1./(a0*rdgas))
+ ph(i,k) = ps(i,j)*exp(-1./(a0*rdgas)*(gz(i,k)-hs(i,j))/(gz(i,k)-hs(i,j)+c0))
endif
enddo
enddo
@@ -397,7 +398,9 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, &
if (ph(i,k) <= p1) then
gz(i,k) = gz(i,k+1) + (rdgas*t1)*log(ph(i,k+1)/ph(i,k))
else
- gz(i,k) = (hs(i,j)+c0)/(ph(i,k)/ps(i,j))**(a0*rdgas) - c0
+! Constant lapse rate region (troposphere)
+ !gz(i,k) = (hs(i,j)+c0)/(ph(i,k)/ps(i,j))**(a0*rdgas) - c0
+ gz(i,k) = c0/(1+a0*rdgas*log(ph(i,k)/ps(i,j)))+hs(i,j)-c0
endif
enddo
enddo
@@ -439,4 +442,173 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, &
end subroutine hydro_eq
+ ! Added by Linjiong Zhou, bugfix + increase temperature above tropospause
+ subroutine hydro_eq_ext(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, &
+ pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
+! Input:
+ integer, intent(in):: is, ie, js, je, km, ng
+ real, intent(in):: ak(km+1), bk(km+1)
+ real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng)
+ real, intent(in):: drym
+ logical, intent(in):: mountain
+ logical, intent(in):: hydrostatic
+ logical, intent(in):: hybrid_z
+ real(kind=R_GRID), intent(IN) :: area(is-ng:ie+ng,js-ng:je+ng)
+ type(domain2d), intent(IN) :: domain
+! Output
+ real, intent(out):: ps(is-ng:ie+ng,js-ng:je+ng)
+ real, intent(out):: pt(is-ng:ie+ng,js-ng:je+ng,km)
+ real, intent(out):: delp(is-ng:ie+ng,js-ng:je+ng,km)
+ real, intent(inout):: delz(is:,js:,1:)
+! Local
+ real gz(is:ie,km+1)
+ real ph(is:ie,km+1)
+ real mslp, z1, z2, t1, t2, p1, p2, t0, a0, a1, psm
+ real ztop, c0, c1
+#ifdef INIT_4BYTE
+ real(kind=4) :: dps
+#else
+ real dps ! note that different PEs will get differt dps during initialization
+ ! this has no effect after cold start
+#endif
+ real p0, gztop, ptop
+ integer i,j,k
+
+ if ( is_master() ) write(*,*) 'Initializing ATM hydrostatically'
+
+ if ( is_master() ) write(*,*) 'Initializing Earth'
+! Given p1 and z1 (100mb, 15km)
+! Given p2 and z2 (1mb, 45km)
+ p2 = 1.e2
+ p1 = 100.e2
+ z2 = 45.E3 * grav
+ z1 = 15.E3 * grav
+ t2 = 260.
+ t1 = 200.
+ t0 = 300. ! sea-level temp.
+ a0 = (t1-t0)/z1*0.5
+ a1 = (t2-t1)/(z2-z1)*0.5
+ c0 = t0/a0
+ c1 = t1/a1
+
+ if ( hybrid_z ) then
+ ptop = 100. ! *** hardwired model top ***
+ else
+ ptop = ak(1)
+ endif
+
+ ztop = z2 + (rdgas*t2)*log(p2/ptop)
+ if(is_master()) write(*,*) 'ZTOP is computed as', ztop/grav*1.E-3
+
+ if ( mountain ) then
+ mslp = 100917.4
+ do j=js,je
+ do i=is,ie
+ !ps(i,j) = mslp*( c0/(hs(i,j)+c0))**(1./(a0*rdgas))
+ ps(i,j) = mslp*exp(-1./(a0*rdgas)*hs(i,j)/(hs(i,j)+c0))
+ enddo
+ enddo
+ psm = g_sum(domain, ps(is:ie,js:je), is, ie, js, je, ng, area, 1, .true.)
+ dps = drym - psm
+ if(is_master()) write(*,*) 'Computed mean ps=', psm
+ if(is_master()) write(*,*) 'Correction delta-ps=', dps
+ else
+ mslp = drym ! 1000.E2
+ do j=js,je
+ do i=is,ie
+ ps(i,j) = mslp
+ enddo
+ enddo
+ dps = 0.
+ endif
+
+
+ do j=js,je
+ do i=is,ie
+ ps(i,j) = ps(i,j) + dps
+ gz(i, 1) = ztop
+ gz(i,km+1) = hs(i,j)
+ ph(i, 1) = ptop
+ ph(i,km+1) = ps(i,j)
+ enddo
+
+ if ( hybrid_z ) then
+!---------------
+! Hybrid Z
+!---------------
+ do k=km,2,-1
+ do i=is,ie
+ gz(i,k) = gz(i,k+1) - delz(i,j,k)*grav
+ enddo
+ enddo
+! Correct delz at the top:
+ do i=is,ie
+ delz(i,j,1) = (gz(i,2) - ztop) / grav
+ enddo
+
+ do k=2,km
+ do i=is,ie
+ if ( gz(i,k) >= z2 ) then
+! Isothermal
+ ph(i,k) = ptop*exp( (gz(i,1)-gz(i,k))/(rdgas*t2) )
+ else if ( gz(i,k) >= z1 ) then
+! Constant lapse rate region (troposphere)
+ !ph(i,k) = p1*((z1+c1)/(gz(i,k)+c1))**(1./(a1*rdgas))
+ ph(i,k) = p1*exp(-1./(a1*rdgas)*(gz(i,k)-z1)/(gz(i,k)-z1+c1))
+ else
+! Constant lapse rate region (troposphere)
+ !ph(i,k) = ps(i,j)*((hs(i,j)+c0)/(gz(i,k)+c0))**(1./(a0*rdgas))
+ ph(i,k) = ps(i,j)*exp(-1./(a0*rdgas)*(gz(i,k)-hs(i,j))/(gz(i,k)-hs(i,j)+c0))
+ endif
+ enddo
+ enddo
+ else
+!---------------
+! Hybrid sigma-p
+!---------------
+ do k=2,km+1
+ do i=is,ie
+ ph(i,k) = ak(k) + bk(k)*ps(i,j)
+ enddo
+ enddo
+
+ do k=2,km
+ do i=is,ie
+ if ( ph(i,k) <= p2 ) then
+! Isothermal
+ gz(i,k) = ztop + (rdgas*t2)*log(ptop/ph(i,k))
+ else if ( ph(i,k) <= p1 ) then
+! Constant lapse rate region (troposphere)
+ !gz(i,k) = (z1+c1)/(ph(i,k)/p1)**(a1*rdgas) - c1
+ gz(i,k) = c1/(1+a1*rdgas*log(ph(i,k)/p1))+z1-c1
+ else
+! Constant lapse rate region (troposphere)
+ !gz(i,k) = (hs(i,j)+c0)/(ph(i,k)/ps(i,j))**(a0*rdgas) - c0
+ gz(i,k) = c0/(1+a0*rdgas*log(ph(i,k)/ps(i,j)))+hs(i,j)-c0
+ endif
+ enddo
+ enddo
+ if ( .not. hydrostatic ) then
+ do k=1,km
+ do i=is,ie
+ delz(i,j,k) = ( gz(i,k+1) - gz(i,k) ) / grav
+ enddo
+ enddo
+ endif
+ endif ! end hybrid_z
+
+! Convert geopotential to Temperature
+ do k=1,km
+ do i=is,ie
+ pt(i,j,k) = (gz(i,k)-gz(i,k+1))/(rdgas*(log(ph(i,k+1)/ph(i,k))))
+ pt(i,j,k) = max(t1, pt(i,j,k))
+ delp(i,j,k) = ph(i,k+1) - ph(i,k)
+ enddo
+ enddo
+ enddo ! j-loop
+
+
+ end subroutine hydro_eq_ext
+
+
end module init_hydro_mod
diff --git a/tools/rad_ref.F90 b/tools/rad_ref.F90
new file mode 100644
index 000000000..2b79ed0d1
--- /dev/null
+++ b/tools/rad_ref.F90
@@ -0,0 +1,235 @@
+!***********************************************************************
+!* 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 rad_ref_mod
+
+ use constants_mod, only: grav, rdgas, pi => pi_8
+ use fv_arrays_mod, only: fv_grid_bounds_type, r_grid
+ use gfdl_mp_mod, only: do_hail, rhor, rhos, rhog, rhoh, rnzr, rnzs, rnzg, rnzh
+ use gfdl_mp_mod, only: do_hail_inline => do_hail ! assuming same densities and numbers in both inline and traditional gfdl mp
+
+contains
+
+subroutine rad_ref (q, pt, delp, peln, delz, dbz, maxdbz, allmax, bd, &
+ npz, ncnst, hydrostatic, zvir, in0r, in0s, in0g, iliqskin, do_inline_mp, &
+ sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top)
+
+ ! code from mark stoelinga's dbzcalc.f from the rip package.
+ ! currently just using values taken directly from that code, which is
+ ! consistent for the mm5 reisner - 2 microphysics. from that file:
+
+ ! this routine computes equivalent reflectivity factor (in dbz) at
+ ! each model grid point. in calculating ze, the rip algorithm makes
+ ! assumptions consistent with those made in an early version
+ ! (ca. 1996) of the bulk mixed - phase microphysical scheme in the mm5
+ ! model (i.e., the scheme known as "resiner - 2") . for each species:
+ !
+ ! 1. particles are assumed to be spheres of constant density. the
+ ! densities of rain drops, snow particles, and graupel particles are
+ ! taken to be rho_r = rho_l = 1000 kg m^ - 3, rho_s = 100 kg m^ - 3, and
+ ! rho_g = 400 kg m^ - 3, respectively. (l refers to the density of
+ ! liquid water.)
+ !
+ ! 2. the size distribution (in terms of the actual diameter of the
+ ! particles, rather than the melted diameter or the equivalent solid
+ ! ice sphere diameter) is assumed to follow an exponential
+ ! distribution of the form n (d) = n_0 * exp (lambda * d) .
+ !
+ ! 3. if in0x = 0, the intercept parameter is assumed constant (as in
+ ! early reisner - 2), with values of 8x10^6, 2x10^7, and 4x10^6 m^ - 4,
+ ! for rain, snow, and graupel, respectively. various choices of
+ ! in0x are available (or can be added) . currently, in0x = 1 gives the
+ ! variable intercept for each species that is consistent with
+ ! thompson, rasmussen, and manning (2004, monthly weather review,
+ ! vol. 132, no. 2, pp. 519 - 542.)
+ !
+ ! 4. if iliqskin = 1, frozen particles that are at a temperature above
+ ! freezing are assumed to scatter as a liquid particle.
+ !
+ ! more information on the derivation of simulated reflectivity in rip
+ ! can be found in stoelinga (2005, unpublished write - up) . contact
+ ! mark stoelinga (stoeling@atmos.washington.edu) for a copy.
+
+ ! 22sep16: modifying to use the gfdl mp parameters. if doing so remember
+ ! that the gfdl mp assumes a constant intercept (in0x = .false.)
+ ! ferrier - aligo has an option for fixed slope (rather than fixed intercept) .
+ ! thompson presumably is an extension of reisner mp.
+
+ implicit none
+
+ type (fv_grid_bounds_type), intent (in) :: bd
+
+ logical, intent (in) :: hydrostatic, in0r, in0s, in0g, iliqskin, do_inline_mp
+
+ integer, intent (in) :: npz, ncnst, mp_top
+ integer, intent (in) :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel
+
+ real, intent (in), dimension (bd%isd:bd%ied, bd%jsd:bd%jed, npz) :: pt, delp
+ real, intent (in), dimension (bd%is:, bd%js:, 1:) :: delz
+ real, intent (in), dimension (bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst) :: q
+ real, intent (in), dimension (bd%is :bd%ie, npz + 1, bd%js:bd%je) :: peln
+ real, intent (out), dimension (bd%is :bd%ie, bd%js :bd%je, npz) :: dbz
+ real, intent (out), dimension (bd%is :bd%ie, bd%js :bd%je) :: maxdbz
+
+ real, intent (in) :: zvir
+ real, intent (out) :: allmax
+
+ ! parameters for constant intercepts (in0[rsg] = .false.)
+ ! using gfdl mp values
+
+ real (kind = r_grid), parameter :: vconr = 2503.23638966667
+ real (kind = r_grid), parameter :: vcong = 87.2382675
+ real (kind = r_grid), parameter :: vcons = 6.6280504
+ real (kind = r_grid), parameter :: vconh = vcong
+ real (kind = r_grid), parameter :: normr = 25132741228.7183
+ real (kind = r_grid), parameter :: normg = 5026548245.74367
+ real (kind = r_grid), parameter :: normh = pi * rhoh * rnzh
+ real (kind = r_grid), parameter :: norms = 942477796.076938
+
+ ! constants for variable intercepts
+ ! will need to be changed based on mp scheme
+
+ real, parameter :: r1 = 1.e-15
+ real, parameter :: ron = 8.e6
+ real, parameter :: ron2 = 1.e10
+ real, parameter :: son = 2.e7
+ real, parameter :: gon = 5.e7
+ real, parameter :: ron_min = 8.e6
+ real, parameter :: ron_qr0 = 0.00010
+ real, parameter :: ron_delqr0 = 0.25 * ron_qr0
+ real, parameter :: ron_const1r = (ron2 - ron_min) * 0.5
+ real, parameter :: ron_const2r = (ron2 + ron_min) * 0.5
+
+ ! other constants
+
+ real, parameter :: gamma_seven = 720.
+ real, parameter :: alpha = 0.224
+ real (kind = r_grid), parameter :: factor_s = gamma_seven * 1.e18 * (1. / (pi * rhos)) ** 1.75 &
+ * (rhos / rhor) ** 2 * alpha
+ real, parameter :: qmin = 1.e-12
+ real, parameter :: tice = 273.16
+
+ ! double precision
+
+ real (kind = r_grid), dimension (bd%is:bd%ie) :: rhoair, denfac, z_e
+ real (kind = r_grid) :: qr1, qs1, qg1, t1, t2, t3, rwat, vtr, vtg, vts
+ real (kind = r_grid) :: factorb_s, factorb_g
+ real (kind = r_grid) :: temp_c, pres, sonv, gonv, ronv
+
+ real :: rhogh, vcongh, normgh
+
+ integer :: i, j, k
+ integer :: is, ie, js, je
+
+ is = bd%is
+ ie = bd%ie
+ js = bd%js
+ je = bd%je
+
+ if (rainwat < 1) return
+
+ dbz (:, :, 1:mp_top) = - 20.
+ maxdbz (:, :) = - 20. ! minimum value
+ allmax = - 20.
+
+ if ((do_hail .and. .not. do_inline_mp) .or. (do_hail_inline .and. do_inline_mp)) then
+ rhogh = rhoh
+ vcongh = vconh
+ normgh = normh
+ else
+ rhogh = rhog
+ vcongh = vcong
+ normgh = normg
+ endif
+
+ !$omp parallel do default (shared) private (rhoair, t1, t2, t3, denfac, vtr, vtg, vts, z_e)
+ do k = mp_top + 1, npz
+ do j = js, je
+ if (hydrostatic) then
+ do i = is, ie
+ rhoair (i) = delp (i, j, k) / ((peln (i, k + 1, j) - peln (i, k, j)) * &
+ rdgas * pt (i, j, k) * (1. + zvir * q (i, j, k, sphum)))
+ denfac (i) = sqrt (min (10., 1.2 / rhoair (i)))
+ z_e (i) = 0.
+ enddo
+ else
+ do i = is, ie
+ rhoair (i) = - delp (i, j, k) / (grav * delz (i, j, k)) ! moist air density
+ denfac (i) = sqrt (min (10., 1.2 / rhoair (i)))
+ z_e (i) = 0.
+ enddo
+ endif
+ if (rainwat > 0) then
+ do i = is, ie
+ ! the following form vectorizes better & more consistent with gfdl_mp
+ ! sjl notes: marshall - palmer, dbz = 200 * precip ** 1.6, precip = 3.6e6 * t1 / rhor * vtr ! [mm / hr]
+ ! gfdl_mp terminal fall speeds are used
+ ! date modified 20170701
+ ! account for excessively high cloud water - > autoconvert (diag only) excess cloud water
+ t1 = rhoair (i) * max (qmin, q (i, j, k, rainwat) + dim (q (i, j, k, liq_wat), 1.0e-3))
+ vtr = max (1.e-3, vconr * denfac (i) * exp (0.2 * log (t1 / normr)))
+ z_e (i) = 200. * exp (1.6 * log (3.6e6 * t1 / rhor * vtr))
+ ! z_e = 200. * (exp (1.6 * log (3.6e6 * t1 / rhor * vtr)) + &
+ ! exp (1.6 * log (3.6e6 * t3 / rhogh * vtg)) + &
+ ! exp (1.6 * log (3.6e6 * t2 / rhos * vts)))
+ enddo
+ endif
+ if (graupel > 0) then
+ do i = is, ie
+ t3 = rhoair (i) * max (qmin, q (i, j, k, graupel))
+ vtg = max (1.e-3, vcongh * denfac (i) * exp (0.125 * log (t3 / normgh)))
+ z_e (i) = z_e (i) + 200. * exp (1.6 * log (3.6e6 * t3 / rhogh * vtg))
+ enddo
+ endif
+ if (snowwat > 0) then
+ do i = is, ie
+ t2 = rhoair (i) * max (qmin, q (i, j, k, snowwat))
+ ! vts = max (1.e-3, vcons * denfac * exp (0.0625 * log (t2 / norms)))
+ z_e (i) = z_e (i) + (factor_s / alpha) * t2 * exp (0.75 * log (t2 / rnzs))
+ ! z_e = 200. * (exp (1.6 * log (3.6e6 * t1 / rhor * vtr)) + &
+ ! exp (1.6 * log (3.6e6 * t3 / rhogh * vtg)) + &
+ ! exp (1.6 * log (3.6e6 * t2 / rhos * vts)))
+ enddo
+ endif
+ do i = is, ie
+ dbz (i, j, k) = 10. * log10 (max (0.01, z_e (i)))
+ enddo
+ enddo
+ enddo
+
+ !$omp parallel do default (shared)
+ do j = js, je
+ do k = mp_top + 1, npz
+ do i = is, ie
+ maxdbz (i, j) = max (dbz (i, j, k), maxdbz (i, j))
+ enddo
+ enddo
+ enddo
+
+ do j = js, je
+ do i = is, ie
+ allmax = max (maxdbz (i, j), allmax)
+ enddo
+ enddo
+
+end subroutine rad_ref
+
+end module rad_ref_mod
diff --git a/tools/sim_nc_mod.F90 b/tools/sim_nc_mod.F90
index e7f837e9d..18a2951dd 100644
--- a/tools/sim_nc_mod.F90
+++ b/tools/sim_nc_mod.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module sim_nc_mod
! This is S-J Lin's private netcdf file reader
@@ -39,7 +40,8 @@ module sim_nc_mod
private
public open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_double, &
get_var3_real, get_var3_double, get_var3_r4, get_var2_real, get_var2_r4, &
- handle_err, check_var, get_var1_real, get_var_att_double
+ handle_err, check_var, get_var1_real, get_var_att_double, &
+ check_var_exists
contains
@@ -358,6 +360,14 @@ logical function check_var( ncid, var3_name)
end function check_var
+ subroutine check_var_exists(ncid, var_name, status)
+ integer, intent(in):: ncid
+ integer, intent(inout) :: status
+ character(len=*), intent(in):: var_name
+ integer:: varid
+ status = nf_inq_varid (ncid, var_name, varid)
+ end subroutine check_var_exists
+
subroutine get_var_att_str(ncid, var_name, att_name, att)
implicit none
#include
diff --git a/tools/sorted_index.F90 b/tools/sorted_index.F90
index 3ca5f3f91..62f6ebf9b 100644
--- a/tools/sorted_index.F90
+++ b/tools/sorted_index.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -18,6 +18,7 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
module sorted_index_mod
!---------------------------------------------------------------------
!
diff --git a/tools/statistics.F90 b/tools/statistics.F90
new file mode 100644
index 000000000..5099d34cf
--- /dev/null
+++ b/tools/statistics.F90
@@ -0,0 +1,266 @@
+!***********************************************************************
+!* 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 statistics_mod
+
+implicit none
+
+interface mode
+ module procedure mode_1d_real4
+ module procedure mode_2d_real4
+ module procedure masked_mode_2d_real4
+ module procedure mode_1d_real8
+ module procedure mode_2d_real8
+ module procedure masked_mode_2d_real8
+end interface mode
+
+contains
+
+ ! qksrt implementation copied and adapted for real arrays from implementation
+ ! in FMS: FMS/drifters/quicksort.F90
+ function qksrt_partition_real4(n, list, start, end) result(top)
+ implicit none
+ integer, intent(in) :: n
+ real(kind=4), intent(inout) :: list(n)
+ integer, intent(in) :: start, end
+
+ real(kind=4) :: pivot
+ integer :: bottom, top
+ logical :: done
+
+ pivot = list(end) ! Partition around the last value
+ bottom = start-1 ! Start outside the area to be partitioned
+ top = end ! Ditto
+
+ done = .false.
+ do while (.not. done) ! Until all elements are partitioned...
+
+ do while (.not. done) ! Until we find an out of place element...
+ bottom = bottom+1 ! ... move the bottom up.
+
+ if(bottom == top) then ! If we hit the top...
+ done = .true. ! ... we are done.
+ exit
+ endif
+
+ if(list(bottom) > pivot) then ! Is the bottom out of place?
+ list(top) = list(bottom) ! Then put it at the top...
+ exit ! ... and start searching from the top.
+ endif
+ enddo
+
+ do while (.not. done) ! Until we find an out of place element...
+ top = top-1 ! ... move the top down.
+
+ if(top == bottom) then ! If we hit the bottom...
+ done = .true. ! ... we are done.
+ exit
+ endif
+
+ if(list(top) < pivot) then ! Is the top out of place?
+ list(bottom) = list(top) ! Then put it at the bottom...
+ exit ! ...and start searching from the bottom.
+ endif
+ enddo
+ enddo
+
+ list(top) = pivot ! Put the pivot in its place.
+ ! Return the split point
+ end function qksrt_partition_real4
+
+ recursive subroutine qksrt_quicksort_real4(n, list, start, end)
+ implicit none
+ integer, intent(in) :: n
+ real(kind=4), intent(inout) :: list(n)
+ integer, intent(in) :: start, end
+ integer :: split
+
+ if(start < end) then ! If there are two or more elements...
+ split = qksrt_partition_real4(n, list, start, end) ! ... partition the sublist...
+ call qksrt_quicksort_real4(n, list, start, split-1) ! ... and sort both halves.
+ call qksrt_quicksort_real4(n, list, split+1, end)
+ endif
+ end subroutine qksrt_quicksort_real4
+
+ ! This procedure produces the same results as scipy.stats.mode; if there is a
+ ! tie in counts, the minimum mode value is returned.
+ function mode_1d_real4(array)
+ real(kind=4), dimension(:), intent(in) :: array
+
+ real(kind=4) :: mode_1d_real4
+
+ integer :: i, run, max_run
+ real(kind=4), dimension(size(array)) :: sorted_array
+
+ run = 1
+ max_run = 0
+
+ sorted_array = array
+ call qksrt_quicksort_real4(size(sorted_array), sorted_array, 1, size(sorted_array))
+
+ if (size(sorted_array) == 1) then
+ mode_1d_real4 = sorted_array(1)
+ else
+ do i = 2, size(sorted_array)
+ if (sorted_array(i) == sorted_array(i - 1)) then
+ run = run + 1
+ else
+ run = 1
+ endif
+ if (run > max_run) then
+ max_run = run
+ mode_1d_real4 = sorted_array(i - 1)
+ endif
+ enddo
+ endif
+ end function mode_1d_real4
+
+ function mode_2d_real4(array)
+ real(kind=4), dimension(:,:), intent(in) :: array
+
+ real(kind=4) :: mode_2d_real4
+
+ mode_2d_real4 = mode_1d_real4(pack(array, .true.))
+ end function mode_2d_real4
+
+ function masked_mode_2d_real4(array, mask)
+ real(kind=4), dimension(:,:), intent(in) :: array
+ logical, dimension(:,:), intent(in) :: mask
+ real(kind=4) :: masked_mode_2d_real4
+
+ masked_mode_2d_real4 = mode_1d_real4(pack(array, mask))
+ end function masked_mode_2d_real4
+
+ ! qksrt implementation copied and adapted for real arrays from implementation
+ ! in FMS: FMS/drifters/quicksort.F90
+ function qksrt_partition_real8(n, list, start, end) result(top)
+ implicit none
+ integer, intent(in) :: n
+ real(kind=8), intent(inout) :: list(n)
+ integer, intent(in) :: start, end
+
+ real(kind=8) :: pivot
+ integer :: bottom, top
+ logical :: done
+
+ pivot = list(end) ! Partition around the last value
+ bottom = start-1 ! Start outside the area to be partitioned
+ top = end ! Ditto
+
+ done = .false.
+ do while (.not. done) ! Until all elements are partitioned...
+
+ do while (.not. done) ! Until we find an out of place element...
+ bottom = bottom+1 ! ... move the bottom up.
+
+ if(bottom == top) then ! If we hit the top...
+ done = .true. ! ... we are done.
+ exit
+ endif
+
+ if(list(bottom) > pivot) then ! Is the bottom out of place?
+ list(top) = list(bottom) ! Then put it at the top...
+ exit ! ... and start searching from the top.
+ endif
+ enddo
+
+ do while (.not. done) ! Until we find an out of place element...
+ top = top-1 ! ... move the top down.
+
+ if(top == bottom) then ! If we hit the bottom...
+ done = .true. ! ... we are done.
+ exit
+ endif
+
+ if(list(top) < pivot) then ! Is the top out of place?
+ list(bottom) = list(top) ! Then put it at the bottom...
+ exit ! ...and start searching from the bottom.
+ endif
+ enddo
+ enddo
+
+ list(top) = pivot ! Put the pivot in its place.
+ ! Return the split point
+ end function qksrt_partition_real8
+
+ recursive subroutine qksrt_quicksort_real8(n, list, start, end)
+ implicit none
+ integer, intent(in) :: n
+ real(kind=8), intent(inout) :: list(n)
+ integer, intent(in) :: start, end
+ integer :: split
+
+ if(start < end) then ! If there are two or more elements...
+ split = qksrt_partition_real8(n, list, start, end) ! ... partition the sublist...
+ call qksrt_quicksort_real8(n, list, start, split-1) ! ... and sort both halves.
+ call qksrt_quicksort_real8(n, list, split+1, end)
+ endif
+ end subroutine qksrt_quicksort_real8
+
+ ! This procedure produces the same results as scipy.stats.mode; if there is a
+ ! tie in counts, the minimum mode value is returned.
+ function mode_1d_real8(array)
+ real(kind=8), dimension(:), intent(in) :: array
+
+ real(kind=8) :: mode_1d_real8
+
+ integer :: i, run, max_run
+ real(kind=8), dimension(size(array)) :: sorted_array
+
+ run = 1
+ max_run = 0
+
+ sorted_array = array
+ call qksrt_quicksort_real8(size(sorted_array), sorted_array, 1, size(sorted_array))
+
+ if (size(sorted_array) == 1) then
+ mode_1d_real8 = sorted_array(1)
+ else
+ do i = 2, size(sorted_array)
+ if (sorted_array(i) == sorted_array(i - 1)) then
+ run = run + 1
+ else
+ run = 1
+ endif
+ if (run > max_run) then
+ max_run = run
+ mode_1d_real8 = sorted_array(i - 1)
+ endif
+ enddo
+ endif
+ end function mode_1d_real8
+
+ function mode_2d_real8(array)
+ real(kind=8), dimension(:,:), intent(in) :: array
+
+ real(kind=8) :: mode_2d_real8
+
+ mode_2d_real8 = mode_1d_real8(pack(array, .true.))
+ end function mode_2d_real8
+
+ function masked_mode_2d_real8(array, mask)
+ real(kind=8), dimension(:,:), intent(in) :: array
+ logical, dimension(:,:), intent(in) :: mask
+ real(kind=8) :: masked_mode_2d_real8
+
+ masked_mode_2d_real8 = mode_1d_real8(pack(array, mask))
+ end function masked_mode_2d_real8
+end module statistics_mod
diff --git a/tools/test_cases.F90 b/tools/test_cases.F90
index d61d558e1..30b6a7611 100644
--- a/tools/test_cases.F90
+++ b/tools/test_cases.F90
@@ -10,7 +10,7 @@
!* (at your option) any later version.
!*
!* The FV3 dynamical core is distributed in the hope that it will be
-!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
+!* 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.
!*
@@ -21,11 +21,12 @@
module test_cases_mod
- use constants_mod, only: cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas
- use init_hydro_mod, only: p_var, hydro_eq
+ use constants_mod, only: cnst_radius=>radius, pi=>pi_8, cnst_omega=>omega, grav, kappa, rdgas, cp_air, rvgas
+ use fv_arrays_mod, only: radius, omega ! scaled for small earth
+ use init_hydro_mod, only: p_var, hydro_eq, hydro_eq_ext
use fv_mp_mod, only: is_master, &
domain_decomp, fill_corners, XDir, YDir, &
- mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst
+ 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, &
ptop_min, inner_prod, get_latlon_vector, get_unit_vect2, &
g_sum, latlon2xyz, cart_to_latlon, make_eta_level, f_p, project_sphere_v
@@ -35,17 +36,15 @@ module test_cases_mod
use fv_eta_mod, only: compute_dz_L32, compute_dz_L101, set_hybrid_z, gw_1d, &
hybrid_z_dz
- use mpp_mod, only: mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum
+ use mpp_mod, only: mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum, mpp_sync
use mpp_mod, only: stdlog, input_nml_file
use fms_mod, only: check_nml_error
use mpp_domains_mod, only: mpp_update_domains, domain2d
use mpp_parameter_mod, only: AGRID_PARAM=>AGRID,CGRID_NE_PARAM=>CGRID_NE, &
SCALAR_PAIR
use fv_sg_mod, only: qsmith
- use fv_diagnostics_mod, only: prt_maxmin, ppme, eqv_pot, qcly0
-!!! DEBUG CODE
- use mpp_mod, only: mpp_pe, mpp_chksum, stdout
-!!! END DEBUG CODE
+ use fv_diagnostics_mod, only: prt_maxmin, ppme, eqv_pot, qcly0, is_ideal_case
+ use mpp_mod, only: mpp_pe, mpp_chksum, stdout
use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID
use tracer_manager_mod, only: get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
@@ -58,18 +57,19 @@ module test_cases_mod
!!!! virtual temperature effect.
! Test Case Number (cubed-sphere domain)
+! SHALLOW WATER TESTS:
! -1 = Divergence conservation test
! 0 = Idealized non-linear deformational flow
-! 1 = Cosine Bell advection
+! 1 = Cosine Bell advection (not implemented)
! 2 = Zonal geostrophically balanced flow
! 3 = non-rotating potential flow
! 4 = Tropical cyclones (merger of Rankine vortices)
-! 5 = Zonal geostrophically balanced flow over an isolated mountain
+! 5 = Zonal geostrophically balanced flow over an isolated mountain, with or without wind
! 6 = Rossby Wave number 4
! 7 = Barotropic instability
-! ! 8 = Potential flow (as in 5 but no rotation and initially at rest)
! 8 = "Soliton" propagation twin-vortex along equator
-! 9 = Polar vortex
+! 9 = Bates and Li (1997, Atmos.-Ocn.) polar vortex
+! THREE-DIMENSIONAL TESTS
! 10 = hydrostatically balanced 3D test with idealized mountain
! 11 = Use this for cold starting the climate model with USGS terrain
! 12 = Jablonowski & Williamson Baroclinic test case (Steady State)
@@ -92,20 +92,43 @@ module test_cases_mod
! 36 = HIWPP Super_Cell; no perturbation
! 37 = HIWPP Super_Cell; with the prescribed thermal
! 44 = Lock-exchange on the sphere; atm at rest with no mountain
-! 45 = New test
+! 45 = 3D Soliton
! 51 = 3D tracer advection (deformational nondivergent flow)
+! 52 = Resting atmosphere over topography
! 55 = TC
! -55 = DCMIP 2016 TC test
! 101 = 3D non-hydrostatic Large-Eddy-Simulation (LES) with hybrid_z IC
+!! Doubly-periodic tests (THREE-DIMENSIONAL)
+! 1 = Pure advection (not implemented)
+! 2 = Resting flow over a 1.5 km mountain
+! 14 = Aqua-plane with hydro_eq sounding and optional warm bubble
+! (sfc = 300 K, 200 K 250 mb tropopause)
+! 15 = Warm bubble in isothermal atmosphere
+! 16 = Cold bubble in isothermal atmosphere
+! 17 = Symmetric Supercell
+! 18 = Asymmetric supercell with M. Toy quarter-circle hodograph
+! 19 = LJZ update to 17 with Cetrone-Houze marine sounding
+! and several bubble and sounding options
+! 101 = LES with isothermal atmosphere (not implemented)
+
+
+
+
integer :: sphum, theta_d
- real(kind=R_GRID), parameter :: radius = cnst_radius
real(kind=R_GRID), parameter :: one = 1.d0
integer :: test_case = 11
logical :: bubble_do = .false.
+ logical :: no_wind = .false.
+ logical :: gaussian_dt = .false.
+ logical :: do_marine_sounding = .false.
+ real :: dt_amp = 2.1
real :: alpha = 0.0
- integer :: Nsolitons = 1
+ integer :: Nsolitons = 2
real :: soliton_size = 750.e3, soliton_Umax = 50.
+ logical :: checker_tr
+ real :: small_earth_scale = 1.0
+ real :: umean = 0.0
! Case 0 parameters
real :: p0_c0 = 3.0
@@ -154,11 +177,12 @@ module test_cases_mod
integer, parameter :: interpOrder = 1
public :: pz0, zz0
- public :: read_namelist_test_case_nml, alpha
+ public :: read_namelist_test_case_nml, alpha, test_case
public :: init_case
public :: case9_forcing1, case9_forcing2, case51_forcing
public :: init_double_periodic
public :: checker_tracers
+ public :: radius, omega, small_earth_scale
INTERFACE mp_update_dwinds
MODULE PROCEDURE mp_update_dwinds_2d
@@ -536,6 +560,9 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
real :: tmp1(1 :npx ,1 :npy ,1:nregions)
real(kind=R_GRID) :: p0(2) ! Temporary Point
+ real(kind=R_GRID) :: p0e(2) ! Temporary Point
+ real(kind=R_GRID) :: p0w(2) ! Temporary Point
+
real(kind=R_GRID) :: p1(2) ! Temporary Point
real(kind=R_GRID) :: p2(2) ! Temporary Point
real(kind=R_GRID) :: p3(2) ! Temporary Point
@@ -754,7 +781,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
enddo
enddo
- call init_winds(UBar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile)
+ call init_winds(UBar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile,bd)
! Test Divergence operator at cell centers
do j=js,je
@@ -776,8 +803,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
! call mpp_update_domains( vor0, domain )
! call mpp_update_domains( divg, domain )
! call mpp_update_domains( vort, domain )
- call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
- pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
200 format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
201 format(' ',A,e21.14,' ',e21.14)
202 format(' ',A,i4.4,'x',i4.4,'x',i4.4)
@@ -809,8 +834,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
ua0 = ua
va0 = va
div0(:,:) = 1.e-20
- call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
- pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
if ( is_master() ) then
write(*,*) ' Error Norms of Analytical Divergence field A-Winds initialized'
write(*,201) 'Divergence MAX error : ', pmax
@@ -839,8 +862,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
enddo
div0(:,:) = 1.e-20
- call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
- pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
if ( is_master() ) then
write(*,*) ' Error Norms of Analytical Divergence field D-Winds initialized'
write(*,201) 'Divergence MAX error : ', pmax
@@ -906,7 +927,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
initWindsCase=initWindsCase1
case(2)
-#ifdef TEST_TRACER
gh0 = 1.0e-6
r0 = radius/3. !RADIUS radius/3.
p1(2) = 35./180.*pi !0.
@@ -917,14 +937,13 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
p2(2) = agrid(i,j,2)
r = great_circle_dist( p1, p2, radius )
if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.)) then
- !q(i,j,k,1) = max(gh0*0.5*(1.0+cos(PI*r/r0))*exp(real(k-npz)),0.)
q(i,j,1,1) = gh0
else
q(i,j,1,1) = 0.
endif
enddo
enddo
-#endif
+
Ubar = (2.0*pi*radius)/(12.0*86400.0)
gh0 = 2.94e4
phis = 0.0
@@ -953,7 +972,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
delp(i,j,1) = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
-#endif
+#endif FIVE_AVG
enddo
enddo
initWindsCase=initWindsCase2
@@ -961,11 +980,11 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
!----------------------------
! Non-rotating potential flow
!----------------------------
-#ifdef NO_WIND
- ubar = 0.
-#else
- ubar = 40.
-#endif
+ if (no_wind) then
+ ubar = 0.
+ else
+ ubar = 40.
+ endif
gh0 = 1.0e3 * grav
phis = 0.0
r0 = radius/3. !RADIUS radius/3.
@@ -986,12 +1005,12 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
enddo
-#ifdef NO_WIND
- u = 0.; v = 0.
- f0 = 0.; fC = 0.
-#else
+ if (no_wind) then
+ u = 0.; v = 0.
+ f0 = 0.; fC = 0.
+ else
- do j=js,je
+ do j=js,je
do i=is,ie+1
p1(:) = grid(i ,j ,1:2)
p2(:) = grid(i,j+1 ,1:2)
@@ -1002,8 +1021,8 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
vtmp = 0.
v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
enddo
- enddo
- do j=js,je+1
+ enddo
+ do j=js,je+1
do i=is,ie
p1(:) = grid(i, j,1:2)
p2(:) = grid(i+1,j,1:2)
@@ -1014,20 +1033,22 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
vtmp = 0.
u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
enddo
- enddo
+ enddo
- anti_rot = -ubar/ radius
- do j=jsd,jed+1
+ anti_rot = -ubar/ radius
+ do j=jsd,jed+1
do i=isd,ied+1
fC(i,j) = 2.*anti_rot*sin(grid(i,j,2))
enddo
- enddo
- do j=jsd,jed
+ enddo
+ do j=jsd,jed
do i=isd,ied
f0(i,j) = 2.*anti_rot*sin(agrid(i,j,2))
enddo
- enddo
-#endif
+ enddo
+
+ endif !no_wind
+
initWindsCase= -1
case(4)
@@ -1061,7 +1082,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
p2(2) = pi/18. ! 10 N
call rankine_vortex(ubar, r0, p2, u, v, grid, bd)
-#ifndef SINGULAR_VORTEX
!-----------
! Anti-pole:
!-----------
@@ -1079,7 +1099,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
call cart_to_latlon(1, e1, p4(1), p4(2))
call rankine_vortex(ubar, r0, p4, u, v, grid, bd)
-#endif
+
call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
initWindsCase=-1 ! do nothing
@@ -1100,14 +1120,29 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
phis(i,j) = 2000.0*Grav*(1.0-(r/r0))
enddo
enddo
- do j=js2,je2
+ if (no_wind) then
+ do j=js,je
+ do i=is,ie
+ delp(i,j,1) = gh0
+ enddo
+ enddo
+ u = 0.; v = 0.
+ f0 = 0.; fC = 0.
+ initWindsCase= -1
+
+ else
+ do j=js2,je2
do i=is2,ie2
delp(i,j,1) =gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
sin(agrid(i ,j ,2))*cos(alpha) ) ** 2 - phis(i,j)
enddo
- enddo
- initWindsCase=initWindsCase5
+ enddo
+
+ initWindsCase=initWindsCase5
+ endif
+
+
case(6)
gh0 = 8.E3*Grav
R = 4.
@@ -1159,6 +1194,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
!call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
initWindsCase=initWindsCase6
+
case(7)
! Barotropically unstable jet
gh0 = 10.E3*Grav
@@ -1189,13 +1225,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
pt8 = gh_jet(npy, grid(i+1,j+1,2))
pt9 = gh_jet(npy, grid(i ,j+1,2))
ftmp = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
-#ifndef NEW_PERT
- delp(i,j,1) = ftmp + 120.*grav*cos(agrid(i,j,2)) * &
- exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
-! phis(i,j) = ftmp
-! delp(i,j,1) = 10.E3*grav + 120.*grav*cos(agrid(i,j,2)) * &
-! exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
-#else
! Using great circle dist:
p1(:) = agrid(i,j,1:2)
delp(i,j,1) = ftmp
@@ -1203,7 +1232,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
if ( r < 3.*r0 ) then
delp(i,j,1) = delp(i,j,1) + 1000.*grav*exp(-(r/r0)**2)
endif
-#endif
enddo
enddo
@@ -1219,7 +1247,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
vv2 = u_jet(pa(2))*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
! 3-point average:
v(i,j,1) = 0.25*(vv1 + 2.*vv2 + vv3)
-! v(i,j,1) = vv2
enddo
enddo
! U-wind:
@@ -1234,7 +1261,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
uu2 = u_jet(pa(2))*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
! 3-point average:
u(i,j,1) = 0.25*(uu1 + 2.*uu2 + uu3)
-! u(i,j,1) = uu2
enddo
enddo
initWindsCase=initWindsCase6 ! shouldn't do anything with this
@@ -1258,39 +1284,10 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
do j=js,je
do i=is,ie
q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) / delp(i,j,npz) * 1.e6 ! PVU
- !q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) * grav / delp(i,j,npz)
enddo
enddo
-! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
case(8)
-#ifdef USE_OLD
-!----------------------------
-! Non-rotating potential flow
-!----------------------------
- gh0 = 5960.*Grav
- phis = 0.0
- r0 = PI/9.
- p1(1) = PI/2.
- p1(2) = PI/6.
- do j=js,je
- do i=is,ie
- p2(1) = agrid(i,j,1)
- p2(2) = agrid(i,j,2)
- r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
- r = SQRT(r)
- phis(i,j) = 2000.0*Grav*(1.0-(r/r0))
- enddo
- enddo
- do j=js,je
- do i=is,ie
- delp(i,j,1) = gh0
- enddo
- enddo
- u = 0.; v = 0.
- f0 = 0.; fC = 0.
- initWindsCase= -1
-#endif
!----------------------------
! Soliton twin-vortex
!----------------------------
@@ -1307,6 +1304,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
! Initiate the westerly-wind-burst:
ubar = soliton_Umax
r0 = soliton_size
+
! #1 1: westerly
p0(1) = pi*0.5
p0(2) = 0.
@@ -1336,7 +1334,8 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
enddo
-! #1 2: easterly
+ ! #2: easterly
+ if (nsolitons > 0) then
p0(1) = p0(1) + pi
p0(2) = 0.
@@ -1364,10 +1363,12 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
u(i,j,1) = u(i,j,1) - utmp*inner_prod(e1,ex)
enddo
enddo
+ endif
initWindsCase= -1
+
case(9)
-#ifdef USE_OLD
+
jm1 = jm - 1
DDP = PI/DBLE(jm1)
DP = DDP
@@ -1439,56 +1440,21 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
initWindsCase=initWindsCase9
-
+ allocate(case9_B(isd:ied,jsd:jed))
call get_case9_B(case9_B, agrid, isd, ied, jsd, jed)
AofT(:) = 0.0
-#else
-!----------------------------
-! Soliton twin-vortex
-!----------------------------
- if ( is_master() ) write(*,*) 'Initialzing case-9: soliton cyclones...'
- f0 = 0.; fC = 0. ! non-rotating planet setup
- phis = 0.0 ! flat terrain
- gh0 = 5.E3*Grav
- do j=js,je
- do i=is,ie
- delp(i,j,1) = gh0
- enddo
- enddo
-
-! Initiate the westerly-wind-burst:
- ubar = soliton_Umax
- r0 = soliton_size
- p0(1) = pi*0.5
- p0(2) = 0.
- do j=js,je
- do i=is,ie+1
- p1(:) = grid(i ,j ,1:2)
- p2(:) = grid(i,j+1 ,1:2)
- call mid_pt_sphere(p1, p2, p3)
- r = great_circle_dist( p0, p3, radius )
- utmp = ubar*exp(-(r/r0)**2)
- call get_unit_vect2(p1, p2, e2)
- call get_latlon_vector(p3, ex, ey)
- v(i,j,1) = utmp*inner_prod(e2,ex)
- enddo
- enddo
- do j=js,je+1
- do i=is,ie
- p1(:) = grid(i, j,1:2)
- p2(:) = grid(i+1,j,1:2)
- call mid_pt_sphere(p1, p2, p3)
- r = great_circle_dist( p0, p3, radius )
- utmp = ubar*exp(-(r/r0)**2)
- call get_unit_vect2(p1, p2, e1)
- call get_latlon_vector(p3, ex, ey)
- u(i,j,1) = utmp*inner_prod(e1,ex)
- enddo
- enddo
- initWindsCase= -1
-#endif
end select
+
+
+ cl = get_tracer_index(MODEL_ATMOS, 'cl')
+ cl2 = get_tracer_index(MODEL_ATMOS, 'cl2')
+ if (cl > 0 .and. cl2 > 0) then
+ call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
+ q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2),bd)
+ call mpp_update_domains(q,domain)
+ endif
+
!--------------- end s-w cases --------------------------
! Copy 3D data for Shallow Water Tests
@@ -1591,53 +1557,14 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
else if ( (test_case==12) .or. (test_case==13) ) then
-#ifdef HIWPP_TRACER
- if (is_master()) print*, 'TEST TRACER enabled for this test case'
-#ifdef HIWPP
- call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
- ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
-#else
- !For consistency with earlier single-grid simulations use gh0 = 1.0e-6 and p1(1) = 195.*pi/180.
- q(:,:,:,:) = 0.
- gh0 = 1.0e-3
- r0 = radius/3. !RADIUS radius/3.
- p1(2) = 51.*pi/180.
- p1(1) = 205.*pi/180. !231.*pi/180.
- do k=1,npz
- do j=jsd,jed
- do i=isd,ied
- p2(1) = agrid(i,j,1)
- p2(2) = agrid(i,j,2)
- r = great_circle_dist( p1, p2, radius )
- if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.) .and. k > 16) then
- q(i,j,k,1) = gh0
- else
- q(i,j,k,1) = 0.
- endif
- enddo
- enddo
- enddo
-#endif
-
-#else
+ !For consistency with earlier single-grid simulations use gh0 = 1.0e-6 and p1(1) = 195.*pi/180.
q(:,:,:,:) = 0.
-#ifdef HIWPP
-
- cl = get_tracer_index(MODEL_ATMOS, 'cl')
- cl2 = get_tracer_index(MODEL_ATMOS, 'cl2')
- if (cl > 0 .and. cl2 > 0) then
- call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
- q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2),bd)
- call mpp_update_domains(q,domain)
- endif
-#endif
-#endif
! Initialize surface Pressure
ps(:,:) = 1.e5
- ! Initialize detla-P
+ ! Initialize delta-P
!$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,ak,ps,bk)
do z=1,npz
do j=js,je
@@ -1690,13 +1617,8 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
do k=1,npz
do j=js,je
do i=is,ie
- !r = great_circle_dist(pcen, agrid(i,j,:), radius)
- !ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j)) - 100000.
- !q(i,j,k,1) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - 100000.
q(i,j,k,sphum) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
-! SJL:
-! q(i,j,k,sphum) = max(1.e-25, q(i,j,k,sphum))
enddo
enddo
enddo
@@ -1708,17 +1630,12 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
pcen(1) = PI/9.
pcen(2) = 2.0*PI/9.
if (test_case == 13) then
-#ifdef ALT_PERT
- u1 = 0.0
- pt0 = 3.0
-#else
u1 = 1.0
pt0 = 0.0
-#endif
r0 = radius/10.0
endif
-!$OMP parallel do default(none) shared(is,ie,js,je,npz,eta_v,grid,Ubar,pcen,r0,ee2,v,ee1,es,u,u1,ew) &
+!$OMP parallel do default(none) shared(is,ie,js,je,npz,eta_v,grid,Ubar,pcen,r0,ee2,v,ee1,es,u,u1,ew,radius) &
!$OMP private(utmp,r,vv1,vv3,p1,p2,vv2,uu1,uu2,uu3,pa)
do z=1,npz
do j=js,je
@@ -1782,7 +1699,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
delta_T = 480000.0
lapse_rate = 0.005
!$OMP parallel do default(none) shared(is,ie,js,je,npz,eta,ak,bk,T_0,lapse_rate,eta_t, &
-!$OMP delta_T,ptop,delp,Ubar,eta_v,agrid,grid,pcen,pt,r0) &
+!$OMP delta_T,ptop,delp,Ubar,eta_v,agrid,grid,pcen,pt,r0,radius,omega) &
!$OMP private(T_mean,press,pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1,r)
do z=1,npz
eta(z) = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
@@ -1854,20 +1771,13 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
pt(i,j,z) = pt1
#endif
-#ifdef ALT_PERT
- r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
- if ( (r/r0)**2 < 40. ) then
- pt(i,j,z) = pt(i,j,z) + pt0*exp(-(r/r0)**2)
- endif
-#endif
-
enddo
enddo
enddo
if (is_master()) print*,' '
! Surface Geopotential
phis(:,:)=1.e25
-!$OMP parallel do default(none) shared(is2,ie2,js2,je2,Ubar,eta_s,eta_0,agrid,grid,phis) &
+!$OMP parallel do default(none) shared(is2,ie2,js2,je2,Ubar,eta_s,eta_0,agrid,grid,phis,radius,omega) &
!$OMP private(pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1)
do j=js2,je2
do i=is2,ie2
@@ -2044,23 +1954,14 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
p1(2) = 0.
do k=1,npz
-#ifndef STD_BUBBLE
r0 = 0.5*(ze1(k)+ze1(k+1)) - 3.2E3
-#else
- r0 = (0.5*(ze1(k)+ze1(k+1)) - 3.0E3) / 2.E3
-#endif
do j=js,je
do i=is,ie
! Impose perturbation in potential temperature: pturb
p2(1) = agrid(i,j,1)
p2(2) = agrid(i,j,2)
-#ifndef STD_BUBBLE
r = great_circle_dist( p1, p2, radius )
dist = sqrt( r**2 + r0**2 ) / 3.2E3
-#else
- r = great_circle_dist( p1, p2, radius ) / 4.E3
- dist = sqrt( r**2 + r0**2 )
-#endif
if ( dist<=1. ) then
q(i,j,k,1) = pk0 * pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
@@ -2601,6 +2502,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
u = 0.
v = 0.
+ q = 0.
p00 = 1.e5
wind_field = tracer_test
@@ -2670,8 +2572,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
! 0.5*(ak(k)+ak(k+1)), 0.5*(bk(k)+bk(k+1)), dum3, dum4, dum5, &
! pt(i,j,k), phis(i,j), ps(i,j), dum6, q(i,j,k,1))
delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
- !Analytic point-value
- !ANalytic layer-mean
+ !Analytic layer-mean
pt(i,j,k) = -grav*t00*p00/(rdgas*gamma + grav)/delp(i,j,k) * &
( (pe(i,k,j)/p00)**(exponent+1.) - (pe(i,k+1,j)/p00)**(exponent+1.) )
@@ -3324,8 +3225,11 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
! Initiate the westerly-wind-burst:
ubar = soliton_Umax
r0 = soliton_size
- p0(1) = pi*0.5
- p0(2) = 0.
+ p0w(1) = pi*0.5
+ p0w(2) = 0.
+ p0e(1) = p0w(1) + pi
+ p0e(2) = 0.
+
do k=1,npz
do j=js,je
@@ -3333,7 +3237,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
p1(:) = grid(i ,j ,1:2)
p2(:) = grid(i,j+1 ,1:2)
call mid_pt_sphere(p1, p2, p3)
- r = great_circle_dist( p0, p3, radius )
+ r = great_circle_dist( p0w, p3, radius )
utmp = ubar*exp(-(r/r0)**2)
call get_unit_vect2(p1, p2, e2)
call get_latlon_vector(p3, ex, ey)
@@ -3345,7 +3249,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
p1(:) = grid(i, j,1:2)
p2(:) = grid(i+1,j,1:2)
call mid_pt_sphere(p1, p2, p3)
- r = great_circle_dist( p0, p3, radius )
+ r = great_circle_dist( p0w, p3, radius )
utmp = ubar*exp(-(r/r0)**2)
call get_unit_vect2(p1, p2, e1)
call get_latlon_vector(p3, ex, ey)
@@ -3353,9 +3257,41 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
enddo
+! Add easterly-wind-brust:
+ if (nsolitons > 0) then
+ p0(1) = p0(1) + pi
+ p0(2) = 0.
+
+ do j=js,je
+ do i=is,ie+1
+ p1(:) = grid(i ,j ,1:2)
+ p2(:) = grid(i,j+1 ,1:2)
+ call mid_pt_sphere(p1, p2, p3)
+ r = great_circle_dist( p0e, p3, radius )
+ utmp = ubar*exp(-(r/r0)**2)
+ call get_unit_vect2(p1, p2, e2)
+ call get_latlon_vector(p3, ex, ey)
+ v(i,j,k) = v(i,j,k) - utmp*inner_prod(e2,ex)
+ enddo
+ enddo
+ do j=js,je+1
+ do i=is,ie
+ p1(:) = grid(i, j,1:2)
+ p2(:) = grid(i+1,j,1:2)
+ call mid_pt_sphere(p1, p2, p3)
+ r = great_circle_dist( p0e, p3, radius )
+ utmp = ubar*exp(-(r/r0)**2)
+ call get_unit_vect2(p1, p2, e1)
+ call get_latlon_vector(p3, ex, ey)
+ u(i,j,k) = u(i,j,k) - utmp*inner_prod(e1,ex)
+ enddo
+ enddo
+ endif !nsolitons > 0
+
do j=js,je
do i=is,ie
pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
+
#ifdef USE_PT
pt(i,j,k) = pt0/p00**kappa
! Convert back to temperature:
@@ -3378,8 +3314,8 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
enddo
enddo
#else
- call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
- ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
+! call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
+! ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
#endif
if ( .not. hydrostatic ) then
@@ -3663,31 +3599,27 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak,
moist_phys, hydrostatic, nwat, domain, adiabatic, .not.hydrostatic)
#endif
-#ifdef COLUMN_TRACER
- if( ncnst>1 ) q(:,:,:,2:ncnst) = 0.0
- ! Initialize a dummy Column Tracer
- pcen(1) = PI/9.
- pcen(2) = 2.0*PI/9.
- r0 = radius/10.0
- do z=1,npz
- do j=js,je
- do i=is,ie
- p1(:) = grid(i ,j ,1:2)
- p2(:) = grid(i,j+1 ,1:2)
- call mid_pt_sphere(p1, p2, pa)
- call get_unit_vect2(p1, p2, e2)
- call get_latlon_vector(pa, ex, ey)
- ! Perturbation Location Case==13
- r = great_circle_dist( pcen, pa, radius )
- if (-(r/r0)**2.0 > -40.0) q(i,j,z,1) = EXP(-(r/r0)**2.0)
- enddo
- enddo
- enddo
-#endif
+ !Initialize tracers
+
+ if (checker_tr) then
+ if (is_master()) print*, 'TEST TRACER enabled for this test case'
+ call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
+ ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
+ endif
+
+ cl = get_tracer_index(MODEL_ATMOS, 'cl')
+ cl2 = get_tracer_index(MODEL_ATMOS, 'cl2')
+ if (cl > 0 .and. cl2 > 0) then
+ call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
+ q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2),bd)
+ call mpp_update_domains(q,domain)
+ endif
+
+#endif SW_DYNAMICS
-#endif
call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
+ is_ideal_case = .true.
nullify(agrid)
nullify(grid)
@@ -4556,11 +4488,16 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
real, dimension(1:npz):: pk1, ts1, qs1
real :: us0 = 30.
real :: dist, r0, f0_const, prf, rgrav
- real :: ptmp, ze, zc, zm, utmp, vtmp
+ real :: ptmp, ze, zc, zm, utmp, vtmp, xr, yr
real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop
real :: ze1(npz+1)
- real:: dz1(npz)
+ real:: dz1(npz)
+ real :: gz(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1)
real:: zvir
+ real :: sigma, mu, amp, zint, zmid, qsum, pint, pmid
+ real :: N2, N2b, th0, ths, pks, rkap, ampb, thl
+ real :: dz, thp, pp, zt, p_t, pkp
+ integer :: o3mr
integer :: i, j, k, m, icenter, jcenter
real, pointer, dimension(:,:,:) :: agrid, grid
@@ -4708,7 +4645,8 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
do k=1,npz
prf = ak(k) + ps(i,j)*bk(k)
if ( prf > 100.E2 ) then
- pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j)
+ pt(i,j,k) = pt(i,j,k) + 2.0*(1. - (dist/r0)) * prf/ps(i,j)
+! pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j)
endif
enddo
enddo
@@ -4738,6 +4676,35 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
enddo
enddo
+#ifdef O3_IC
+ !--------------------------------------------------------------
+ ! *** Add o3 distribution *** Linjiong Zhou
+ ! normal distribution based on pressure
+ o3mr = get_tracer_index (MODEL_ATMOS, 'o3mr')
+ if (o3mr > 0) then
+ sigma = 19.0
+ mu = 1.e3
+ amp = 0.00023
+ do j=js,je
+ do i=is,ie
+ pint = ptop
+ qsum = 0.0
+ do k=1,npz
+ pmid = pint + 0.5 * delp(i,j,k)
+ pint = pint + delp(i,j,k)
+ q(i,j,k,o3mr) = 1.0 / (sigma * sqrt(2.0 * pi)) * &
+ exp(- (pmid ** 0.5 - mu ** 0.5) ** 2.0 / (2.0 * sigma ** 2.0))
+ qsum = qsum + q(i,j,k,o3mr)
+ enddo
+ do k=npz,1,-1
+ q(i,j,k,o3mr) = amp * q(i,j,k,o3mr) / qsum
+ enddo
+ enddo
+ enddo
+ endif
+ !--------------------------------------------------------------
+#endif
+
case ( 15 )
!---------------------------
! Doubly periodic bubble
@@ -4767,18 +4734,10 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
enddo
- do k=1,npz
- do j=jsd,jed
- do i=isd,ied
- ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
-! pt(i,j,k) = t00
- 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)
+ moist_phys, .false., nwat, domain, flagstruct%adiabatic, .true.)
! *** Add Initial perturbation ***
r0 = 5.*max(dx_const, dy_const)
@@ -4796,7 +4755,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
(zm-zc)**2
dist = sqrt(dist)
if ( dist <= r0 ) then
- pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
+ pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
endif
enddo
enddo
@@ -4847,7 +4806,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
do j=js,je
do i=is,ie
peln(i,k,j) = log(pe(i,k,j))
- ze0(i,j,k) = ze1(k)
+ !ze0(i,j,k) = ze1(k) !not used?
enddo
enddo
enddo
@@ -4927,11 +4886,17 @@ 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)
@@ -4939,7 +4904,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)
+ utmp = us0*tanh(zm/3.E3) - us0*0.5 ! subtract off mean wind
do j=js,je+1
do i=is,ie
u(i,j,k) = utmp
@@ -4952,25 +4917,23 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
.true., hydrostatic, nwat, domain, flagstruct%adiabatic)
! *** Add Initial perturbation ***
- pturb = 2.
- r0 = 10.e3
- zc = 1.4e3 ! center of bubble from surface
- icenter = (npx-1)/3 + 1
- jcenter = (npy-1)/2 + 1
- do k=1, npz
- zm = 0.5*(ze1(k)+ze1(k+1))
- ptmp = ( (zm-zc)/zc ) **2
- if ( ptmp < 1. ) then
+ if (bubble_do) then
+ pturb = 2.
+ r0 = 10.e3
+ zc = 1.4e3 ! center of bubble from surface
+ icenter = (npx-1)/3 + 1
+ jcenter = (npy-1)/2 + 1
+ do k=1, npz
+ zm = 0.5*(ze1(k)+ze1(k+1))
+ ptmp = ( (zm-zc)/zc ) **2
do j=js,je
do i=is,ie
- dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
- if ( dist < 1. ) then
- pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
- endif
+ dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
+ pt(i,j,k) = pt(i,j,k) + pturb*max(1.-sqrt(dist),0.)
enddo
enddo
- endif
- enddo
+ enddo
+ endif
case ( 18 )
!---------------------------
@@ -5061,27 +5024,411 @@ 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
- r0 = 10.e3
- zc = 1.4e3 ! center of bubble from surface
- icenter = (npx-1)/2 + 1
- jcenter = (npy-1)/2 + 1
- do k=1, npz
- zm = 0.5*(ze1(k)+ze1(k+1))
- ptmp = ( (zm-zc)/zc ) **2
- if ( ptmp < 1. ) then
- do j=js,je
- do i=is,ie
- dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
- if ( dist < 1. ) then
- pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
- endif
- enddo
- enddo
- endif
- enddo
- endif
+ pturb = 2.
+ r0 = 10.e3
+ zc = 1.4e3 ! center of bubble from surface
+ icenter = (npx-1)/3 + 1
+ jcenter = (npy-1)/2 + 1
+ do k=1, npz
+ zm = 0.5*(ze1(k)+ze1(k+1))
+ ptmp = ( (zm-zc)/zc ) **2
+ do j=js,je
+ do i=is,ie
+ dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
+ pt(i,j,k) = pt(i,j,k) + pturb*max(1.-sqrt(dist),0.)
+ enddo
+ enddo
+ enddo
+ endif
+
+ case ( 19 )
+!---------------------------
+! Revised Doubly periodic SuperCell, straight wind (v==0)
+! Linjiong Zhou
+!--------------------------
+ zvir = rvgas/rdgas - 1.
+ p00 = 1000.E2
+ ps(:,:) = p00
+ phis(:,:) = 0.
+ do j=js,je
+ do i=is,ie
+ pk(i,j,1) = ptop**kappa
+ pe(i,1,j) = ptop
+ peln(i,1,j) = log(ptop)
+ enddo
+ enddo
+
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
+ pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
+ peln(i,k+1,j) = log(pe(i,k+1,j))
+ pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
+ enddo
+ enddo
+ enddo
+
+ i = is
+ j = js
+ do k=1,npz
+ pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
+ enddo
+
+ if (do_marine_sounding) then
+ call Marine_Sounding(npz, p00, pk1, ts1, qs1)
+ else
+ call SuperCell_Sounding_Marine(npz, p00, pk1, ts1, qs1)
+ endif
+
+ v(:,:,:) = 0.
+ w(:,:,:) = 0.
+ q(:,:,:,:) = 0.
+
+ do k=1,npz
+ do j=js,je
+ 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))
+ enddo
+ enddo
+ enddo
+
+ ze1(npz+1) = 0.
+ do k=npz,1,-1
+ ze1(k) = ze1(k+1) - delz(is,js,k)
+ enddo
+
+ do k=1,npz
+ zm = 0.5*(ze1(k)+ze1(k+1))
+ if (no_wind) then
+ us0 = 0.0 + umean
+ else
+ us0 = 14. + umean
+ endif
+ utmp = us0*tanh(zm/1.2E4)
+ do j=js,je+1
+ do i=is,ie
+ u(i,j,k) = utmp
+ 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., &
+ .true., hydrostatic, nwat, domain, flagstruct%adiabatic)
+
+ if (gaussian_dt) then
+
+! *** Add Initial perturbation (Gaussian) ***
+ pturb = dt_amp
+ r0 = 10.e3
+ zc = 1.4e3 ! center of bubble from surface
+ icenter = (npx-1)/2 + 1
+ jcenter = (npy-1)/2 + 1
+ do k=1, npz
+ zm = 0.5*(ze1(k)+ze1(k+1))
+ ptmp = min(abs((zm-zc)/zc),1.0)
+ do j=js,je
+ do i=is,ie
+ xr = min(abs((i-icenter)*dx_const/r0),1.0)
+ yr = min(abs((j-jcenter)*dy_const/r0),1.0)
+ dist = cos(pi/2*ptmp)**2*cos(pi/2*xr)**2*cos(pi/2*yr)**2
+ pt(i,j,k) = pt(i,j,k) + pturb*dist
+ enddo
+ enddo
+ enddo
+
+ else
+
+! *** Add Initial perturbation (Ellipse) ***
+ pturb = dt_amp
+ r0 = 10.e3
+ zc = 1.4e3 ! center of bubble from surface
+ icenter = (npx-1)/2 + 1
+ jcenter = (npy-1)/2 + 1
+ do k=1, npz
+ zm = 0.5*(ze1(k)+ze1(k+1))
+ ptmp = ( (zm-zc)/zc ) **2
+ do j=js,je
+ do i=is,ie
+ dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
+ pt(i,j,k) = pt(i,j,k) + pturb*max(1.-sqrt(dist),0.)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ case ( 21 )
+!---------------------------------------------------------
+! Mountain wave
+!---------------------------------------------------------
+ t00 = 288.
+ N2 = 0.01**2
+ p00 = 1.e5
+ pk0 = exp(kappa*log(p00))
+ th0 = t00/pk0
+ amp = grav*grav/(cp_air*N2)
+ rkap = 1./kappa
+
+ !1. set up topography (uniform-in-y)
+ icenter = npx/2
+ jcenter = npy/2
+ do j=jsd,jed
+ do i=isd,ied
+ dist=(i-icenter)*dx_const
+ phis(i,j)=250.*exp(-(dist/5000.)**2)*cos(pi*dist/4000.)*cos(pi*dist/4000.)
+ gz(i,j,npz+1) = phis(i,j)
+ enddo
+ enddo
- case ( 101 )
+ !2. Compute surface pressure
+ ! then form pressure surfaces
+ do j=jsd,jed
+ do i=isd,ied
+ ths = th0*exp(phis(i,j)*N2/grav)
+ pks = pk0 + amp*(1./ths - 1./th0)
+ ps(i,j) = exp(rkap*log(pks))
+ enddo
+ enddo
+
+ do k=1,npz+1
+ do j=js,je
+ do i=is,ie
+ pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
+ peln(i,k,j) = log(pe(i,k,j))
+ pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
+ enddo
+ enddo
+ enddo
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
+ !delp(i,j,k) = ak(k+1) - ak(k) + ps(i,j)*(bk(k+1) - bk(k))
+ pkz(i,j,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
+ pkz(i,j,k) = exp(kappa*log(pkz(i,j,k)))
+ enddo
+ enddo
+ enddo
+ ptop = ak(1)
+
+ !3. Set up thermal profile: N = 0.02
+ do j=js,je
+ do i=is,ie
+ ths = exp(-phis(i,j)*N2/grav)/th0
+ ths = ths - (pk(i,j,npz+1)-pkz(i,j,npz))/amp
+ pt(i,j,npz) = pkz(i,j,npz)/ths
+ delz(i,j,npz) = rdgas/grav*pt(i,j,npz)*(peln(i,npz,j)-peln(i,npz+1,j))
+ gz(i,j,npz) = gz(i,j,npz+1) - delz(i,j,npz)
+ enddo
+ enddo
+
+ do k=npz-1,1,-1
+ do j=js,je
+ do i=is,ie
+ ths = pkz(i,j,k+1)/pt(i,j,k+1) - (pkz(i,j,k+1)-pkz(i,j,k))/amp
+ pt(i,j,k) = pkz(i,j,k)/ths
+ delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
+ gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ !4. Set up wind profile:
+ u = 10.0
+ v = 0.0
+ w = 0.0
+ q = 0.0
+
+ !5. Re-adjust phis and gz ; set up other variables
+ do j=jsd,jed
+ do i=isd,ied
+ phis(i,j) = phis(i,j)*grav
+ enddo
+ enddo
+ do k=1,npz+1
+ do j=jsd,jed
+ do i=isd,ied
+ gz(i,j,k) = gz(i,j,k)*grav
+ 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, hydrostatic, nwat, domain, flagstruct%adiabatic, .not. hydrostatic )
+
+ case ( 22 )
+!---------------------------------------------------------
+! Uniform-in-y resting + shear flow over Schar topography
+!---------------------------------------------------------
+ t00 = 300.
+ N2 = 0.01**2
+ N2b = 0.02**2
+ p00 = 1.e5
+ pk0 = exp(kappa*log(p00))
+ th0 = t00/pk0
+ amp = grav*grav/(cp_air*N2)
+ ampb = grav*grav/(cp_air*N2b)
+ rkap = 1./kappa
+
+#ifdef UNIFORM_DZ
+ !0. Set up uniform ~500-m grid spacing
+ !(This is a primitive method for creating a hybrid coordinate
+ ! and produces discontinuities.)
+ dz = 500.
+ ze = 0.0
+ zt = 8000.
+ !zt = 5000.
+ thp = th0
+ pkp = pk0
+ ak(npz+1) = 0.0
+ bk(npz+1) = 1.0
+
+ ths = th0*exp(zt*N2/grav)
+ pks = pk0 + amp*(1./ths - 1./th0)
+ p_t = exp(1./kappa*log(pks))
+
+ if (is_master()) write(*,'(I, 2F)') npz+1, ak(npz+1), bk(npz+1)
+ if (is_master()) write(*,'(2F)') ths*pk0, p_t
+
+ do k=npz,1,-1
+ ze = ze+dz
+ if (ze >= 10000.) then
+ ths = thp*exp(dz*N2b/grav)
+ pks = pkp + ampb*(1./ths - 1./thp)
+ else
+ ths = thp*exp(dz*N2/grav)
+ pks = pkp + amp*(1./ths - 1./thp)
+ endif
+ pp = exp(1./kappa*log(pks))
+ if (pp <= p_t) then
+ ak(k) = pp
+ bk(k) = 0.0
+ else
+ ak(k) = p_t*(pp-p00)/(p_t-p00)
+ bk(k) = (pp-p_t)/(p00-p_t)
+ endif
+ thp = ths
+ pkp = pks
+ if (is_master()) write(*,'(I, 5F)') k, ak(k), bk(k), ak(k+1)-ak(k) + p00*(bk(k+1)-bk(k)), ths*pk0, pp
+
+ enddo
+
+ call mpp_sync()
+#endif
+
+ !1. set up topography (uniform-in-y)
+ icenter = npx/2
+ jcenter = npy/2
+ do j=jsd,jed
+ do i=isd,ied
+ dist=(i-icenter)*dx_const
+ phis(i,j)=2000.*exp(-(dist/10000.)**2)*cos(pi*dist/8000.)*cos(pi*dist/8000.)
+ gz(i,j,npz+1) = phis(i,j)
+ enddo
+ enddo
+
+ !2. Compute surface pressure assuming constant N = 0.01
+ ! then form pressure surfaces
+ do j=jsd,jed
+ do i=isd,ied
+ ths = th0*exp(phis(i,j)*N2/grav)
+ pks = pk0 + amp*(1./ths - 1./th0)
+ ps(i,j) = exp(rkap*log(pks))
+ enddo
+ enddo
+
+ do k=1,npz+1
+ do j=js,je
+ do i=is,ie
+ pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
+ peln(i,k,j) = log(pe(i,k,j))
+ pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
+ enddo
+ enddo
+ enddo
+ do k=1,npz
+ do j=js,je
+ do i=is,ie
+ delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
+ !delp(i,j,k) = ak(k+1) - ak(k) + ps(i,j)*(bk(k+1) - bk(k))
+ pkz(i,j,k) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
+ pkz(i,j,k) = exp(kappa*log(pkz(i,j,k)))
+ enddo
+ enddo
+ enddo
+ ptop = ak(1)
+
+ !2. Set up thermal profile: N = 0.01 below 14 km and 0.02 above 14 km.
+ do j=js,je
+ do i=is,ie
+ ths = exp(-phis(i,j)*N2/grav)/th0
+ ths = ths - (pk(i,j,npz+1)-pkz(i,j,npz))/amp
+ pt(i,j,npz) = pkz(i,j,npz)/ths
+ delz(i,j,npz) = rdgas/grav*pt(i,j,npz)*(peln(i,npz,j)-peln(i,npz+1,j))
+ gz(i,j,npz) = gz(i,j,npz+1) - delz(i,j,npz)
+ enddo
+ enddo
+
+ do k=npz-1,1,-1
+ do j=js,je
+ do i=is,ie
+ if (gz(i,j,k+1) < 14000.) then
+ ths = pkz(i,j,k+1)/pt(i,j,k+1) - (pkz(i,j,k+1)-pkz(i,j,k))/amp
+ else
+ ths = pkz(i,j,k+1)/pt(i,j,k+1) - (pkz(i,j,k+1)-pkz(i,j,k))/ampb
+ endif
+ pt(i,j,k) = pkz(i,j,k)/ths
+ delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
+ gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ !3. Set up wind profile: 0 below 10 km, 20 above 14 km, linear between
+ ! (recall this is uniform-in-y; a 3D problem would require
+ ! computing staggered height from cell-centroid gz)
+ do k=npz,1,-1
+ do j=js,je+1
+ do i=is,ie
+ if (gz(i,js,k+1) < 10000.) then
+ u(i,j,k) = 0.0
+ elseif (gz(i,js,k+1) < 14000.) then
+ u(i,j,k) = 0.005*(0.5*(gz(i,js,k)+gz(i,js,k+1))-10000.)
+ else
+ u(i,j,k) = 20.0
+ endif
+ enddo
+ enddo
+ enddo
+ v = 0.0
+ w = 0.0
+ q = 0.0
+
+ !4. Re-adjust phis and gz ; set up other variables
+ do j=jsd,jed
+ do i=isd,ied
+ phis(i,j) = phis(i,j)*grav
+ enddo
+ enddo
+ do k=1,npz+1
+ do j=jsd,jed
+ do i=isd,ied
+ gz(i,j,k) = gz(i,j,k)*grav
+ 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, hydrostatic, nwat, domain, flagstruct%adiabatic, .not. hydrostatic )
+
+
+ case ( 101 )
! IC for LES
t00 = 250. ! constant temp
@@ -5170,15 +5517,15 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1))
dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2
dist = sqrt(dist)
- if ( dist <= r0 ) then
- pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0)
- endif
+ pt(i,j,k) = pt(i,j,k) + 2.0*max((1.-dist/r0),0.)
enddo
enddo
enddo
end select
+ is_ideal_case = .true.
+
nullify(grid)
nullify(agrid)
@@ -5223,7 +5570,8 @@ subroutine read_namelist_test_case_nml(nml_filename)
character(*), intent(IN) :: nml_filename
integer :: ierr, f_unit, unit, ios
- namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size
+ namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size, &
+ no_wind, gaussian_dt, dt_amp, do_marine_sounding, checker_tr, small_earth_scale, Umean
#include
@@ -5239,6 +5587,10 @@ subroutine read_namelist_test_case_nml(nml_filename)
ierr = check_nml_error(ios,'test_case_nml')
write(unit, nml=test_case_nml)
+ if (.not. (small_earth_scale == 1.0)) then
+ radius = cnst_radius / small_earth_scale
+ omega = cnst_omega * small_earth_scale
+ endif
end subroutine read_namelist_test_case_nml
@@ -5566,7 +5918,7 @@ end subroutine superK_u
subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
- use gfdl_cloud_microphys_mod, only: wqsat_moist, qsmith_init, qs_blend
+ use gfdl_mp_mod, only: wqsat_moist, qsmith_init, qs_blend
! Morris Weisman & J. Klemp 2002 sounding
! Output sounding on pressure levels:
integer, intent(in):: km
@@ -5588,11 +5940,119 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
real:: dz0, zvir, fac_z, pk0, temp1, p2
integer:: k, n, kk
-#ifdef GFS_PHYS
+ zvir = rvgas/rdgas - 1.
+ pk0 = p00**kappa
+ pp(ns) = ps
+ pk(ns) = ps**kappa
+ if ( (is_master()) ) then
+ write(*,*) 'Computing sounding for super-cell test'
+ endif
- call mpp_error(FATAL, 'SuperCell sounding cannot perform with GFS Physics.')
+ call qsmith_init
-#else
+ dz0 = 50.
+ zs(ns) = 0.
+ qs(:) = qst
+ rh(:) = 0.25
+
+ do k=ns-1, 1, -1
+ zs(k) = zs(k+1) + dz0
+ enddo
+
+ do k=1,ns
+! Potential temperature
+ if ( zs(k) .gt. ztr ) then
+! Stratosphere:
+ pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
+ else
+! Troposphere:
+ fac_z = (zs(k)/ztr)**1.25
+ pt(k) = pt0 + (ptr-pt0)* fac_z
+ rh(k) = 1. - 0.75 * fac_z
+! First guess on q:
+ qs(k) = qv0 - (qv0-qst)*fac_z
+ endif
+ pt(k) = pt(k) / pk0
+ enddo
+
+!--------------------------------------
+! Iterate nx times with virtual effect:
+!--------------------------------------
+ do n=1, nx
+ do k=1,ns-1
+ temp1 = 0.5*(pt(k)*(1.+zvir*qs(k)) + pt(k+1)*(1.+zvir*qs(k+1)))
+ dpk(k) = grav*(zs(k)-zs(k+1))/(cp_air*temp1) ! DPK > 0
+ enddo
+
+ do k=ns-1,1,-1
+ pk(k) = pk(k+1) - dpk(k)
+ enddo
+
+ do k=1, ns
+ temp1 = pt(k)*pk(k)
+! 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)*wqsat_moist(temp1, qs(k), pp(k)))
+ !qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k)))
+ !if ( (is_master()) ) write(*,*) 0.001*pp(k), qs(k)
+ else
+ !if ( (is_master()) ) write(*,*) n, k, pk(k)
+ call mpp_error(FATAL, 'Super-Cell case: pk < 0')
+ endif
+ enddo
+ enddo
+
+! Interpolate to p levels using pk1: p**kappa
+ do 555 k=1, km
+ if ( pk1(k) .le. pk(1) ) then
+ tp(k) = pt(1)*pk(1)/pk1(k) ! isothermal above
+ qp(k) = qst ! set to stratosphere value
+ elseif ( pk1(k) .ge. pk(ns) ) then
+ tp(k) = pt(ns)
+ qp(k) = qs(ns)
+ else
+ do kk=1,ns-1
+ if( (pk1(k).le.pk(kk+1)) .and. (pk1(k).ge.pk(kk)) ) then
+ fac_z = (pk1(k)-pk(kk))/(pk(kk+1)-pk(kk))
+ tp(k) = pt(kk) + (pt(kk+1)-pt(kk))*fac_z
+ qp(k) = qs(kk) + (qs(kk+1)-qs(kk))*fac_z
+ goto 555
+ endif
+ enddo
+ endif
+555 continue
+
+ do k=1,km
+ tp(k) = tp(k)*pk1(k) ! temperature
+ tp(k) = max(Tmin, tp(k))
+ enddo
+
+ end subroutine SuperCell_Sounding
+
+! added by Linjiong Zhou
+ subroutine SuperCell_Sounding_Marine(km, ps, pk1, tp, qp)
+ use gfdl_mp_mod, only: wqsat_moist, qsmith_init, qs_blend
+! Morris Weisman & J. Klemp 2002 sounding
+! Output sounding on pressure levels:
+ integer, intent(in):: km
+ real, intent(in):: ps ! surface pressure (Pa)
+ real, intent(in), dimension(km):: pk1
+ real, intent(out), dimension(km):: tp, qp
+! Local:
+ integer, parameter:: ns = 401
+ integer, parameter:: nx = 3
+ real, dimension(ns):: zs, pt, qs, us, rh, pp, pk, dpk, dqdt
+ real, parameter:: Tmin = 175.
+ real, parameter:: p00 = 1.0e5
+ real, parameter:: qst = 3.0e-6
+ real, parameter:: qv0 = 1.7e-2 ! higher surface specific humidity
+ real, parameter:: ztr = 12.E3
+ real, parameter:: ttr = 213.
+ real, parameter:: ptr = 353. ! higher Tropopause potential temp.
+ real, parameter:: pt0 = 300. ! surface potential temperature
+ real:: dz0, zvir, fac_z, pk0, temp1, p2
+ integer:: k, n, kk
zvir = rvgas/rdgas - 1.
pk0 = p00**kappa
@@ -5602,7 +6062,7 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
write(*,*) 'Computing sounding for super-cell test'
endif
- call qsmith_init
+ !call qsmith_init
dz0 = 50.
zs(ns) = 0.
@@ -5629,6 +6089,133 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
pt(k) = pt(k) / pk0
enddo
+!--------------------------------------
+! Iterate nx times with virtual effect:
+!--------------------------------------
+ do n=1, nx
+ do k=1,ns-1
+ temp1 = 0.5*(pt(k)*(1.+zvir*qs(k)) + pt(k+1)*(1.+zvir*qs(k+1)))
+ dpk(k) = grav*(zs(k)-zs(k+1))/(cp_air*temp1) ! DPK > 0
+ enddo
+
+ do k=ns-1,1,-1
+ pk(k) = pk(k+1) - dpk(k)
+ enddo
+
+ do k=1, ns
+ temp1 = pt(k)*pk(k)
+! 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) = 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)*qs_blend(temp1, pp(k), qs(k)))
+!#else
+! qs(k) = min(qv0, rh(k)*wqsat_moist(temp1, qs(k), pp(k)))
+!#endif
+!
+!#endif
+ else
+ if ( (is_master()) ) write(*,*) n, k, pk(k)
+ call mpp_error(FATAL, 'Super-Cell case: pk < 0')
+ endif
+ enddo
+ enddo
+
+! Interpolate to p levels using pk1: p**kappa
+ do 555 k=1, km
+ if ( pk1(k) .le. pk(1) ) then
+ tp(k) = pt(1)*pk(1)/pk1(k) ! isothermal above
+ qp(k) = qst ! set to stratosphere value
+ elseif ( pk1(k) .ge. pk(ns) ) then
+ tp(k) = pt(ns)
+ qp(k) = qs(ns)
+ else
+ do kk=1,ns-1
+ if( (pk1(k).le.pk(kk+1)) .and. (pk1(k).ge.pk(kk)) ) then
+ fac_z = (pk1(k)-pk(kk))/(pk(kk+1)-pk(kk))
+ tp(k) = pt(kk) + (pt(kk+1)-pt(kk))*fac_z
+ qp(k) = qs(kk) + (qs(kk+1)-qs(kk))*fac_z
+ goto 555
+ endif
+ enddo
+ endif
+555 continue
+
+ do k=1,km
+ tp(k) = tp(k)*pk1(k) ! temperature
+ tp(k) = max(Tmin, tp(k))
+ enddo
+
+ end subroutine SuperCell_Sounding_Marine
+
+ ! added by Linjiong Zhou
+ subroutine Marine_Sounding(km, ps, pk1, tp, qp)
+ use gfdl_mp_mod, only: wqsat_moist, qsmith_init, qs_blend
+! JASMINE CETRONE AND ROBERT A. HOUZE JR. MWR 225
+! Output sounding on pressure levels:
+ integer, intent(in):: km
+ real, intent(in):: ps ! surface pressure (Pa)
+ real, intent(in), dimension(km):: pk1
+ real, intent(out), dimension(km):: tp, qp
+! Local:
+ integer, parameter:: ns = 401
+ integer, parameter:: nx = 3
+ real, dimension(ns):: zs, pt, qs, us, rh, pp, pk, dpk, dqdt
+ real, parameter:: Tmin = 175.
+ real, parameter:: p00 = 1.0e5
+ real, parameter:: qst = 3.0e-6
+ real, parameter:: qv0 = 2.0e-2
+ real, parameter:: ztr = 12.E3
+ real, parameter:: ttr = 213.
+ real, parameter:: ptr = 346. ! Tropopause potential temp.
+ real, parameter:: pt0 = 300. ! surface potential temperature
+ real:: dz0, zvir, fac_z, pk0, temp1, p2
+ integer:: k, n, kk
+
+
+ zvir = rvgas/rdgas - 1.
+ pk0 = p00**kappa
+ pp(ns) = ps
+ pk(ns) = ps**kappa
+ if ( (is_master()) ) then
+ write(*,*) 'Computing sounding for super-cell test'
+ endif
+
+ call qsmith_init
+
+ dz0 = 50.
+ zs(ns) = 0.
+ qs(:) = qst
+ rh(:) = 0.25
+
+ do k=ns-1, 1, -1
+ zs(k) = zs(k+1) + dz0
+ enddo
+
+ do k=1,ns
+! Potential temperature
+ if ( zs(k) .gt. ztr ) then
+! Stratosphere:
+ pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
+ else
+! Troposphere:
+ fac_z = (zs(k)/ztr)**1.25
+ pt(k) = (pt0 + (ptr-pt0)* fac_z**1.25)*(ztr-zs(k))/ztr+&
+ (pt0 + (ptr-pt0)* fac_z**0.15)*zs(k)/ztr
+ rh(k) = 1. - 0.75 * fac_z
+! First guess on q:
+ qs(k) = (qv0 - (qv0-qst)* fac_z**0.50)*(ztr-zs(k))/ztr+&
+ (qv0 - (qv0-qst)* fac_z**0.01)*zs(k)/ztr
+ endif
+ pt(k) = pt(k) / pk0
+ enddo
+
!--------------------------------------
! Iterate nx times with virtual effect:
!--------------------------------------
@@ -5692,9 +6279,7 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
tp(k) = max(Tmin, tp(k))
enddo
-#endif
-
- end subroutine SuperCell_Sounding
+ end subroutine Marine_Sounding
subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,&
is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
@@ -5734,7 +6319,7 @@ subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,&
real(kind=R_GRID), parameter :: lamp = pi/9.
real(kind=R_GRID), parameter :: phip = 2.*lamp
real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
- real, parameter :: Rp = radius/10.
+ real :: Rp
real, parameter :: lapse = 5.e-3
real, parameter :: dT = 4.8e5
real, parameter :: phiW = 2.*pi/9.
@@ -5764,6 +6349,7 @@ subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,&
!Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
! and meridional winds on both grids, and rotate as needed
zvir = rvgas/rdgas - 1.
+ Rp = radius/10.
!PS
do j=js,je
@@ -6120,7 +6706,7 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,&
real, parameter :: dp = 1115. ! Pa
real, parameter :: rp = 282000. ! m
real, parameter :: zp = 7000. ! m
- real, parameter :: fc = 2.*OMEGA*sin(phip)
+ real :: fc
real, parameter :: zconv = 1.e-6
real, parameter :: rdgrav = rdgas/grav
@@ -6137,6 +6723,8 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,&
real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v
real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
+ fc = 2.*OMEGA*sin(phip)
+
!Compute ps, phis, delp, aux pressure variables, Temperature, winds
! (with or without perturbation), moisture, w, delz