diff --git a/README.md b/README.md
index 7292e7fe5..3f77c8d2e 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,6 @@
# GFDL_atmos_cubed_sphere
-The source contained herein reflects the 202204 release of the Finite Volume Cubed-Sphere Dynamical Core (FV3) from GFDL
+The source contained herein reflects the 202210 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 0794ce729..3dd4f450a 100644
--- a/RELEASE.md
+++ b/RELEASE.md
@@ -1,3 +1,19 @@
+# RELEASE NOTES for FV3 202210: Summary
+FV3-202210-public --- October 2022
+Lucas Harris, GFDL lucas.harris@noaa.gov
+
+This version has been tested with SHiELD physics release 202210
+and with FMS release 2022.03 from https://github.com/NOAA-GFDL/FMS
+
+This release includes the following:
+- Release of the GFDL Microphysics Version 3
+- Fix pressure-coarse-graining weighting from AI2's fork of FV3GFS
+- Add A-grid restart functionality from AI2's fork of FV3GFS
+- Fix for telescoping nest and GFS FIX file read
+- Total precipitation diag field has changed from prec to pret
+- Clean-up of the diagnostic messages to stdout
+
+
# RELEASE NOTES for FV3 202204: Summary
FV3-202204-public --- April 2022
Lucas Harris, GFDL lucas.harris@noaa.gov
diff --git a/driver/SHiELD/atmosphere.F90 b/driver/SHiELD/atmosphere.F90
index 8d9e3ceac..e6efa824f 100644
--- a/driver/SHiELD/atmosphere.F90
+++ b/driver/SHiELD/atmosphere.F90
@@ -83,8 +83,8 @@ module atmosphere_mod
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 cld_eff_rad_mod, only: cld_eff_rad_init
use diag_manager_mod, only: send_data
+use external_aero_mod, only: load_aero, read_aero, clean_aero
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
@@ -283,8 +283,8 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data
!--- allocate pref
allocate(pref(npz+1,2), dum1d(npz+1))
- call gfdl_mp_init(input_nml_file, stdlog())
- call cld_eff_rad_init(input_nml_file, stdlog())
+ call gfdl_mp_init(input_nml_file, stdlog(), Atm(mygrid)%flagstruct%hydrostatic)
+
call fv_restart(Atm(mygrid)%domain, Atm, dt_atmos, seconds, days, cold_start, &
Atm(mygrid)%gridstruct%grid_type, mygrid)
@@ -294,6 +294,13 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data
!I've had trouble getting this to work with multiple grids at a time; worth revisiting?
call fv_diag_init(Atm(mygrid:mygrid), Atm(mygrid)%atmos_axes, Time, npx, npy, npz, Atm(mygrid)%flagstruct%p_ref)
+ if (Atm(mygrid)%flagstruct%do_aerosol) then
+ call load_aero(Atm(mygrid), Time)
+ call read_aero(isc, iec, jsc, jec, npz, nq, Time, Atm(mygrid)%pe(isc:iec,:,jsc:jec), &
+ Atm(mygrid)%peln(isc:iec,:,jsc:jec), Atm(mygrid)%q(isc:iec,jsc:jec,:,:), &
+ Atm(mygrid)%flagstruct%kord_tr, Atm(mygrid)%flagstruct%fill)
+ endif
+
if (Atm(mygrid)%coarse_graining%write_coarse_diagnostics) then
call fv_coarse_diag_init(Atm, Time, Atm(mygrid)%atmos_axes(3), &
Atm(mygrid)%atmos_axes(4), Atm(mygrid)%coarse_graining)
@@ -338,7 +345,6 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data
endif
call fv_io_register_nudge_restart ( Atm )
-
if ( Atm(mygrid)%flagstruct%na_init>0 ) then
if ( .not. Atm(mygrid)%flagstruct%hydrostatic ) then
call prt_maxmin('Before adi: W', Atm(mygrid)%w, isc, iec, jsc, jec, Atm(mygrid)%ng, npz, 1.)
@@ -449,6 +455,12 @@ subroutine atmosphere_dynamics ( Time )
isd, ied, jsd, jed )
endif
+ if (Atm(mygrid)%flagstruct%do_aerosol) then
+ call read_aero(isc, iec, jsc, jec, npz, nq, Time, Atm(mygrid)%pe(isc:iec,:,jsc:jec), &
+ Atm(mygrid)%peln(isc:iec,:,jsc:jec), Atm(mygrid)%q(isc:iec,jsc:jec,:,:), &
+ Atm(mygrid)%flagstruct%kord_tr, Atm(mygrid)%flagstruct%fill)
+ endif
+
!save ps to ps_dt before dynamics update
ps_dt(:,:)=Atm(n)%ps(:,:)
@@ -578,10 +590,12 @@ subroutine atmosphere_end (Time, Grid_box )!rab, Radiation, Physics)
! initialize domains for writing global physics data
if ( Atm(mygrid)%flagstruct%nudge ) call fv_nwp_nudge_end
- if (Atm(mygrid)%flagstruct%do_inline_mp) then
- call gfdl_mp_end ( )
+ if (Atm(mygrid)%flagstruct%do_aerosol) then
+ call clean_aero()
endif
+ call gfdl_mp_end ( )
+
if (first_diag) then
call timing_on('FV_DIAG')
call fv_diag(Atm(mygrid:mygrid), zvir, fv_time, Atm(mygrid)%flagstruct%print_freq)
@@ -655,13 +669,8 @@ subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num
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
+ if (present(tile_num)) tile_num = Atm(mygrid)%global_tile
+
end subroutine atmosphere_control_data
@@ -1385,13 +1394,6 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block)
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.
@@ -1769,10 +1771,19 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
do ix = 1, blen
i = Atm_block%index(nb)%ii(ix)
j = Atm_block%index(nb)%jj(ix)
+ IPD_Data(nb)%Statein%prew(ix) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prew(i,j)))
IPD_Data(nb)%Statein%prer(ix) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prer(i,j)))
IPD_Data(nb)%Statein%prei(ix) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prei(i,j)))
IPD_Data(nb)%Statein%pres(ix) = _DBL_(_RL_(Atm(mygrid)%inline_mp%pres(i,j)))
IPD_Data(nb)%Statein%preg(ix) = _DBL_(_RL_(Atm(mygrid)%inline_mp%preg(i,j)))
+ do k = 1, npz
+ k1 = npz+1-k ! flipping the index
+ IPD_Data(nb)%Statein%prefluxw(ix,k) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prefluxw(i,j,k1)))
+ IPD_Data(nb)%Statein%prefluxr(ix,k) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prefluxr(i,j,k1)))
+ IPD_Data(nb)%Statein%prefluxi(ix,k) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prefluxi(i,j,k1)))
+ IPD_Data(nb)%Statein%prefluxs(ix,k) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prefluxs(i,j,k1)))
+ IPD_Data(nb)%Statein%prefluxg(ix,k) = _DBL_(_RL_(Atm(mygrid)%inline_mp%prefluxg(i,j,k1)))
+ enddo
enddo
endif
diff --git a/driver/solo/atmosphere.F90 b/driver/solo/atmosphere.F90
index 9ff66e494..1a79fe23d 100644
--- a/driver/solo/atmosphere.F90
+++ b/driver/solo/atmosphere.F90
@@ -51,9 +51,7 @@ module atmosphere_mod
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
@@ -163,12 +161,9 @@ subroutine atmosphere_init ( Time_init, Time, Time_step )
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 (.not. Atm(n)%flagstruct%adiabatic) call gfdl_mp_init (input_nml_file, stdlog(), Atm(n)%flagstruct%hydrostatic)
@@ -534,7 +529,6 @@ subroutine atmosphere_end
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)
diff --git a/driver/solo/fv_phys.F90 b/driver/solo/fv_phys.F90
index 9107bf1c0..f95ab8024 100644
--- a/driver/solo/fv_phys.F90
+++ b/driver/solo/fv_phys.F90
@@ -25,7 +25,7 @@ module fv_phys_mod
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 gfdl_mp_mod, only: mqs3d, wet_bulb, c_liq
use hswf_mod, only: Held_Suarez_Tend
use fv_sg_mod, only: fv_subgrid_z
use fv_update_phys_mod, only: fv_update_phys
@@ -70,8 +70,6 @@ module fv_phys_mod
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
@@ -899,8 +897,8 @@ subroutine GFDL_sim_phys(npx, npy, npz, is, ie, js, je, ng, nq, nwat, pk, pkz,
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
+ call mqs3d(ie-is+1, je-js+1, 1, sst, ps, q3(is:ie,js:je,km,sphum), qs)
+ call mqs3d(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
diff --git a/driver/solo/qs_tables.F90 b/driver/solo/qs_tables.F90
index 83b7f26fe..f2948ef16 100644
--- a/driver/solo/qs_tables.F90
+++ b/driver/solo/qs_tables.F90
@@ -22,6 +22,7 @@
module qs_tables_mod
use constants_mod, only: rdgas, rvgas, cp_air, cp_vapor, hlv
+use gfdl_mp_mod, only: c_liq
implicit none
logical:: qs_table_is_initialized = .false.
@@ -30,8 +31,6 @@ module qs_tables_mod
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
diff --git a/model/cld_eff_rad.F90 b/model/cld_eff_rad.F90
deleted file mode 100644
index fc7caee12..000000000
--- a/model/cld_eff_rad.F90
+++ /dev/null
@@ -1,529 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-! =======================================================================
-! cloud radii diagnosis built for gfdl cloud microphysics
-! authors: linjiong zhou and shian - jiann lin
-! =======================================================================
-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 cld_eff_rad, cld_eff_rad_init
-
- real :: qi0_rei = 0.8e-4 ! max cloud ice value (by other sources)
-
- real :: qmin = 1.0e-12 ! minimum mass mixing ratio (kg / kg)
- 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
- real :: betar = 1.0
- real :: betas = 1.0
- real :: betag = 1.0
-
- logical :: liq_ice_combine = .true.
- logical :: snow_grauple_combine = .false.
-
- integer :: rewflag = 1
- ! 1: martin et al., 1994
- ! 2: martin et al., 1994, gfdl revision
- ! 3: kiehl et al., 1994
- integer :: reiflag = 1
- ! 1: heymsfield and mcfarquhar, 1996
- ! 2: donner et al., 1997
- ! 3: fu, 2007
- ! 4: kristjansson et al., 2000
- ! 5: wyser, 1998
-
- 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
-
-! =======================================================================
-! radius of cloud species diagnosis
-! =======================================================================
-
-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)
-
- implicit none
-
- integer, intent (in) :: is, ie
- integer, intent (in) :: ks, ke
-
- real, intent (in), dimension (is:ie) :: lsm ! land sea mask, 0: ocean, 1: land, 2: sea ice
- real, intent (in), dimension (is:ie) :: snowd ! snow depth (mm)
-
- real, intent (in), dimension (is:ie, ks:ke) :: delp, t, p
- 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 / ice mass mixing ratio (kg / kg)
- real, intent (in), dimension (is:ie, ks:ke), optional :: cnvc ! convective 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
-
- integer :: i, k, ind
-
- real, dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg ! mass mixing ratio (kg / kg)
-
- real :: dpg ! dp / g
- real :: rho ! density (kg / m^3)
- real :: ccnw ! cloud condensate nuclei for cloud water (cm^ - 3)
- real :: mask
- real :: cor
- real :: tc0
- real :: bw
-
- real :: lambdar, lambdas, lambdag
- real :: rei_fac
-
- 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) = (/ &
- 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, &
- 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, &
- 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, &
- 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, &
- 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, &
- 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, &
- 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, &
- 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
- 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
- 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
- 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
- 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
- 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
- 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
- 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
- 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
- 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
- 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
- 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
- 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
- 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
- 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
- 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /)
-
- qmw = qw
- qmi = qi
- qmr = qr
- qms = qs
- qmg = qg
- cld = cloud
-
- if (present (cnvw)) then
- qmw = qmw + cnvw
- endif
- if (present (cnvi)) then
- qmi = qmi + cnvi
- endif
- if (present (cnvc)) then
- cld = cnvc + (1 - cnvc) * cld
- endif
-
- 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) > t_ice) then
- qms (i, k) = qmi (i, k) + qms (i, k)
- qmi (i, k) = 0.
- else
- qmi (i, k) = qmi (i, k) + qms (i, k)
- if (qmi (i, k) .gt. qi0_max) then
- qms (i, k) = qmi (i, k) - qi0_max + qmg (i, k)
- qmi (i, k) = qi0_max
- else
- qms (i, k) = qmg (i, k)
- 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 (:, :)
- ! qms (:, :) = qmg (:, :)
- ! qmg (:, :) = 0. ! treating all graupel as "snow"
- do k = ks, ke
- do i = is, ie
- ! step - 1: combine cloud ice & snow
- qmi (i, k) = qmi (i, k) + qms (i, k)
- ! step - 2: auto - convert cloud ice if > qi0_max
- qms (i, k) = qmi (i, k) - qi0_max
- if (qms (i, k) .gt. 0.) then
- qmi (i, k) = qi0_max
- else
- qms (i, k) = 0.0
- endif
- enddo
- enddo
-#endif
- endif
-
- 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
- do i = is, ie
- ! step - 1: combine cloud water & rain
- qmw (i, k) = qmw (i, k) + qmr (i, k)
- ! step - 2: auto - convert cloud wat if > ql0_max
- qmr (i, k) = qmw (i, k) - ql0_max
- if (qmr (i, k) .gt. 0.) then
- qmw (i, k) = ql0_max
- else
- qmr (i, k) = 0.0
- endif
- enddo
- enddo
-#endif
-
- do k = ks, ke
-
- do i = is, ie
-
- qmw (i, k) = max (qmw (i, k), 0.0)
- qmi (i, k) = max (qmi (i, k), 0.0)
- qmr (i, k) = max (qmr (i, k), 0.0)
- qms (i, k) = max (qms (i, k), 0.0)
- qmg (i, k) = max (qmg (i, k), 0.0)
-
- cld (i, k) = min (max (cld (i, k), 0.0), 1.0)
-
- mask = min (max (lsm (i), 0.0), 2.0)
-
- dpg = abs (delp (i, k)) / grav
- ! 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) - t_ice
-
- if (rewflag .eq. 1) then
-
- ! -----------------------------------------------------------------------
- ! cloud water (martin et al., 1994)
- ! -----------------------------------------------------------------------
-
-#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
- 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
- rew (i, k) = rewmin
- endif
-
- endif
-
- if (rewflag .eq. 2) then
-
- ! -----------------------------------------------------------------------
- ! cloud water (martin et al., 1994, gfdl revision)
- ! -----------------------------------------------------------------------
-
- ccnw = 1.077 * ccn_o * abs (mask - 1.0) + 1.143 * ccn_l * (1.0 - abs (mask - 1.0))
-
- 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) * rho) / (4.0 * pi * rhow * ccnw))) * 1.0e4
- rew (i, k) = max (rewmin, min (rewmax, rew (i, k)))
- else
- qcw (i, k) = 0.0
- rew (i, k) = rewmin
- endif
-
- endif
-
- if (rewflag .eq. 3) then
-
- ! -----------------------------------------------------------------------
- ! cloud water (kiehl et al., 1994)
- ! -----------------------------------------------------------------------
-
- 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) = rew (i, k) + (14.0 - rew (i, k)) * min (1.0, max (0.0, snowd (i) / 1000.0))
- rew (i, k) = max (rewmin, min (rewmax, rew (i, k)))
- else
- qcw (i, k) = 0.0
- rew (i, k) = rewmin
- endif
-
- endif
-
- if (reiflag .eq. 1) then
-
- ! -----------------------------------------------------------------------
- ! cloud ice (heymsfield and mcfarquhar, 1996)
- ! -----------------------------------------------------------------------
-
- if (qmi (i, k) .gt. qmin) then
- qci (i, k) = betai * dpg * qmi (i, k) * 1.0e3
-#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 (0.109 * rei_fac) * 1.0e3
- elseif (tc0 .lt. - 40) then
- 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 (0.055 * rei_fac) * 1.0e3
- else
- rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3
- endif
- rei (i, k) = max (reimin, min (reimax, rei (i, k)))
- else
- qci (i, k) = 0.0
- rei (i, k) = reimin
- endif
-
- endif
-
- if (reiflag .eq. 2) then
-
- ! -----------------------------------------------------------------------
- ! cloud ice (donner et al., 1997)
- ! -----------------------------------------------------------------------
-
- if (qmi (i, k) .gt. qmin) then
- qci (i, k) = betai * dpg * qmi (i, k) * 1.0e3
- if (tc0 .le. - 55) then
- rei (i, k) = 15.41627
- elseif (tc0 .le. - 50) then
- rei (i, k) = 16.60895
- elseif (tc0 .le. - 45) then
- rei (i, k) = 32.89967
- elseif (tc0 .le. - 40) then
- rei (i, k) = 35.29989
- elseif (tc0 .le. - 35) then
- rei (i, k) = 55.65818
- elseif (tc0 .le. - 30) then
- rei (i, k) = 85.19071
- elseif (tc0 .le. - 25) then
- rei (i, k) = 72.35392
- else
- rei (i, k) = 92.46298
- endif
- rei (i, k) = max (reimin, min (reimax, rei (i, k)))
- else
- qci (i, k) = 0.0
- rei (i, k) = reimin
- endif
-
- endif
-
- if (reiflag .eq. 3) then
-
- ! -----------------------------------------------------------------------
- ! cloud ice (fu, 2007)
- ! -----------------------------------------------------------------------
-
- 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
- rei (i, k) = 100.0 + tc0 * 5.94
- else
- rei (i, k) = 47.05 + tc0 * (0.6624 + 0.001741 * tc0)
- 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
- endif
-
- endif
-
- if (reiflag .eq. 4) then
-
- ! -----------------------------------------------------------------------
- ! cloud ice (kristjansson et al., 2000)
- ! -----------------------------------------------------------------------
-
- if (qmi (i, k) .gt. qmin) then
- qci (i, k) = betai * dpg * qmi (i, k) * 1.0e3
- ind = min (max (int (t (i, k) - 136.0), 44), 138 - 1)
- cor = t (i, k) - int (t (i, k))
- rei (i, k) = retab (ind) * (1. - cor) + retab (ind + 1) * cor
- rei (i, k) = max (reimin, min (reimax, rei (i, k)))
- else
- qci (i, k) = 0.0
- rei (i, k) = reimin
- endif
-
- endif
-
- if (reiflag .eq. 5) then
-
- ! -----------------------------------------------------------------------
- ! cloud ice (wyser, 1998)
- ! -----------------------------------------------------------------------
-
- 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) * 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)))
- else
- qci (i, k) = 0.0
- rei (i, k) = reimin
- endif
-
- endif
-
- ! -----------------------------------------------------------------------
- ! rain (lin et al., 1983)
- ! -----------------------------------------------------------------------
-
- if (qmr (i, k) .gt. qmin) then
- qcr (i, k) = betar * dpg * qmr (i, k) * 1.0e3
- lambdar = exp (0.25 * log (pi * rhor * n0r / qmr (i, k) / rho))
- rer (i, k) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6
- rer (i, k) = max (rermin, min (rermax, rer (i, k)))
- else
- qcr (i, k) = 0.0
- rer (i, k) = rermin
- endif
-
- ! -----------------------------------------------------------------------
- ! snow (lin et al., 1983)
- ! -----------------------------------------------------------------------
-
- if (qms (i, k) .gt. qmin) then
- qcs (i, k) = betas * dpg * qms (i, k) * 1.0e3
- lambdas = exp (0.25 * log (pi * rhos * n0s / qms (i, k) / rho))
- res (i, k) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6
- res (i, k) = max (resmin, min (resmax, res (i, k)))
- else
- qcs (i, k) = 0.0
- res (i, k) = resmin
- endif
-
- ! -----------------------------------------------------------------------
- ! graupel (lin et al., 1983)
- ! -----------------------------------------------------------------------
-
- if (qmg (i, k) .gt. qmin) then
- qcg (i, k) = betag * dpg * qmg (i, k) * 1.0e3
- lambdag = exp (0.25 * log (pi * rhog * n0g / qmg (i, k) / rho))
- reg (i, k) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6
- reg (i, k) = max (regmin, min (regmax, reg (i, k)))
- else
- qcg (i, k) = 0.0
- reg (i, k) = regmin
- endif
-
- enddo
-
- enddo
-
-end subroutine cld_eff_rad
-
-subroutine cld_eff_rad_init (input_nml_file, logunit)
-
- implicit none
-
- character (len = *), intent (in) :: input_nml_file (:)
- integer, intent (in) :: logunit
-
- logical :: exists
-
- 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 cld_eff_rad_init
-
-end module cld_eff_rad_mod
diff --git a/model/dyn_core.F90 b/model/dyn_core.F90
index 4ab79c9a0..7f7bb4688 100644
--- a/model/dyn_core.F90
+++ b/model/dyn_core.F90
@@ -59,6 +59,7 @@ module dyn_core_mod
#endif
use fv_regional_mod, only: dump_field, exch_uv, H_STAGGER, U_STAGGER, V_STAGGER
use fv_regional_mod, only: a_step, p_step, k_step, n_step
+ use fast_phys_mod, only: fast_phys
implicit none
private
@@ -89,14 +90,14 @@ 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, diss_est, time_total)
+ init_step, i_pack, end_step, diss_est, consv, te0_2d, time_total)
integer, intent(IN) :: npx
integer, intent(IN) :: npy
integer, intent(IN) :: npz
integer, intent(IN) :: ng, nq, sphum
integer, intent(IN) :: n_map, n_split
real , intent(IN) :: bdt
- real , intent(IN) :: zvir, cp, akap, grav
+ real , intent(IN) :: zvir, cp, akap, grav, consv
real , intent(IN) :: ptop
logical, intent(IN) :: hydrostatic
logical, intent(IN) :: init_step, end_step
@@ -141,6 +142,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
real, intent(inout):: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
real, intent(inout), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: ua, va
real, intent(inout):: q_con(bd%isd:, bd%jsd:, 1:)
+ real, intent(inout):: te0_2d(bd%is:bd%ie,bd%js:bd%je)
! The Flux capacitors: accumulated Mass flux arrays
real, intent(inout):: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
@@ -388,6 +390,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
if (test_case==9) call case9_forcing1(phis, time_total, isd, ied, jsd, jed)
#endif
+
if ( it==1 ) then
call timing_on('COMM_TOTAL')
call complete_group_halo_update(i_pack(1), domain)
@@ -900,12 +903,12 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
if ( flagstruct%fv_debug ) then
if ( .not. flagstruct%hydrostatic ) then
call prt_mxm('delz updated', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain)
- call prt_maxmin('WS', ws, is, ie, js, je, 0, 1, 1.)
+ call prt_mxm('WS', ws, is, ie, js, je, 0, 1, 1., gridstruct%area_64, domain)
endif
endif
if (idiag%id_ws>0 .and. last_step) then
-! call prt_maxmin('WS', ws, is, ie, js, je, 0, 1, 1.)
+! call prt_mxm('WS', ws, is, ie, js, je, 0, 1, 1., gridstruct%area_64, domain)
used=send_data(idiag%id_ws, ws, fv_time)
endif
@@ -1078,6 +1081,72 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
endif
!-------------------------------------------------------------------------------------------------------
+!-----------------------------------------------------------------------
+! Fast Physics >>>
+!-----------------------------------------------------------------------
+
+ if (flagstruct%do_fast_phys) then
+
+ call timing_on('COMM_TOTAL')
+ call start_group_halo_update(i_pack(1), delp, domain, complete=.false.)
+ call start_group_halo_update(i_pack(1), pt, domain, complete=.true.)
+ call start_group_halo_update(i_pack(7), w, domain)
+ call start_group_halo_update(i_pack(8), u, v, domain, gridtype=DGRID_NE)
+ call start_group_halo_update(i_pack(10), q, domain)
+ call start_group_halo_update(i_pack(11), q_con, domain)
+ call start_group_halo_update(i_pack(12), cappa, domain)
+ call complete_group_halo_update(i_pack(1), domain)
+ call complete_group_halo_update(i_pack(7), domain)
+ call complete_group_halo_update(i_pack(8), domain)
+ call complete_group_halo_update(i_pack(10), domain)
+ call complete_group_halo_update(i_pack(11), domain)
+ call complete_group_halo_update(i_pack(12), domain)
+ call timing_off('COMM_TOTAL')
+
+ call fast_phys (is, ie, js, je, isd, ied, jsd, jed, npz, npx, npy, nq, &
+ flagstruct%c2l_ord, dt, consv, akap, ptop, phis, te0_2d, u, v, w, pt, &
+ delp, delz, q_con, cappa, q, pkz, zvir, flagstruct%te_err, flagstruct%tw_err, &
+ gridstruct, domain, bd, hydrostatic, do_adiabatic_init, &
+ flagstruct%consv_checker, flagstruct%adj_mass_vmr)
+
+ call timing_on('COMM_TOTAL')
+ call start_group_halo_update(i_pack(1), delp, domain, complete=.false.)
+ call start_group_halo_update(i_pack(1), pt, domain, complete=.true.)
+ call start_group_halo_update(i_pack(7), w, domain)
+ call start_group_halo_update(i_pack(8), u, v, domain, gridtype=DGRID_NE)
+ call start_group_halo_update(i_pack(10), q, domain)
+ call start_group_halo_update(i_pack(11), q_con, domain)
+ call start_group_halo_update(i_pack(12), cappa, domain)
+ call complete_group_halo_update(i_pack(1), domain)
+ call complete_group_halo_update(i_pack(7), domain)
+ call complete_group_halo_update(i_pack(8), domain)
+ call complete_group_halo_update(i_pack(10), domain)
+ call complete_group_halo_update(i_pack(11), domain)
+ call complete_group_halo_update(i_pack(12), domain)
+ call timing_off('COMM_TOTAL')
+
+ if (remap_step) then
+ pe (is:ie, 1, js:je) = ptop
+ peln (is:ie, 1, js:je) = log (pe (is:ie, 1, js:je))
+ pk (is:ie, js:je, 1) = exp (akap * peln (is:ie, 1, js:je))
+ do k = 2, npz + 1
+ do j = js, je
+ 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 (akap * peln (i, k, j))
+ enddo
+ enddo
+ enddo
+ call pe_halo (is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, delp)
+ endif
+
+ endif
+
+!-----------------------------------------------------------------------
+! <<< Fast Physics
+!-----------------------------------------------------------------------
+
call timing_on('COMM_TOTAL')
if( it==n_split .and. gridstruct%grid_type<4 .and. .not. gridstruct%bounded_domain) then
! Prevent accumulation of rounding errors at overlapped domain edges:
@@ -1099,6 +1168,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
if ( .not. flagstruct%regional .and. it/=n_split) &
call start_group_halo_update(i_pack(8), u, v, domain, gridtype=DGRID_NE)
#endif
+
call timing_off('COMM_TOTAL')
#ifdef SW_DYNAMICS
@@ -1213,7 +1283,6 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
allocated(heat_source), npz, nq, sphum, flagstruct%nwat, zvir, ptop, hydrostatic, bd, fv_time, n_map, it)
endif
-
!-----------------------------------------------------
enddo ! time split loop
!-----------------------------------------------------
@@ -1229,7 +1298,6 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
if(is_master()) write(*,*) 'End of n_split loop'
endif
-
if ( n_con/=0 .and. flagstruct%d_con > 1.e-5 ) then
nf_ke = min(3, flagstruct%nord+1)
call del2_cubed(heat_source, cnst_0p20*gridstruct%da_min, gridstruct, domain, npx, npy, npz, nf_ke, bd)
diff --git a/model/fast_phys.F90 b/model/fast_phys.F90
new file mode 100644
index 000000000..c22ccf8ad
--- /dev/null
+++ b/model/fast_phys.F90
@@ -0,0 +1,199 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! Fast Physics Interface
+! Developer: Linjiong Zhou
+! Last Update: 5/19/2022
+! =======================================================================
+
+module fast_phys_mod
+
+ use constants_mod, only: rdgas, grav
+ use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys
+ use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type
+ use mpp_domains_mod, only: domain2d, mpp_update_domains
+ use fv_timing_mod, only: timing_on, timing_off
+ use tracer_manager_mod, only: get_tracer_index, get_tracer_names
+ use field_manager_mod, only: model_atmos
+ use gfdl_mp_mod, only: mtetw
+
+ implicit none
+
+ private
+
+ real, parameter :: consv_min = 0.001
+
+ public :: fast_phys
+
+ ! -----------------------------------------------------------------------
+ ! precision definition
+ ! -----------------------------------------------------------------------
+
+ integer, parameter :: r8 = 8 ! double precision
+
+contains
+
+subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, &
+ c2l_ord, mdt, consv, akap, ptop, hs, te0_2d, u, v, w, pt, &
+ delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, &
+ gridstruct, domain, bd, hydrostatic, do_adiabatic_init, &
+ consv_checker, adj_mass_vmr)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, c2l_ord
+
+ logical, intent (in) :: hydrostatic, do_adiabatic_init, consv_checker, adj_mass_vmr
+
+ real, intent (in) :: consv, mdt, akap, r_vir, ptop, te_err, tw_err
+
+ real, intent (in), dimension (isd:ied, jsd:jed) :: hs
+
+ real, intent (inout), dimension (is:, js:, 1:) :: delz
+
+ real, intent (inout), dimension (isd:, jsd:, 1:) :: q_con, cappa, w
+
+ real, intent (inout), dimension (is:ie, js:je) :: te0_2d
+
+ real, intent (inout), dimension (isd:ied, jsd:jed, km) :: pt, delp
+
+ real, intent (inout), dimension (isd:ied, jsd:jed, km, *) :: q
+
+ real, intent (inout), dimension (isd:ied, jsd:jed+1, km) :: u
+
+ real, intent (inout), dimension (isd:ied+1, jsd:jed, km) :: v
+
+ real, intent (out), dimension (is:ie, js:je, km) :: pkz
+
+ type (fv_grid_type), intent (in), target :: gridstruct
+
+ type (fv_grid_bounds_type), intent (in) :: bd
+
+ type (domain2d), intent (inout) :: domain
+
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ logical, allocatable, dimension (:) :: conv_vmr_mmr
+
+ integer :: i, j, k, m, kmp, sphum, liq_wat, ice_wat
+ integer :: rainwat, snowwat, graupel, cld_amt, ccn_cm3, cin_cm3, aerosol
+
+ real :: rrg
+
+ real, dimension (is:ie) :: gsize
+
+ real, dimension (is:ie, km) :: q2, q3, qliq, qsol, adj_vmr
+
+ real, dimension (is:ie, km+1) :: phis, pe, peln
+
+ real, dimension (isd:ied, jsd:jed, km) :: te, ua, va
+
+ real, allocatable, dimension (:) :: wz
+
+ real, allocatable, dimension (:,:) :: dz, wa
+
+ real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0
+
+ real (kind = r8), allocatable, dimension (:) :: tz
+
+ real (kind = r8), dimension (is:ie) :: te_b_beg, te_b_end, tw_b_beg, tw_b_end, dte, te_loss
+
+ real (kind = r8), dimension (is:ie, 1:km) :: te_beg, te_end, tw_beg, tw_end
+
+ character (len = 32) :: tracer_units, tracer_name
+
+ sphum = get_tracer_index (model_atmos, 'sphum')
+ 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')
+ aerosol = get_tracer_index (model_atmos, 'aerosol')
+
+ rrg = - rdgas / grav
+
+ ! decide which tracer needs adjustment
+ if (.not. allocated (conv_vmr_mmr)) allocate (conv_vmr_mmr (nq))
+ conv_vmr_mmr (:) = .false.
+ if (adj_mass_vmr) then
+ do m = 1, nq
+ call get_tracer_names (model_atmos, m, name = tracer_name, units = tracer_units)
+ if (trim (tracer_units) .eq. 'vmr') then
+ conv_vmr_mmr (m) = .true.
+ else
+ conv_vmr_mmr (m) = .false.
+ endif
+ enddo
+ endif
+
+ !-----------------------------------------------------------------------
+ ! pt conversion
+ !-----------------------------------------------------------------------
+
+ do k = 1, km
+ do j = js, je
+ do i = is, ie
+#ifdef MOIST_CAPPA
+ pt (i, j, k) = pt (i, j, k) * exp (cappa (i, j, k) / (1. - cappa (i, j, k)) * &
+ log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k)))
+#else
+ pt (i, j, k) = pt (i, j, k) * exp (akap / (1 - akap) * &
+ log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k)))
+#endif
+ enddo
+ enddo
+ enddo
+
+ !-----------------------------------------------------------------------
+ ! pt conversion
+ !-----------------------------------------------------------------------
+
+ do k = 1, km
+ do j = js, je
+ do i = is, ie
+#ifdef MOIST_CAPPA
+ pkz (i, j, k) = exp (cappa (i, j, k) * &
+ log (rrg * delp (i, j, k) / &
+ delz (i, j, k) * pt (i, j, k)))
+#else
+ pkz (i, j, k) = exp (akap * &
+ log (rrg * delp (i, j, k) / &
+ delz (i, j, k) * pt (i, j, k)))
+#endif
+ pt (i, j, k) = pt (i, j, k) / pkz (i, j, k)
+ enddo
+ enddo
+ enddo
+
+end subroutine fast_phys
+
+end module fast_phys_mod
diff --git a/model/fast_sat_adj.F90 b/model/fast_sat_adj.F90
deleted file mode 100644
index 3abda323a..000000000
--- a/model/fast_sat_adj.F90
+++ /dev/null
@@ -1,1168 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-! =======================================================================
-! 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 fast_sat_adj_mod
-
- use fv_arrays_mod, only: r_grid
- 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 fast_sat_adj, qsmith_init
- public wqs2_vect, qs_table, qs_tablew, qs_table2, wqs1, iqs1, wqs2, iqs2
-
- real, parameter :: lv0 = hlv - dc_vap * t_ice
- real, parameter :: li00 = hlf - dc_ice * t_ice
-
- 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 (:)
-
- logical :: mp_initialized = .false.
-
-contains
-
-! =======================================================================
-! fast saturation adjustments
-! this is designed for single - moment 6 - class cloud microphysics schemes
-! handles the heat release due to in situ phase changes.
-! =======================================================================
-
-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
-
- logical, intent (in) :: hydrostatic, consv_te, out_dt, last_step
-
- integer, intent (in) :: is, ie, js, je, ng
-
- real, intent (in) :: mdt
-
- 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: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, 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 (inout), dimension (is - ng:ie + ng, js - ng:je + ng) :: qa, te, qnl, qni
-
- 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, ccn, cin
-
- 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, c_air, c_vap, dw
-
- integer :: i, j
-
- sdt = 0.5 * mdt
- dt_bigg = mdt
-
- ! -----------------------------------------------------------------------
- ! conversion scalar / factor
- ! -----------------------------------------------------------------------
-
- fac_i2s = 1. - exp (- mdt / tau_i2s)
- 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)
-
- fac_imlt = 1. - exp (- sdt / tau_imlt)
- fac_smlt = 1. - exp (- mdt / tau_smlt)
-
- ! -----------------------------------------------------------------------
- ! heat capacity of dry air and water vapor based on hydrostatical property
- ! -----------------------------------------------------------------------
-
- if (hydrostatic) then
- c_air = cp_air
- c_vap = cp_vap
- else
- c_air = cv_air
- c_vap = cv_vap
- endif
- d0_vap = c_vap - c_liq
- lv00 = hlv - d0_vap * t_ice
-
- lat2 = (hlv + hlf) ** 2
-
- 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 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)
- qpz (i) = qpz (i) + qv (i, j)
- enddo
-
- ! -----------------------------------------------------------------------
- ! moist air density based on hydrostatical property
- ! -----------------------------------------------------------------------
-
- if (hydrostatic) then
- do i = is, ie
- den (i) = delp (i, j) / (dpln (i, j) * rdgas * pt (i, j))
- enddo
- else
- do i = is, ie
- den (i) = - delp (i, j) / (grav * delz (i, j))
- enddo
- endif
-
- ! -----------------------------------------------------------------------
- ! 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
- 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
-
- ! -----------------------------------------------------------------------
- ! for energy fixer
- ! -----------------------------------------------------------------------
-
- if (consv_te) then
- if (hydrostatic) then
- do i = is, ie
- te (i, j) = - c_air * t0 (i)
- enddo
- else
- do i = is, ie
-#ifdef MOIST_CAPPA
- te (i, j) = - cvm (i) * t0 (i)
-#else
- 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
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- if (qi (i, j) < 0.) then
- qs (i, j) = qs (i, j) + qi (i, j)
- qi (i, j) = 0.
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! melting of cloud ice to cloud water and rain
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- 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
- pt1 (i) = pt1 (i) - sink (i) * lhi (i) / cvm (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- lhi (i) = li00 + dc_ice * pt1 (i)
- icp2 (i) = lhi (i) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! fix negative snow with graupel or graupel with available snow
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- if (qs (i, j) < 0.) then
- qg (i, j) = qg (i, j) + qs (i, j)
- qs (i, j) = 0.
- elseif (qg (i, j) < 0.) then
- tmp = min (- qg (i, j), max (0., qs (i, j)))
- qg (i, j) = qg (i, j) + tmp
- qs (i, j) = qs (i, j) - tmp
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! fix negative cloud water with rain or rain with available cloud water
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- if (ql (i, j) < 0.) then
- tmp = min (- ql (i, j), max (0., qr (i, j)))
- ql (i, j) = ql (i, j) + tmp
- qr (i, j) = qr (i, j) - tmp
- elseif (qr (i, j) < 0.) then
- tmp = min (- qr (i, j), max (0., ql (i, j)))
- ql (i, j) = ql (i, j) - tmp
- qr (i, j) = qr (i, j) + tmp
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! enforce complete freezing of cloud water to cloud ice below - 48 c
- ! it can be - 50 c, straka, 2009
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- qi (i, j) = qi (i, j) + sink (i)
- 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
- pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (t_ice, pt1 (i)) / 48.)
- enddo
-
- ! -----------------------------------------------------------------------
- ! condensation / evaporation between water vapor and cloud water
- ! -----------------------------------------------------------------------
-
- call wqs2_vect (is, ie, pt1, den, wqsat, dq2dt)
-
- adj_fac = sat_adj0
- do i = is, ie
- dq0 = (qv (i, j) - wqsat (i)) / (1. + tcp3 (i) * dq2dt (i))
- if (dq0 > 0.) then
- src (i) = min (adj_fac * dq0, max (ql_gen - ql (i, j), fac_v2l * dq0))
- 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)))
- src (i) = - min (ql (i, j), factor * dq0)
- endif
- qv (i, j) = qv (i, j) - src (i)
- ql (i, j) = ql (i, j) + src (i)
- q_liq (i) = q_liq (i) + src (i)
- cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
- pt1 (i) = pt1 (i) + src (i) * lhl (i) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- 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 at last time step
- ! enforce upper (no super_sat) & lower (critical rh) bounds
- ! final iteration:
- ! -----------------------------------------------------------------------
-
- call wqs2_vect (is, ie, pt1, den, wqsat, dq2dt)
-
- do i = is, ie
- dq0 = (qv (i, j) - wqsat (i)) / (1. + tcp3 (i) * dq2dt (i))
- if (dq0 > 0.) then
- src (i) = dq0
- 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)))
- src (i) = - min (ql (i, j), factor * dq0)
- endif
- adj_fac = 1.
- qv (i, j) = qv (i, j) - src (i)
- ql (i, j) = ql (i, j) + src (i)
- q_liq (i) = q_liq (i) + src (i)
- cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
- pt1 (i) = pt1 (i) + src (i) * lhl (i) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- enddo
-
- endif
-
- ! -----------------------------------------------------------------------
- ! 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)
- 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)
- qi (i, j) = qi (i, j) + sink (i)
- 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
- pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- lhi (i) = li00 + dc_ice * pt1 (i)
- icp2 (i) = lhi (i) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! bigg mechanism (heterogeneous freezing of cloud water to cloud ice)
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- tc = t_ice - pt1 (i)
- if (ql (i, j) > 0.0 .and. tc > 0.) then
- 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)
- 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
- pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- lhi (i) = li00 + dc_ice * pt1 (i)
- icp2 (i) = lhi (i) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! freezing of rain to graupel, complete freezing below - 40 c
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- 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)
- 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
- pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- lhi (i) = li00 + dc_ice * pt1 (i)
- icp2 (i) = lhi (i) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! melting of snow to rain or cloud water, complete melting above 10 c
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- sink (i) = min (tmp, fac_smlt * dtmp / icp2 (i))
- 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)
- cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
- pt1 (i) = pt1 (i) - sink (i) * lhi (i) / cvm (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! autoconversion from cloud water to rain
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- if (ql (i, j) > ql0_max) then
- sink (i) = fac_l2r * (ql (i, j) - ql0_max)
- qr (i, j) = qr (i, j) + sink (i)
- ql (i, j) = ql (i, j) - sink (i)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- enddo
-
- ! -----------------------------------------------------------------------
- ! sublimation / deposition between water vapor and cloud ice
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- src (i) = 0.
- if (pt1 (i) < t_sub) then
- src (i) = dim (qv (i, j), 1.e-6)
- 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
- 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
- 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
- pidep = pidep * min (1., dim (pt1 (i), t_sub) * 0.2)
- src (i) = max (pidep, sink (i), - qi (i, j))
- endif
- endif
- qv (i, j) = qv (i, j) - src (i)
- qi (i, j) = qi (i, j) + src (i)
- q_sol (i) = q_sol (i) + src (i)
- cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice
- pt1 (i) = pt1 (i) + src (i) * (lhl (i) + lhi (i)) / cvm (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! fix negative graupel with available cloud ice
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- if (qg (i, j) < 0.) then
- tmp = min (- qg (i, j), max (0., qi (i, j)))
- qg (i, j) = qg (i, j) + tmp
- qi (i, j) = qi (i, j) - tmp
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! autoconversion from cloud ice to snow
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- qim = qi0_max / den (i)
- if (qi (i, j) > qim) then
- sink (i) = fac_i2s * (qi (i, j) - qim)
- qi (i, j) = qi (i, j) - sink (i)
- qs (i, j) = qs (i, j) + sink (i)
- 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)
- enddo
- endif
-
- ! -----------------------------------------------------------------------
- ! for energy fixer
- ! -----------------------------------------------------------------------
-
- if (consv_te) then
- do i = is, ie
- if (hydrostatic) then
- te (i, j) = delp (i, j) * (te (i, j) + c_air * pt1 (i))
- else
-#ifdef MOIST_CAPPA
- te (i, j) = delp (i, j) * (te (i, j) + cvm (i) * pt1 (i))
-#else
- te (i, j) = delp (i, j) * (te (i, j) + c_air * pt1 (i))
-#endif
- endif
- enddo
- endif
-
- ! -----------------------------------------------------------------------
- ! update latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do i = is, ie
- 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)
- enddo
-
- ! -----------------------------------------------------------------------
- ! compute cloud fraction
- ! -----------------------------------------------------------------------
-
- if (do_qa .and. last_step) then
-
- ! -----------------------------------------------------------------------
- ! combine water species
- ! -----------------------------------------------------------------------
-
- if (rad_snow) then
- if (rad_graupel) then
- do i = is, ie
- q_sol (i) = qi (i, j) + qs (i, j) + qg (i, j)
- enddo
- else
- do i = is, ie
- q_sol (i) = qi (i, j) + qs (i, j)
- enddo
- endif
- else
- do i = is, ie
- q_sol (i) = qi (i, j)
- enddo
- endif
- if (rad_rain) then
- do i = is, ie
- q_liq (i) = ql (i, j) + qr (i, j)
- enddo
- else
- do i = is, ie
- q_liq (i) = ql (i, j)
- enddo
- endif
- do i = is, ie
- q_cond (i) = q_sol (i) + q_liq (i)
- enddo
-
- ! -----------------------------------------------------------------------
- ! 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))
-
- ! -----------------------------------------------------------------------
- ! compute saturated specific humidity
- ! -----------------------------------------------------------------------
-
- if (tin <= t_wfr) then
- qstar (i) = iqs1 (tin, den (i))
- elseif (tin >= t_ice) then
- qstar (i) = wqs1 (tin, den (i))
- else
- 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
- rqi = ((t_ice - tin) / (t_ice - t_wfr))
- endif
- qstar (i) = rqi * qsi + (1. - rqi) * qsw
- endif
-
- ! -----------------------------------------------------------------------
- ! compute sub - grid variability
- ! -----------------------------------------------------------------------
-
- dw = dw_ocean + (dw_land - dw_ocean) * min (1., abs (hs (i, j)) / (10. * grav))
- 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 == qpz;
- ! -----------------------------------------------------------------------
-
- rh = qpz (i) / qstar (i)
-
- ! -----------------------------------------------------------------------
- ! icloud_f = 0: bug - fxied
- ! icloud_f = 1: old fvgfs gfdl_mp implementation
- ! icloud_f = 2: binary cloud scheme (0 / 1)
- ! -----------------------------------------------------------------------
-
- if (rh > 0.75 .and. qpz (i) > 1.e-6) then
- dq = hvar (i) * qpz (i)
- q_plus = qpz (i) + dq
- q_minus = qpz (i) - dq
- if (icloud_f == 2) then
- if (qpz (i) > qstar (i)) then
- qa (i, j) = 1.
- elseif (qstar (i) < q_plus .and. q_cond (i) > 1.e-6) then
- qa (i, j) = ((q_plus - qstar (i)) / dq) ** 2
- qa (i, j) = min (1., qa (i, j))
- else
- qa (i, j) = 0.
- endif
- else
- if (qstar (i) < q_minus) then
- qa (i, j) = 1.
- else
- if (qstar (i) < q_plus) then
- 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)))
- endif
- else
- qa (i, j) = 0.
- endif
- if (q_cond (i) > 1.e-6) then
- qa (i, j) = max (cld_min, qa (i, j))
- endif
- qa (i, j) = min (1., qa (i, j))
- endif
- endif
- else
- qa (i, j) = 0.
- endif
-
- enddo
-
- endif
-
- 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 fast_sat_adj
-
-! =======================================================================
-! 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 = t_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 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 = t_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 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 = t_ice - 160.
- 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 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, intent (in) :: ta, den
-
- real, intent (out) :: dqdt
-
- real :: es, ap1, tmin
-
- integer :: it
-
- tmin = t_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
- ! finite diff, del_t = 0.1:
- dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den)
-
-end function iqs2
-
-! =======================================================================
-! initialization
-! prepare saturation water vapor pressure tables
-! =======================================================================
-
-subroutine qsmith_init
-
- implicit none
-
- integer, parameter :: length = 2621
-
- integer :: i
-
- if (mp_initialized) return
-
- ! generate es table (dt = 0.1 deg c)
-
- allocate (table (length))
- allocate (table2 (length))
- allocate (tablew (length))
- allocate (des2 (length))
- allocate (desw (length))
-
- call qs_table (length)
- call qs_table2 (length)
- call qs_tablew (length)
-
- do i = 1, length - 1
- des2 (i) = max (0., table2 (i + 1) - table2 (i))
- desw (i) = max (0., tablew (i + 1) - tablew (i))
- enddo
- des2 (length) = des2 (length - 1)
- desw (length) = desw (length - 1)
-
- mp_initialized = .true.
-
-end subroutine qsmith_init
-
-! =======================================================================
-! saturation water vapor pressure table i
-! 3 - phase table
-! =======================================================================
-
-subroutine qs_table (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- 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
-
- tmin = t_ice - 160.
-
- ! -----------------------------------------------------------------------
- ! compute es over ice between - 160 deg c and 0 deg c.
- ! -----------------------------------------------------------------------
-
- do i = 1, 1600
- tem = tmin + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * li2
- fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas
- table (i) = e00 * exp (fac2)
- enddo
-
- ! -----------------------------------------------------------------------
- ! compute es over water between - 20 deg c and 102 deg c.
- ! -----------------------------------------------------------------------
-
- do i = 1, 1221
- tem = 253.16 + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
- esh20 = e00 * exp (fac2)
- if (i <= 200) then
- esupc (i) = esh20
- else
- table (i + 1400) = esh20
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! derive blended es over ice and supercooled water between - 20 deg c and 0 deg c
- ! -----------------------------------------------------------------------
-
- do i = 1, 200
- tem = 253.16 + delt * real (i - 1)
- wice = 0.05 * (t_ice - tem)
- wh2o = 0.05 * (tem - 253.16)
- table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i)
- enddo
-
-end subroutine qs_table
-
-! =======================================================================
-! saturation water vapor pressure table ii
-! 1 - phase table
-! =======================================================================
-
-subroutine qs_tablew (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real (kind = r_grid) :: delt = 0.1
- real (kind = r_grid) :: tmin, tem, fac0, fac1, fac2
-
- integer :: i
-
- tmin = t_ice - 160.
-
- ! -----------------------------------------------------------------------
- ! compute es over water
- ! -----------------------------------------------------------------------
-
- do i = 1, n
- tem = tmin + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
- tablew (i) = e00 * exp (fac2)
- enddo
-
-end subroutine qs_tablew
-
-! =======================================================================
-! saturation water vapor pressure table iii
-! 2 - phase table
-! =======================================================================
-
-subroutine qs_table2 (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real (kind = r_grid) :: delt = 0.1
- real (kind = r_grid) :: tmin, tem0, tem1, fac0, fac1, fac2
-
- integer :: i, i0, i1
-
- tmin = t_ice - 160.
-
- do i = 1, n
- tem0 = tmin + delt * real (i - 1)
- 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 / 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 / t_ice) + fac1) / rvgas
- endif
- table2 (i) = e00 * exp (fac2)
- enddo
-
- ! -----------------------------------------------------------------------
- ! smoother around 0 deg c
- ! -----------------------------------------------------------------------
-
- i0 = 1600
- i1 = 1601
- tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1))
- tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1))
- table2 (i0) = tem0
- table2 (i1) = tem1
-
-end subroutine qs_table2
-
-end module fast_sat_adj_mod
diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90
index 8b1cb3b40..630489a7a 100644
--- a/model/fv_arrays.F90
+++ b/model/fv_arrays.F90
@@ -55,8 +55,8 @@ module fv_arrays_mod
real, allocatable :: zxg(:,:)
- 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
+ integer :: id_u_dt_sg, id_v_dt_sg, id_t_dt_sg, id_qv_dt_sg, id_diss
+ integer :: id_ws, id_te, id_amdt, id_divg, id_aam
logical :: initialized = .false.
real :: efx(max_step), efx_sum, efx_nest(max_step), efx_sum_nest, mtq(max_step), mtq_sum
@@ -361,9 +361,15 @@ module fv_arrays_mod
logical :: do_sat_adj= .false. !< Controls split GFDL Microphysics. .false. by default. Must have the same
!< value as do_sat_adj in gfdl_mp_nml. Not compatible with other microphysics
!< schemes. Also requires GFDL microphysics be installed within the physics driver.
+ logical :: consv_checker = .false.!< turn on energy and water conservation checker
+ logical :: do_fast_phys = .false.!< Controls fast physics, in which the SA-TKE-EDMF and part of the GWD are
+ !< within the acoustic time step of FV3. If .true. disabling the SA-TKE-EDMF
+ !< and part of the GWD in the intermediate physics.
logical :: do_inline_mp = .false.!< Controls Inline GFDL cloud microphysics, in which the full microphysics is
!< called entirely within FV3. If .true. disabling microphysics within the physics
!< is very strongly recommended. .false. by default.
+ logical :: do_aerosol = .false. !< Controls climatological aerosol data used in the GFDL cloud microphyiscs.
+ !< .false. by default.
logical :: do_f3d = .false. !
logical :: no_dycore = .false. !< Disables execution of the dynamical core, only running
!< the initialization, diagnostic, and I/O routines, and
@@ -684,6 +690,8 @@ module fv_arrays_mod
!< considered; and for non-hydrostatic models values of 10 or less should be
!< considered, with smaller values for higher-resolution.
real :: rf_cutoff = 30.E2 !< Pressure below which no Rayleigh damping is applied if tau > 0.
+ real :: te_err = 1.e-5 !< 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time
+ real :: tw_err = 1.e-8 !< 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time
logical :: filter_phys = .false.
logical :: dwind_2d = .false. !< Whether to use a simpler & faster algorithm for interpolating
!< the A-grid (cell-centered) wind tendencies computed from the physics
@@ -904,7 +912,8 @@ module fv_arrays_mod
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
-
+ logical :: restart_from_agrid_winds = .false. !< Whether to restart from A-grid winds
+ logical :: write_optional_dgrid_vel_rst = .true. !< Whether to write out optional D-grid winds when restart_from_agrid_winds is active
end type fv_flags_type
type fv_nest_BC_type_3D
@@ -1027,15 +1036,48 @@ module fv_arrays_mod
end type fv_nest_type
type inline_mp_type
+
+ real, _ALLOCATABLE :: prew(:,:) _NULL
real, _ALLOCATABLE :: prer(:,:) _NULL
real, _ALLOCATABLE :: prei(:,:) _NULL
real, _ALLOCATABLE :: pres(:,:) _NULL
real, _ALLOCATABLE :: preg(:,:) _NULL
+ real, _ALLOCATABLE :: prefluxw(:,:,:) _NULL
+ real, _ALLOCATABLE :: prefluxr(:,:,:) _NULL
+ real, _ALLOCATABLE :: prefluxi(:,:,:) _NULL
+ real, _ALLOCATABLE :: prefluxs(:,:,:) _NULL
+ real, _ALLOCATABLE :: prefluxg(:,:,:) _NULL
real, _ALLOCATABLE :: cond(:,:) _NULL
real, _ALLOCATABLE :: dep(:,:) _NULL
real, _ALLOCATABLE :: reevap(:,:) _NULL
real, _ALLOCATABLE :: sub(:,:) _NULL
+ real, _ALLOCATABLE :: pcw(:,:,:) _NULL
+ real, _ALLOCATABLE :: edw(:,:,:) _NULL
+ real, _ALLOCATABLE :: oew(:,:,:) _NULL
+ real, _ALLOCATABLE :: rrw(:,:,:) _NULL
+ real, _ALLOCATABLE :: tvw(:,:,:) _NULL
+ real, _ALLOCATABLE :: pci(:,:,:) _NULL
+ real, _ALLOCATABLE :: edi(:,:,:) _NULL
+ real, _ALLOCATABLE :: oei(:,:,:) _NULL
+ real, _ALLOCATABLE :: rri(:,:,:) _NULL
+ real, _ALLOCATABLE :: tvi(:,:,:) _NULL
+ real, _ALLOCATABLE :: pcr(:,:,:) _NULL
+ real, _ALLOCATABLE :: edr(:,:,:) _NULL
+ real, _ALLOCATABLE :: oer(:,:,:) _NULL
+ real, _ALLOCATABLE :: rrr(:,:,:) _NULL
+ real, _ALLOCATABLE :: tvr(:,:,:) _NULL
+ real, _ALLOCATABLE :: pcs(:,:,:) _NULL
+ real, _ALLOCATABLE :: eds(:,:,:) _NULL
+ real, _ALLOCATABLE :: oes(:,:,:) _NULL
+ real, _ALLOCATABLE :: rrs(:,:,:) _NULL
+ real, _ALLOCATABLE :: tvs(:,:,:) _NULL
+ real, _ALLOCATABLE :: pcg(:,:,:) _NULL
+ real, _ALLOCATABLE :: edg(:,:,:) _NULL
+ real, _ALLOCATABLE :: oeg(:,:,:) _NULL
+ real, _ALLOCATABLE :: rrg(:,:,:) _NULL
+ real, _ALLOCATABLE :: tvg(:,:,:) _NULL
+
real, _ALLOCATABLE :: qv_dt(:,:,:)
real, _ALLOCATABLE :: ql_dt(:,:,:)
real, _ALLOCATABLE :: qi_dt(:,:,:)
@@ -1047,6 +1089,7 @@ module fv_arrays_mod
real, _ALLOCATABLE :: t_dt(:,:,:)
real, _ALLOCATABLE :: u_dt(:,:,:)
real, _ALLOCATABLE :: v_dt(:,:,:)
+
end type inline_mp_type
type phys_diag_type
@@ -1489,14 +1532,45 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie
allocate ( Atm%ak(npz_2d+1) )
allocate ( Atm%bk(npz_2d+1) )
+ allocate ( Atm%inline_mp%prew(is:ie,js:je) )
allocate ( Atm%inline_mp%prer(is:ie,js:je) )
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%prefluxw(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%prefluxr(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%prefluxi(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%prefluxs(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%prefluxg(is:ie,js:je,npz) )
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) )
+ allocate ( Atm%inline_mp%pcw(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%edw(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%oew(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%rrw(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%tvw(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%pci(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%edi(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%oei(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%rri(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%tvi(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%pcr(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%edr(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%oer(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%rrr(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%tvr(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%pcs(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%eds(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%oes(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%rrs(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%tvs(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%pcg(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%edg(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%oeg(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%rrg(is:ie,js:je,npz) )
+ allocate ( Atm%inline_mp%tvg(is:ie,js:je,npz) )
!--------------------------
! Non-hydrostatic dynamics:
@@ -1577,14 +1651,45 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie
enddo
do j=js, je
do i=is, ie
+ Atm%inline_mp%prew(i,j) = real_big
Atm%inline_mp%prer(i,j) = real_big
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%prefluxw(i,j,:) = real_big
+ Atm%inline_mp%prefluxr(i,j,:) = real_big
+ Atm%inline_mp%prefluxi(i,j,:) = real_big
+ Atm%inline_mp%prefluxs(i,j,:) = real_big
+ Atm%inline_mp%prefluxg(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%inline_mp%pcw(i,j,:) = real_big
+ Atm%inline_mp%edw(i,j,:) = real_big
+ Atm%inline_mp%oew(i,j,:) = real_big
+ Atm%inline_mp%rrw(i,j,:) = real_big
+ Atm%inline_mp%tvw(i,j,:) = real_big
+ Atm%inline_mp%pci(i,j,:) = real_big
+ Atm%inline_mp%edi(i,j,:) = real_big
+ Atm%inline_mp%oei(i,j,:) = real_big
+ Atm%inline_mp%rri(i,j,:) = real_big
+ Atm%inline_mp%tvi(i,j,:) = real_big
+ Atm%inline_mp%pcr(i,j,:) = real_big
+ Atm%inline_mp%edr(i,j,:) = real_big
+ Atm%inline_mp%oer(i,j,:) = real_big
+ Atm%inline_mp%rrr(i,j,:) = real_big
+ Atm%inline_mp%tvr(i,j,:) = real_big
+ Atm%inline_mp%pcs(i,j,:) = real_big
+ Atm%inline_mp%eds(i,j,:) = real_big
+ Atm%inline_mp%oes(i,j,:) = real_big
+ Atm%inline_mp%rrs(i,j,:) = real_big
+ Atm%inline_mp%tvs(i,j,:) = real_big
+ Atm%inline_mp%pcg(i,j,:) = real_big
+ Atm%inline_mp%edg(i,j,:) = real_big
+ Atm%inline_mp%oeg(i,j,:) = real_big
+ Atm%inline_mp%rrg(i,j,:) = real_big
+ Atm%inline_mp%tvg(i,j,:) = real_big
Atm%ts(i,j) = 300.
@@ -1835,14 +1940,45 @@ subroutine deallocate_fv_atmos_type(Atm)
deallocate ( Atm%bk )
deallocate ( Atm%diss_est )
+ deallocate ( Atm%inline_mp%prew )
deallocate ( Atm%inline_mp%prer )
deallocate ( Atm%inline_mp%prei )
deallocate ( Atm%inline_mp%pres )
deallocate ( Atm%inline_mp%preg )
+ deallocate ( Atm%inline_mp%prefluxw )
+ deallocate ( Atm%inline_mp%prefluxr )
+ deallocate ( Atm%inline_mp%prefluxi )
+ deallocate ( Atm%inline_mp%prefluxs )
+ deallocate ( Atm%inline_mp%prefluxg )
deallocate ( Atm%inline_mp%cond )
deallocate ( Atm%inline_mp%dep )
deallocate ( Atm%inline_mp%reevap )
deallocate ( Atm%inline_mp%sub )
+ deallocate ( Atm%inline_mp%pcw )
+ deallocate ( Atm%inline_mp%edw )
+ deallocate ( Atm%inline_mp%oew )
+ deallocate ( Atm%inline_mp%rrw )
+ deallocate ( Atm%inline_mp%tvw )
+ deallocate ( Atm%inline_mp%pci )
+ deallocate ( Atm%inline_mp%edi )
+ deallocate ( Atm%inline_mp%oei )
+ deallocate ( Atm%inline_mp%rri )
+ deallocate ( Atm%inline_mp%tvi )
+ deallocate ( Atm%inline_mp%pcr )
+ deallocate ( Atm%inline_mp%edr )
+ deallocate ( Atm%inline_mp%oer )
+ deallocate ( Atm%inline_mp%rrr )
+ deallocate ( Atm%inline_mp%tvr )
+ deallocate ( Atm%inline_mp%pcs )
+ deallocate ( Atm%inline_mp%eds )
+ deallocate ( Atm%inline_mp%oes )
+ deallocate ( Atm%inline_mp%rrs )
+ deallocate ( Atm%inline_mp%tvs )
+ deallocate ( Atm%inline_mp%pcg )
+ deallocate ( Atm%inline_mp%edg )
+ deallocate ( Atm%inline_mp%oeg )
+ deallocate ( Atm%inline_mp%rrg )
+ deallocate ( Atm%inline_mp%tvg )
deallocate ( Atm%u_srf )
deallocate ( Atm%v_srf )
diff --git a/model/fv_control.F90 b/model/fv_control.F90
index 2f2563226..da16bab92 100644
--- a/model/fv_control.F90
+++ b/model/fv_control.F90
@@ -165,7 +165,10 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
logical , pointer :: RF_fast
logical , pointer :: consv_am
logical , pointer :: do_sat_adj
+ logical , pointer :: consv_checker
+ logical , pointer :: do_fast_phys
logical , pointer :: do_inline_mp
+ logical , pointer :: do_aerosol
logical , pointer :: do_f3d
logical , pointer :: no_dycore
logical , pointer :: convert_ke
@@ -230,6 +233,8 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
real , pointer :: consv_te
real , pointer :: tau
real , pointer :: rf_cutoff
+ real , pointer :: te_err
+ real , pointer :: tw_err
logical , pointer :: filter_phys
logical , pointer :: dwind_2d
logical , pointer :: breed_vortex_inline
@@ -304,6 +309,8 @@ 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 :: restart_from_agrid_winds
+ logical, pointer :: write_optional_dgrid_vel_rst
logical, pointer :: pass_full_omega_to_physics_in_non_hydrostatic_mode
!!!!!!!!!! END POINTERS !!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -692,7 +699,10 @@ subroutine set_namelist_pointers(Atm)
RF_fast => Atm%flagstruct%RF_fast
consv_am => Atm%flagstruct%consv_am
do_sat_adj => Atm%flagstruct%do_sat_adj
+ consv_checker => Atm%flagstruct%consv_checker
+ do_fast_phys => Atm%flagstruct%do_fast_phys
do_inline_mp => Atm%flagstruct%do_inline_mp
+ do_aerosol => Atm%flagstruct%do_aerosol
do_f3d => Atm%flagstruct%do_f3d
no_dycore => Atm%flagstruct%no_dycore
convert_ke => Atm%flagstruct%convert_ke
@@ -754,6 +764,8 @@ subroutine set_namelist_pointers(Atm)
consv_te => Atm%flagstruct%consv_te
tau => Atm%flagstruct%tau
rf_cutoff => Atm%flagstruct%rf_cutoff
+ te_err => Atm%flagstruct%te_err
+ tw_err => Atm%flagstruct%tw_err
filter_phys => Atm%flagstruct%filter_phys
dwind_2d => Atm%flagstruct%dwind_2d
breed_vortex_inline => Atm%flagstruct%breed_vortex_inline
@@ -836,6 +848,8 @@ 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
+ restart_from_agrid_winds => Atm%flagstruct%restart_from_agrid_winds
+ write_optional_dgrid_vel_rst => Atm%flagstruct%write_optional_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
@@ -907,8 +921,8 @@ 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, remap_te, fv_debug, fv_land, &
- do_am4_remap, nudge, do_sat_adj, do_inline_mp, do_f3d, &
+ kord_mt, kord_wz, kord_tm, kord_tr, remap_te, fv_debug, fv_land, consv_checker, &
+ do_am4_remap, nudge, do_sat_adj, do_fast_phys, do_inline_mp, do_aerosol, 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, &
@@ -916,7 +930,7 @@ subroutine read_namelist_fv_core_nml(Atm)
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, &
+ tau, tau_h2o, rf_cutoff, te_err, tw_err, nf_omega, hydrostatic, fv_sg_adj, sg_cutoff, breed_vortex_inline, &
na_init, nudge_dz, hybrid_z, Make_NH, n_zs_filter, nord_zs_filter, full_zs_filter, reset_eta, &
pnats, dnats, dnrts, a2b_ord, remap_t, p_ref, d2_bg_k1, d2_bg_k2, &
c2l_ord, dx_const, dy_const, umax, deglat, &
@@ -930,6 +944,7 @@ subroutine read_namelist_fv_core_nml(Atm)
w_limiter, write_coarse_restart_files, write_coarse_diagnostics,&
write_only_coarse_intermediate_restarts, &
write_coarse_agrid_vel_rst, write_coarse_dgrid_vel_rst, &
+ restart_from_agrid_winds, write_optional_dgrid_vel_rst, &
pass_full_omega_to_physics_in_non_hydrostatic_mode, ignore_rst_cksum
diff --git a/model/fv_dynamics.F90 b/model/fv_dynamics.F90
index 597448129..cfc257055 100644
--- a/model/fv_dynamics.F90
+++ b/model/fv_dynamics.F90
@@ -44,7 +44,8 @@ module fv_dynamics_mod
use fv_regional_mod, only: a_step, p_step, k_step
use fv_regional_mod, only: current_time_in_seconds
use boundary_mod, only: nested_grid_BC_apply_intT
- use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_atmos_type, fv_nest_type, fv_diag_type, fv_grid_bounds_type, inline_mp_type
+ use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_atmos_type, fv_nest_type, &
+ fv_diag_type, fv_grid_bounds_type, inline_mp_type
use fv_nwp_nudge_mod, only: do_adiabatic_init
implicit none
@@ -157,7 +158,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
real:: m_fac(bd%is:bd%ie,bd%js:bd%je)
real:: pfull(npz)
real, dimension(bd%is:bd%ie):: cvm
- real, allocatable :: dp1(:,:,:), dtdt_m(:,:,:), cappa(:,:,:)
+ real, allocatable :: dp1(:,:,:), cappa(:,:,:)
real:: akap, rdg, ph1, ph2, mdt, gam, amdt, u0
real:: recip_k_split,reg_bc_update_time
integer:: kord_tracer(ncnst)
@@ -408,24 +409,18 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
last_step = .false.
mdt = bdt / real(k_split)
- if ( idiag%id_mdt > 0 .and. (.not. do_adiabatic_init) ) then
- allocate ( dtdt_m(is:ie,js:je,npz) )
-!$OMP parallel do default(none) shared(is,ie,js,je,npz,dtdt_m)
- do k=1,npz
- do j=js,je
- do i=is,ie
- dtdt_m(i,j,k) = 0.
- enddo
- enddo
- enddo
- endif
-
! Initialize rain, ice, snow and graupel precipitaiton
if (flagstruct%do_inline_mp) then
+ inline_mp%prew = 0.0
inline_mp%prer = 0.0
inline_mp%prei = 0.0
inline_mp%pres = 0.0
inline_mp%preg = 0.0
+ inline_mp%prefluxw = 0.0
+ inline_mp%prefluxr = 0.0
+ inline_mp%prefluxi = 0.0
+ inline_mp%prefluxs = 0.0
+ inline_mp%prefluxg = 0.0
inline_mp%cond = 0.0
inline_mp%dep = 0.0
inline_mp%reevap = 0.0
@@ -487,7 +482,8 @@ 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, diss_est, time_total)
+ domain, n_map==1, i_pack, last_step, diss_est, &
+ consv_te, te_2d, time_total)
call timing_off('DYN_CORE')
@@ -594,15 +590,16 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
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, &
+ zvir, cp_air, flagstruct%te_err, flagstruct%tw_err, akap, cappa, flagstruct%kord_mt, flagstruct%kord_wz, &
kord_tracer, flagstruct%kord_tm, flagstruct%remap_te, peln, te_2d, &
ng, ua, va, omga, dp1, ws, fill, reproduce_sum, &
- idiag%id_mdt>0, dtdt_m, ptop, ak, bk, pfull, gridstruct, domain, &
+ ptop, ak, bk, pfull, gridstruct, domain, &
flagstruct%do_sat_adj, hydrostatic, &
hybrid_z, &
flagstruct%adiabatic, do_adiabatic_init, flagstruct%do_inline_mp, &
inline_mp, flagstruct%c2l_ord, bd, flagstruct%fv_debug, &
- flagstruct%moist_phys, flagstruct%w_limiter, flagstruct%do_am4_remap)
+ flagstruct%w_limiter, flagstruct%do_am4_remap, &
+ flagstruct%do_fast_phys, flagstruct%consv_checker, flagstruct%adj_mass_vmr)
if ( flagstruct%fv_debug ) then
if (is_master()) write(*,'(A, I3, A1, I3)') 'finished k_split ', n_map, '/', k_split
@@ -650,10 +647,16 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
! Initialize rain, ice, snow and graupel precipitaiton
if (flagstruct%do_inline_mp) then
+ inline_mp%prew = inline_mp%prew / k_split
inline_mp%prer = inline_mp%prer / k_split
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%prefluxw = inline_mp%prefluxw / k_split
+ inline_mp%prefluxr = inline_mp%prefluxr / k_split
+ inline_mp%prefluxi = inline_mp%prefluxi / k_split
+ inline_mp%prefluxs = inline_mp%prefluxs / k_split
+ inline_mp%prefluxg = inline_mp%prefluxg / 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
@@ -672,20 +675,6 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
endif
call timing_off('FV_DYN_LOOP')
- if ( idiag%id_mdt > 0 .and. (.not.do_adiabatic_init) ) then
-! Output temperature tendency due to inline moist physics:
-!$OMP parallel do default(none) shared(is,ie,js,je,npz,dtdt_m,bdt)
- do k=1,npz
- do j=js,je
- do i=is,ie
- dtdt_m(i,j,k) = dtdt_m(i,j,k) / bdt * 86400.
- enddo
- enddo
- enddo
-! call prt_mxm('Fast DTDT (deg/Day)', dtdt_m, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain)
- used = send_data(idiag%id_mdt, dtdt_m, fv_time)
- deallocate ( dtdt_m )
- endif
if( nwat==6 ) then
if (cld_amt > 0) then
diff --git a/model/fv_grid_utils.F90 b/model/fv_grid_utils.F90
index 602c30e07..18b19c901 100644
--- a/model/fv_grid_utils.F90
+++ b/model/fv_grid_utils.F90
@@ -66,7 +66,7 @@ module fv_grid_utils_mod
direct_transform, cube_transform, &
make_eta_level, expand_cell, cart_to_latlon, intp_great_circle, normalize_vect, &
dist2side_latlon, spherical_linear_interpolation, get_latlon_vector
- public symm_grid
+ public symm_grid, cubed_a2d
INTERFACE fill_ghost
#ifdef OVERLOAD_R4
@@ -3612,6 +3612,189 @@ subroutine update2d_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_
end subroutine update2d_dwinds_phys
+ subroutine cubed_a2d( npx, npy, npz, ua, va, u, v, gridstruct, fv_domain, bd )
+
+! Purpose; Transform wind on A grid to D grid
+
+ type(fv_grid_bounds_type), intent(IN) :: bd
+ integer, intent(in):: npx, npy, npz
+ real, intent(inout), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: ua, va
+ real, intent(out):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1,npz)
+ real, intent(out):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
+ type(fv_grid_type), intent(IN), target :: gridstruct
+ type(domain2d), intent(INOUT) :: fv_domain
+! local:
+ real v3(3,bd%is-1:bd%ie+1,bd%js-1:bd%je+1)
+ real ue(3,bd%is-1:bd%ie+1,bd%js:bd%je+1) ! 3D winds at edges
+ real ve(3,bd%is:bd%ie+1,bd%js-1:bd%je+1) ! 3D winds at edges
+ real, dimension(bd%is:bd%ie):: ut1, ut2, ut3
+ real, dimension(bd%js:bd%je):: vt1, vt2, vt3
+ integer i, j, k, im2, jm2
+
+ real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat
+ real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n
+ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
+
+ integer :: is, ie, js, je
+ integer :: isd, ied, jsd, jed
+
+ is = bd%is
+ ie = bd%ie
+ js = bd%js
+ je = bd%je
+ isd = bd%isd
+ ied = bd%ied
+ jsd = bd%jsd
+ jed = bd%jed
+
+ vlon => gridstruct%vlon
+ vlat => gridstruct%vlat
+
+ edge_vect_w => gridstruct%edge_vect_w
+ edge_vect_e => gridstruct%edge_vect_e
+ edge_vect_s => gridstruct%edge_vect_s
+ edge_vect_n => gridstruct%edge_vect_n
+
+ ew => gridstruct%ew
+ es => gridstruct%es
+
+ call mpp_update_domains(ua, fv_domain, complete=.false.)
+ call mpp_update_domains(va, fv_domain, complete=.true.)
+
+ im2 = (npx-1)/2
+ jm2 = (npy-1)/2
+
+ do k=1, npz
+! Compute 3D wind on A grid
+ do j=js-1,je+1
+ do i=is-1,ie+1
+ v3(1,i,j) = ua(i,j,k)*vlon(i,j,1) + va(i,j,k)*vlat(i,j,1)
+ v3(2,i,j) = ua(i,j,k)*vlon(i,j,2) + va(i,j,k)*vlat(i,j,2)
+ v3(3,i,j) = ua(i,j,k)*vlon(i,j,3) + va(i,j,k)*vlat(i,j,3)
+ enddo
+ enddo
+
+! A --> D
+! Interpolate to cell edges
+ do j=js,je+1
+ do i=is-1,ie+1
+ ue(1,i,j) = 0.5*(v3(1,i,j-1) + v3(1,i,j))
+ ue(2,i,j) = 0.5*(v3(2,i,j-1) + v3(2,i,j))
+ ue(3,i,j) = 0.5*(v3(3,i,j-1) + v3(3,i,j))
+ enddo
+ enddo
+
+ do j=js-1,je+1
+ do i=is,ie+1
+ ve(1,i,j) = 0.5*(v3(1,i-1,j) + v3(1,i,j))
+ ve(2,i,j) = 0.5*(v3(2,i-1,j) + v3(2,i,j))
+ ve(3,i,j) = 0.5*(v3(3,i-1,j) + v3(3,i,j))
+ enddo
+ enddo
+
+! --- E_W edges (for v-wind):
+ if (.not. gridstruct%bounded_domain) then
+ if ( is==1) then
+ i = 1
+ do j=js,je
+ if ( j>jm2 ) then
+ vt1(j) = edge_vect_w(j)*ve(1,i,j-1)+(1.-edge_vect_w(j))*ve(1,i,j)
+ vt2(j) = edge_vect_w(j)*ve(2,i,j-1)+(1.-edge_vect_w(j))*ve(2,i,j)
+ vt3(j) = edge_vect_w(j)*ve(3,i,j-1)+(1.-edge_vect_w(j))*ve(3,i,j)
+ else
+ vt1(j) = edge_vect_w(j)*ve(1,i,j+1)+(1.-edge_vect_w(j))*ve(1,i,j)
+ vt2(j) = edge_vect_w(j)*ve(2,i,j+1)+(1.-edge_vect_w(j))*ve(2,i,j)
+ vt3(j) = edge_vect_w(j)*ve(3,i,j+1)+(1.-edge_vect_w(j))*ve(3,i,j)
+ endif
+ enddo
+ do j=js,je
+ ve(1,i,j) = vt1(j)
+ ve(2,i,j) = vt2(j)
+ ve(3,i,j) = vt3(j)
+ enddo
+ endif
+
+ if ( (ie+1)==npx ) then
+ i = npx
+ do j=js,je
+ if ( j>jm2 ) then
+ vt1(j) = edge_vect_e(j)*ve(1,i,j-1)+(1.-edge_vect_e(j))*ve(1,i,j)
+ vt2(j) = edge_vect_e(j)*ve(2,i,j-1)+(1.-edge_vect_e(j))*ve(2,i,j)
+ vt3(j) = edge_vect_e(j)*ve(3,i,j-1)+(1.-edge_vect_e(j))*ve(3,i,j)
+ else
+ vt1(j) = edge_vect_e(j)*ve(1,i,j+1)+(1.-edge_vect_e(j))*ve(1,i,j)
+ vt2(j) = edge_vect_e(j)*ve(2,i,j+1)+(1.-edge_vect_e(j))*ve(2,i,j)
+ vt3(j) = edge_vect_e(j)*ve(3,i,j+1)+(1.-edge_vect_e(j))*ve(3,i,j)
+ endif
+ enddo
+ do j=js,je
+ ve(1,i,j) = vt1(j)
+ ve(2,i,j) = vt2(j)
+ ve(3,i,j) = vt3(j)
+ enddo
+ endif
+
+! N-S edges (for u-wind):
+ if ( js==1 ) then
+ j = 1
+ do i=is,ie
+ if ( i>im2 ) then
+ ut1(i) = edge_vect_s(i)*ue(1,i-1,j)+(1.-edge_vect_s(i))*ue(1,i,j)
+ ut2(i) = edge_vect_s(i)*ue(2,i-1,j)+(1.-edge_vect_s(i))*ue(2,i,j)
+ ut3(i) = edge_vect_s(i)*ue(3,i-1,j)+(1.-edge_vect_s(i))*ue(3,i,j)
+ else
+ ut1(i) = edge_vect_s(i)*ue(1,i+1,j)+(1.-edge_vect_s(i))*ue(1,i,j)
+ ut2(i) = edge_vect_s(i)*ue(2,i+1,j)+(1.-edge_vect_s(i))*ue(2,i,j)
+ ut3(i) = edge_vect_s(i)*ue(3,i+1,j)+(1.-edge_vect_s(i))*ue(3,i,j)
+ endif
+ enddo
+ do i=is,ie
+ ue(1,i,j) = ut1(i)
+ ue(2,i,j) = ut2(i)
+ ue(3,i,j) = ut3(i)
+ enddo
+ endif
+
+ if ( (je+1)==npy ) then
+ j = npy
+ do i=is,ie
+ if ( i>im2 ) then
+ ut1(i) = edge_vect_n(i)*ue(1,i-1,j)+(1.-edge_vect_n(i))*ue(1,i,j)
+ ut2(i) = edge_vect_n(i)*ue(2,i-1,j)+(1.-edge_vect_n(i))*ue(2,i,j)
+ ut3(i) = edge_vect_n(i)*ue(3,i-1,j)+(1.-edge_vect_n(i))*ue(3,i,j)
+ else
+ ut1(i) = edge_vect_n(i)*ue(1,i+1,j)+(1.-edge_vect_n(i))*ue(1,i,j)
+ ut2(i) = edge_vect_n(i)*ue(2,i+1,j)+(1.-edge_vect_n(i))*ue(2,i,j)
+ ut3(i) = edge_vect_n(i)*ue(3,i+1,j)+(1.-edge_vect_n(i))*ue(3,i,j)
+ endif
+ enddo
+ do i=is,ie
+ ue(1,i,j) = ut1(i)
+ ue(2,i,j) = ut2(i)
+ ue(3,i,j) = ut3(i)
+ enddo
+ endif
+
+ endif ! .not. bounded_domain
+
+ do j=js,je+1
+ do i=is,ie
+ u(i,j,k) = ue(1,i,j)*es(1,i,j,1) + &
+ ue(2,i,j)*es(2,i,j,1) + &
+ ue(3,i,j)*es(3,i,j,1)
+ enddo
+ enddo
+ do j=js,je
+ do i=is,ie+1
+ v(i,j,k) = ve(1,i,j)*ew(1,i,j,2) + &
+ ve(2,i,j)*ew(2,i,j,2) + &
+ ve(3,i,j)*ew(3,i,j,2)
+ enddo
+ enddo
+
+ enddo ! k-loop
+
+ end subroutine cubed_a2d
#ifdef TO_DO_MQ
subroutine init_mq(phis, gridstruct, npx, npy, is, ie, js, je, ng)
diff --git a/model/fv_mapz.F90 b/model/fv_mapz.F90
index dbbfb8399..8705d0775 100644
--- a/model/fv_mapz.F90
+++ b/model/fv_mapz.F90
@@ -30,15 +30,15 @@ module fv_mapz_mod
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_grid_utils_mod, only: g_sum, ptop_min, cubed_to_latlon
use fv_fill_mod, only: fillz
use mpp_domains_mod, only: mpp_update_domains, domain2d
use mpp_mod, only: FATAL, NOTE, mpp_error, get_unit, mpp_root_pe, mpp_pe
use 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 fast_sat_adj_mod, only: fast_sat_adj, qsmith_init
- use gfdl_mp_mod, only: gfdl_mp_driver, c_liq, c_ice
+ use intermediate_phys_mod, only: intermediate_phys
+ use gfdl_mp_mod, only: c_liq, c_ice
implicit none
real, parameter:: consv_min = 0.001 ! below which no correction applies
@@ -56,23 +56,26 @@ module fv_mapz_mod
private
public compute_total_energy, Lagrangian_to_Eulerian, moist_cv, moist_cp, &
- rst_remap, mappm, E_Flux, remap_2d, map_scalar
+ rst_remap, mappm, E_Flux, remap_2d, map_scalar, consv_min, map1_q2
contains
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, &
+ nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, te_err, tw_err, &
akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, remap_te, peln, te0_2d, &
- ng, ua, va, omga, te, ws, fill, reproduce_sum, out_dt, dtdt, &
+ ng, ua, va, omga, te, ws, fill, reproduce_sum, &
ptop, ak, bk, pfull, gridstruct, domain, do_sat_adj, &
hydrostatic, hybrid_z, adiabatic, do_adiabatic_init, &
do_inline_mp, inline_mp, c2l_ord, bd, fv_debug, &
- moist_phys, w_limiter, do_am4_remap)
+ w_limiter, do_am4_remap, do_fast_phys, consv_checker, adj_mass_vmr)
logical, intent(in):: last_step
logical, intent(in):: fv_debug
logical, intent(in):: w_limiter
logical, intent(in):: do_am4_remap
+ logical, intent(in):: do_fast_phys
+ logical, intent(in):: consv_checker
+ logical, intent(in):: adj_mass_vmr
real, intent(in):: mdt ! remap time step
real, intent(in):: pdt ! phys time step
integer, intent(in):: npx, npy
@@ -92,6 +95,8 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
real, intent(in):: consv ! factor for TE conservation
real, intent(in):: r_vir
real, intent(in):: cp
+ real, intent(in):: te_err
+ real, intent(in):: tw_err
real, intent(in):: akap
real, intent(in):: hs(isd:ied,jsd:jed) ! surface geopotential
real, intent(inout):: te0_2d(is:ie,js:je)
@@ -128,14 +133,11 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
real, intent(inout), dimension(is:,js:,1:)::delz
logical, intent(in):: hydrostatic
logical, intent(in):: hybrid_z
- logical, intent(in):: out_dt
- 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
real, intent(inout):: omga(isd:ied,jsd:jed,km) ! vertical press. velocity (pascal/sec)
real, intent(inout):: peln(is:ie,km+1,js:je) ! log(pe)
- real, intent(inout):: dtdt(is:ie,js:je,km)
real, intent(out):: pkz(is:ie,js:je,km) ! layer-mean pk for converting t to pt
real, intent(out):: te(isd:ied,jsd:jed,km)
@@ -147,23 +149,18 @@ 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, q3
+ real, dimension(is:ie,js:je):: te_2d, zsum0, zsum1
+ real, dimension(is:ie,km) :: q2, dp2, t0, w2
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
+ real, dimension(is:ie):: gz, cvm
real, dimension(isd:ied,jsd:jed,km):: qnl, qni
- real rcp, rg, rrg, bkh, dtmp, k1k, dlnp, tmp, tpe
- logical:: fast_mp_consv
+ real rcp, rg, rrg, bkh, dtmp, k1k, dlnp, tpe
integer:: i,j,k
integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, iq, n, kmp, kp, k_next
- integer:: ccn_cm3, cin_cm3
-
+ integer:: ccn_cm3, cin_cm3, aerosol
k1k = rdgas/cv_air ! akap / (1.-akap) = rg/Cv=0.4
rg = rdgas
@@ -178,15 +175,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
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
+ aerosol = get_tracer_index (MODEL_ATMOS, 'aerosol')
!$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, &
@@ -456,12 +445,12 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
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)
+ !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)
+ !print*, ' W_LIMITER down: ', i,j,k, w2(i,k:k+1), w(i,j,k:k+1)
endif
enddo
enddo
@@ -471,22 +460,22 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
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)
+ !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)
+ !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)
+ !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)
+ !print*, ' W_LIMITER top limited: ', i,j,1, w2(i,1), w(i,j,1)
endif
enddo
do k=1,km
@@ -702,43 +691,6 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
enddo !j-loop
-!-----------------------------------------------------------------------
-! 5) Inline GFDL MP setup
-!-----------------------------------------------------------------------
-
- if ((.not. do_adiabatic_init) .and. do_inline_mp) then
-
- allocate(u_dt(isd:ied,jsd:jed,km))
- allocate(v_dt(isd:ied,jsd:jed,km))
-
- do k=1,km
- do j=jsd,jed
- do i=isd,ied
- u_dt(i,j,k) = 0.
- v_dt(i,j,k) = 0.
- enddo
- enddo
- enddo
-
- ! save D grid u and v
- if (consv .gt. consv_min) then
- allocate(u0(isd:ied,jsd:jed+1,km))
- allocate(v0(isd:ied+1,jsd:jed,km))
- u0 = u
- v0 = v
- endif
-
- ! D grid wind to A grid wind remap
- call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, 1, gridstruct%grid_type, &
- domain, gridstruct%bounded_domain, c2l_ord, bd)
-
- ! save delp
- if (consv .gt. consv_min) then
- allocate(dp0(isd:ied,jsd:jed,km))
- dp0 = delp
- endif
-
- endif
!6) Energy fixer
!$OMP parallel do default(none) shared(is,ie,js,je,km,pe4,pe)
@@ -882,233 +834,20 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
endif ! end consv check
endif ! end last_step check
-! Note: pt at this stage is T_v
!-----------------------------------------------------------------------
-! 7) Split GFDL MP
+! Intermediate Physics >>>
!-----------------------------------------------------------------------
-! if ( (.not.do_adiabatic_init) .and. do_sat_adj ) then
- if (do_adiabatic_init .or. do_sat_adj) then
- call timing_on('sat_adj2')
-
- 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 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), 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
-#ifdef MOIST_CAPPA
- pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)))
-#else
- pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)))
-#endif
- enddo
- enddo
- endif
- enddo ! OpenMP k-loop
-
- deallocate(dz)
-
- if ( fast_mp_consv ) then
-!$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
- te0_2d(i,j) = te0_2d(i,j) + te(i,j,k)
- enddo
- enddo
- enddo
- endif
- call timing_off('sat_adj2')
- endif ! do_sat_adj
+ call intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, &
+ c2l_ord, mdt, consv, akap, ptop, pfull, hs, te0_2d, u, &
+ v, w, pt, delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, &
+ inline_mp, gridstruct, domain, bd, hydrostatic, do_adiabatic_init, &
+ do_inline_mp, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr)
!-----------------------------------------------------------------------
-! 8) Inline GFDL MP --- full call
+! <<< Intermediate Physics
!-----------------------------------------------------------------------
- if ((.not. do_adiabatic_init) .and. do_inline_mp) then
-
- 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
- q2(is:ie,:) = q(is:ie,j,:,ccn_cm3)
- 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 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,:)
- v_dt(is:ie,j,:) = va(is:ie,j,:)
-
- !save temperature and qv for tendencies
- 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 (.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
-
- 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,:), 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, &
- 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 (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
- pe(is:ie,k,j) = pe(is:ie,k-1,j)+delp(is:ie,j,k-1)
- peln(is:ie,k,j) = log(pe(is:ie,k,j))
- pk(is:ie,j,k) = exp(akap*peln(is:ie,k,j))
- enddo
-
- ps(is:ie,j) = pe(is:ie,km+1,j)
-
- ! update pkz
- if (.not. hydrostatic) then
-#ifdef MOIST_CAPPA
- pkz(is:ie,j,:) = exp(cappa(is:ie,j,:)*log(rrg*delp(is:ie,j,:)/delz(is:ie,j,:)*pt(is:ie,j,:)))
-#else
- pkz(is:ie,j,:) = exp(akap*log(rrg*delp(is:ie,j,:)/delz(is:ie,j,:)*pt(is:ie,j,:)))
-#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
-
- deallocate(dz)
- deallocate(wa)
-
- endif
-
if ( last_step ) then
! 9a) Convert T_v/T_m to T if last_step
!!! if ( is_master() ) write(*,*) 'dtmp=', dtmp, nwat
@@ -1151,80 +890,6 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
enddo
endif
-!-----------------------------------------------------------------------
-! 10) Finish Inline GFDL MP
-!-----------------------------------------------------------------------
-
- if ((.not. do_adiabatic_init) .and. do_inline_mp) then
-
- ! Note: (ua,va) are *lat-lon* wind tendenies on cell centers
- if ( gridstruct%square_domain ) then
- call mpp_update_domains(u_dt, domain, whalo=1, ehalo=1, shalo=1, nhalo=1, complete=.false.)
- call mpp_update_domains(v_dt, domain, whalo=1, ehalo=1, shalo=1, nhalo=1, complete=.true.)
- else
- call mpp_update_domains(u_dt, domain, complete=.false.)
- call mpp_update_domains(v_dt, domain, complete=.true.)
- endif
- ! update u_dt and v_dt in halo
- call mpp_update_domains(u_dt, v_dt, domain)
-
- ! update D grid wind
- call update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, abs(mdt), u_dt, v_dt, u, v, &
- gridstruct, npx, npy, km, domain)
-
- ! 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) + 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))) &
- - dp0(i,j,k) * &
- (0.25*gridstruct%rsin2(i,j)*(u0(i,j,k)**2+u0(i,j+1,k)**2 + &
- v0(i,j,k)**2+v0(i+1,j,k)**2 - &
- (u0(i,j,k)+u0(i,j+1,k))*(v0(i,j,k)+v0(i+1,j,k))*gridstruct%cosa_s(i,j)))
- enddo
- enddo
- else
- do i=is,ie
- 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
- do i=is,ie
- 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)))) &
- - dp0(i,j,k) * &
- (0.5*(phis(i,k)+phis(i,k+1) + w(i,j,k)**2 + 0.5*gridstruct%rsin2(i,j)*( &
- u0(i,j,k)**2+u0(i,j+1,k)**2 + v0(i,j,k)**2+v0(i+1,j,k)**2 - &
- (u0(i,j,k)+u0(i,j+1,k))*(v0(i,j,k)+v0(i+1,j,k))*gridstruct%cosa_s(i,j))))
- enddo
- enddo
- endif
- enddo
- end if
-
- deallocate(u_dt)
- deallocate(v_dt)
- if (consv .gt. consv_min) then
- deallocate(u0)
- deallocate(v0)
- deallocate(dp0)
- endif
-
- endif
-
end subroutine Lagrangian_to_Eulerian
diff --git a/model/fv_sg.F90 b/model/fv_sg.F90
index 31f3eba3e..37a4a1c1c 100644
--- a/model/fv_sg.F90
+++ b/model/fv_sg.F90
@@ -27,14 +27,14 @@ 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_mp_mod, only: wqs1, wqs2, wqsat2_moist, c_liq, c_ice
+ use gfdl_mp_mod, only: wqs, mqs3d, c_liq, c_ice
use fv_mp_mod, only: mp_reduce_min, is_master
use mpp_mod, only: mpp_pe
implicit none
private
-public fv_subgrid_z, qsmith, neg_adj3
+public fv_subgrid_z, neg_adj3
real, parameter:: esl = 0.621971831
real, parameter:: tice = 273.16
@@ -60,7 +60,6 @@ module fv_sg_mod
real, parameter:: Li0 = hlf0 - dc_ice*t_ice ! = -2.431928e5
real, parameter:: zvir = rvgas/rdgas - 1. ! = 0.607789855
- real, allocatable:: table(:),des(:)
real:: lv00, d0_vap
contains
@@ -713,7 +712,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, &
do k=kbot, 2, -1
km1 = k-1
#ifdef TEST_MQ
- if(nwat>0) call qsmith(im, 1, 1, t0(is,km1), pm(is,km1), q0(is,km1,sphum), qs)
+ if(nwat>0) call mqs3d(im, 1, 1, t0(is,km1), pm(is,km1), q0(is,km1,sphum), qs)
#endif
do i=is,ie
! Richardson number = g*delz * del_theta/theta / (del_u**2 + del_v**2)
@@ -905,7 +904,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, &
! Prevent super saturation over water:
do i=is, ie
- qsw = wqs2(t0(i,k), den(i,k), dqsdt)
+ qsw = wqs(t0(i,k), den(i,k), dqsdt)
dq = q0(i,k,sphum) - qsw
if ( dq > 0. ) then ! remove super-saturation
tcp3 = lcp2(i) + icp2(i)*min(1., dim(tice,t0(i,k))/40.)
@@ -964,154 +963,6 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, &
end subroutine fv_subgrid_z
#endif
-
- subroutine qsmith_init
- integer, parameter:: length=2621
- integer i
-
- if( .not. allocated(table) ) then
-! Generate es table (dT = 0.1 deg. C)
-
- allocate ( table(length) )
- allocate ( des (length) )
-
- call qs_table_m(length, table)
-
- do i=1,length-1
- des(i) = table(i+1) - table(i)
- enddo
- des(length) = des(length-1)
- endif
-
- end subroutine qsmith_init
-
-
- subroutine qsmith(im, km, k1, t, p, q, qs, dqdt)
-! input T in deg K; p (Pa)
- integer, intent(in):: im, km, k1
- real, intent(in),dimension(im,km):: t, p, q
- real, intent(out),dimension(im,km):: qs
- real, intent(out), optional:: dqdt(im,km)
-! Local:
- real es(im,km)
- real ap1, eps10
- real Tmin
- integer i, k, it
-
- Tmin = tice-160.
- eps10 = 10.*esl
-
- if( .not. allocated(table) ) call qsmith_init
-
- do k=k1,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) = esl*es(i,k)*(1.+zvir*q(i,k))/p(i,k)
- enddo
- enddo
-
- if ( present(dqdt) ) then
- do k=k1,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
-
-
- subroutine qs_table(n,table)
- integer, intent(in):: n
- real table (n)
- real:: dt=0.1
- real esbasw, tbasw, esbasi, tbasi, Tmin, tem, aa, b, c, d, e, esh20
- real wice, wh2o
- integer i
-! Constants
- esbasw = 1013246.0
- tbasw = 373.16
- tbasi = 273.16
- Tmin = tbasi - 160.
-! Compute es over water
-! see smithsonian meteorological tables page 350.
- do i=1,n
- tem = Tmin+dt*real(i-1)
- aa = -7.90298*(tbasw/tem-1)
- b = 5.02808*alog10(tbasw/tem)
- c = -1.3816e-07*(10**((1-tem/tbasw)*11.344)-1)
- d = 8.1328e-03*(10**((tbasw/tem-1)*(-3.49149))-1)
- e = alog10(esbasw)
- table(i) = 0.1*10**(aa+b+c+d+e)
- enddo
-
- end subroutine qs_table
-
- subroutine qs_table_m(n,table)
-! Mixed (blended) table
- integer, intent(in):: n
- real table (n)
- real esupc(200)
- real:: dt=0.1
- real esbasw, tbasw, esbasi, tbasi, Tmin, tem, aa, b, c, d, e, esh20
- real wice, wh2o
- integer i
-
-! Constants
- esbasw = 1013246.0
- tbasw = 373.16
- esbasi = 6107.1
- tbasi = 273.16
-! ****************************************************
-! Compute es over ice between -160c and 0 c.
- Tmin = tbasi - 160.
-! see smithsonian meteorological tables page 350.
- do i=1,1600
- tem = Tmin+dt*real(i-1)
- aa = -9.09718 *(tbasi/tem-1.0)
- b = -3.56654 *alog10(tbasi/tem)
- c = 0.876793*(1.0-tem/tbasi)
- e = alog10(esbasi)
- table(i)=10**(aa+b+c+e)
- enddo
-! *****************************************************
-! Compute es over water between -20c and 102c.
-! see smithsonian meteorological tables page 350.
- do i=1,1221
- tem = 253.16+dt*real(i-1)
- aa = -7.90298*(tbasw/tem-1)
- b = 5.02808*alog10(tbasw/tem)
- c = -1.3816e-07*(10**((1-tem/tbasw)*11.344)-1)
- d = 8.1328e-03*(10**((tbasw/tem-1)*(-3.49149))-1)
- e = alog10(esbasw)
- esh20 = 10**(aa+b+c+d+e)
- if (i <= 200) then
- esupc(i) = esh20
- else
- table(i+1400) = esh20
- endif
- enddo
-!********************************************************************
-! Derive blended es over ice and supercooled water between -20c and 0c
- do i=1,200
- tem = 253.16+dt*real(i-1)
- wice = 0.05*(273.16-tem)
- wh2o = 0.05*(tem-253.16)
- table(i+1400) = wice*table(i+1400)+wh2o*esupc(i)
- enddo
-
- do i=1,n
- table(i) = table(i)*0.1
- enddo
-
- end subroutine qs_table_m
-
subroutine neg_adj3(is, ie, js, je, ng, kbot, hydrostatic, &
peln, delz, pt, dp, qv, ql, qr, qi, qs, qg, qa, check_negative)
@@ -1312,7 +1163,7 @@ subroutine neg_adj3(is, ie, js, je, ng, kbot, hydrostatic, &
endif
! vapor <---> liquid water --------------------------------
- qsw = wqsat2_moist(pt2(i,j), qv2(i,j), p2(i,j), dwsdt)
+ qsw = wqs(pt2(i,j), p2(i,j), qv2(i,j), dwsdt)
sink = min( ql2(i,j), (qsw-qv2(i,j))/(1.+lcpk(i,j)*dwsdt) )
qv2(i,j) = qv2(i,j) + sink
ql2(i,j) = ql2(i,j) - sink
diff --git a/model/gfdl_cld_mp.F90 b/model/gfdl_cld_mp.F90
deleted file mode 100644
index 5316f4bc3..000000000
--- a/model/gfdl_cld_mp.F90
+++ /dev/null
@@ -1,4597 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-! =======================================================================
-! cloud micro - physics package for gfdl global cloud resolving model
-! the algorithms are originally derived from lin et al 1983. most of the
-! key elements have been simplified / improved. this code at this stage
-! 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
-! =======================================================================
-
-module gfdl_cld_mp_mod
-
-#ifdef GFS_PHYS
- use machine, only: r_grid => kind_phys
-#endif
-
- implicit none
-
- private
-
- 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.
-
- 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 = 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, 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, 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
-
- ! 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 (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 value
- real, parameter :: hlf0 = hlf ! gfs: fussion latent heat coefficient at 0 deg c
- ! real, parameter :: hlf0 = 3.337e5 ! emanuel value
-
- 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 = 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 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 ! used for correcting flipped height
-
- real, parameter :: sfcrho = 1.2 ! surface air density
-
- 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 :: 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
-
- 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, 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
- 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.
-
- 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
- ! -----------------------------------------------------------------------
-
- 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)
-
- real :: rh_inc = 0.25 ! rh increment for complete evaporation of cloud water and cloud ice
- real :: rh_inr = 0.25 ! rh increment for minimum evaporation of rain
- real :: rh_ins = 0.25 ! rh increment for sublimation of snow
-
- real :: tau_r2g = 900. ! rain freezing during fast_sat
- real :: tau_smlt = 900. ! snow melting
- real :: tau_g2r = 600. ! graupel melting to rain
- real :: tau_imlt = 600. ! cloud ice melting
- real :: tau_i2s = 1000. ! cloud ice to snow auto - conversion
- real :: tau_l2r = 900. ! cloud water to rain auto - conversion
- real :: tau_v2l = 150. ! water vapor to cloud water (condensation)
- 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
- 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
-
- 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 (micron)
-
- ! -----------------------------------------------------------------------
- ! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33
- ! optimized: qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp)))
- ! qi_gen ~ 4.808e-7 at 0 c; 1.818e-6 at - 10 c, 9.82679e-5 at - 40c
- ! the following value is constructed such that qc_crt = 0 at zero c and @ - 10c matches
- ! wrf / wsm6 ice initiation scheme; qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den
- ! -----------------------------------------------------------------------
-
- real :: sat_adj0 = 0.90 ! adjustment factor (0: no, 1: full) during fast_sat_adj
-
- real :: qc_crt = 5.0e-8 ! mini condensate mixing ratio to allow partial cloudiness
-
- real :: qi_lim = 1. ! cloud ice limiter to prevent large ice build up
-
- 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 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_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
- ! 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: (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 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
-
- 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
-
- 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
-
- 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 :: do_hail = .false. ! use hail parameters instead of graupel
- 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_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, 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, 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
-
-! -----------------------------------------------------------------------
-! the driver of the gfdl cloud microphysics
-! -----------------------------------------------------------------------
-
-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
- 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
-
- real, intent (in) :: dts ! physics time step
-
- 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) :: 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 (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
-
- 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 (hydrostatic) then
- c_air = cp_air
- c_vap = cp_vap
- do_sedi_w = .false.
- else
- c_air = cv_air
- c_vap = cv_vap
- endif
- d0_vap = c_vap - c_liq
-
- ! scaled constants (to reduce fp errors for 32 - bit) :
- d1_vap = d0_vap / c_air
- d1_ice = dc_ice / c_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
-
- c1_vap = c_vap / c_air
- c1_liq = c_liq / c_air
- c1_ice = c_ice / c_air
-
- ! -----------------------------------------------------------------------
- ! define latent heat coefficient used in wet bulb and bigg mechanism
- ! -----------------------------------------------------------------------
-
- lat2 = (hlv + hlf) ** 2
-
- lcp = hlv / cp_air
- icp = hlf / cp_air
- tcp = (hlv + hlf) / cp_air
-
- ! tendency zero out for am moist processes should be done outside the driver
-
- ! -----------------------------------------------------------------------
- ! major cloud microphysics
- ! -----------------------------------------------------------------------
-
- 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_cld_mp_driver
-
-! -----------------------------------------------------------------------
-! gfdl cloud microphysics, major program
-! lin et al., 1983, jam, 1065 - 1092, and
-! rutledge and hobbs, 1984, jas, 2949 - 2972
-! terminal fall is handled lagrangianly by conservative fv algorithm
-! pt: temperature (k)
-! 6 water species:
-! 1) qv: water vapor (kg / kg)
-! 2) ql: cloud water (kg / kg)
-! 3) qr: rain (kg / kg)
-! 4) qi: cloud ice (kg / kg)
-! 5) qs: snow (kg / kg)
-! 6) qg: graupel (kg / kg)
-! -----------------------------------------------------------------------
-
-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
- 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) :: 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
- 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 = one_r8 / dts
-
- dte = 0.0
-
- ! convert to mm / day
- convt = 86400. * rdt * rgrav
- cond = 0.0
-
- ! -----------------------------------------------------------------------
- ! use local variables
- ! -----------------------------------------------------------------------
-
- 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))))
-#else
- 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
- ! -----------------------------------------------------------------------
- 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)
- ! 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.
- 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 transport:
- ! -----------------------------------------------------------------------
-
- m1 (k) = 0.
- 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
-
- ! -----------------------------------------------------------------------
- ! 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
-
- ! -----------------------------------------------------------------------
- ! calculate cloud condensation nuclei (ccn)
- ! the following is based on klein eq. 15
- ! -----------------------------------------------------------------------
-
- cpaut = c_paut * 0.104 * grav / 1.717e-5
-
- if (prog_ccn) then
- 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
- else
- ! 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
-
- ! -----------------------------------------------------------------------
- ! calculate horizontal subgrid variability
- ! total water subgrid deviation in horizontal direction
- ! default area dependent form: use dx ~ 100 km as the base
- ! -----------------------------------------------------------------------
-
- s_leng = sqrt (gsize (i) / 1.e5)
- t_land = dw_land * s_leng
- t_ocean = dw_ocean * s_leng
- 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))
-
- ! -----------------------------------------------------------------------
- ! relative humidity thresholds
- ! -----------------------------------------------------------------------
-
- rh_adj = 1. - h_var - rh_inc
- 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, cond)
-
- condensation (i) = condensation (i) + cond * convt * ntimes
-
- m2_rain (i, :) = 0.
- m2_sol (i, :) = 0.
-
- do n = 1, ntimes
-
- ! -----------------------------------------------------------------------
- ! time - split warm rain processes: 1st 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, reevap, dte (i))
-
- evaporation (i) = evaporation (i) + reevap * convt
- rain (i) = rain (i) + r1 * convt
-
- do k = ks, ke
- m2_rain (i, k) = m2_rain (i, k) + m1_rain (k)
- m1 (k) = m1 (k) + m1_rain (k)
- enddo
-
- ! -----------------------------------------------------------------------
- ! sedimentation of cloud ice, snow, and graupel
- ! -----------------------------------------------------------------------
-
- 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))
-
- 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) 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, 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))
-
- evaporation (i) = evaporation (i) + reevap * convt
- rain (i) = rain (i) + r1 * convt
-
- 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)
- enddo
-
- ! -----------------------------------------------------------------------
- ! ice - phase microphysics
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! momentum transportation during sedimentation
- ! note: dp1 is dry mass; dp0 is the old moist (total) mass
- ! -----------------------------------------------------------------------
-
- if (sedi_transport) then
- 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))
- 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
- ! 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 = 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
-
- ! -----------------------------------------------------------------------
- ! 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
- ! -----------------------------------------------------------------------
-
- 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
- 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
- endif
-
- ! -----------------------------------------------------------------------
- ! update cloud fraction tendency
- ! -----------------------------------------------------------------------
-
- 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 (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
- 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
- ! local:
- real, dimension (ks:ke) :: dgz, cv0
- integer :: k
-
- ! 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
- ! -----------------------------------------------------------------------
- ! implicit algorithm: can't be vectorized
- ! needs an inner i - loop for vectorization
- ! -----------------------------------------------------------------------
- ! 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
-
-! -----------------------------------------------------------------------
-! warm rain cloud microphysics
-! -----------------------------------------------------------------------
-
-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) :: 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 (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 (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
-
- logical :: no_fall
-
- dt5 = 0.5 * dt
-
- ! -----------------------------------------------------------------------
- ! terminal speed of rain
- ! -----------------------------------------------------------------------
-
- m1_rain (:) = 0.
-
- call check_column (ks, ke, qr, no_fall)
-
- reevap = 0
-
- if (no_fall) then
- vtr (:) = vf_min
- r1 = 0.
- else
-
- ! -----------------------------------------------------------------------
- ! fall speed of rain
- ! -----------------------------------------------------------------------
-
- if (const_vr) then
- vtr (:) = vr_fac ! ifs_2016: 4.0
- else
- do k = ks, ke
- qden = qr (k) * den (k)
- if (qr (k) < thr) then
- vtr (k) = vr_min
- else
- vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * &
- exp (0.2 * log (qden / normr))
- vtr (k) = min (vr_max, max (vr_min, vtr (k)))
- endif
- enddo
- endif
-
- ze (ke + 1) = zs
- do k = ke, ks, - 1
- ze (k) = ze (k + 1) - dz (k) ! dz < 0
- enddo
-
- ! -----------------------------------------------------------------------
- ! 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, dp, reevap)
-
- if (do_sedi_w) then
- 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
-
- ! -----------------------------------------------------------------------
- ! 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 (ke + 1) = zs - dt * vtr (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
- call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof)
- else
- 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
- ! -----------------------------------------------------------------------
-
- if (do_sedi_w) then
- ! 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 exchanges during sedimentation
- ! -----------------------------------------------------------------------
-
- 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, dp, reevap)
-
- endif
-
- ! -----------------------------------------------------------------------
- ! auto - conversion
- ! assuming linear subgrid vertical distribution of cloud water
- ! following lin et al. 1994, mwr
- ! -----------------------------------------------------------------------
-
- if (irain_f /= 0) then
-
- ! -----------------------------------------------------------------------
- ! no subgrid varaibility
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- qc = fac_rc * ccn (k)
- if (tz (k) > t_wfr) then
- dq = ql (k) - qc
- if (dq > 0.) then
- sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))))
- ql (k) = ql (k) - sink
- qr (k) = qr (k) + sink
- endif
- endif
- enddo
-
- else
-
- ! -----------------------------------------------------------------------
- ! with subgrid varaibility
- ! -----------------------------------------------------------------------
-
- call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var)
-
- 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)
- ! --------------------------------------------------------------------
- dq = 0.5 * (ql (k) + dl (k) - qc)
- ! --------------------------------------------------------------------
- ! dq = dl if qc == q_minus = ql - dl
- ! dq = 0 if qc == q_plus = ql + dl
- ! --------------------------------------------------------------------
- if (dq > 0.) then ! q_plus > qc
- ! --------------------------------------------------------------------
- ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl
- ! --------------------------------------------------------------------
- sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))
- ql (k) = ql (k) - sink
- qr (k) = qr (k) + sink
- endif
- endif
- enddo
- endif
-
-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, 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, 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
-
- ! -----------------------------------------------------------------------
- ! define heat capacity and latent heat coefficient
- ! -----------------------------------------------------------------------
-
- q_liq (k) = ql (k) + qr (k)
- q_sol (k) = qi (k) + qs (k) + qg (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)
- 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
-
- ! -----------------------------------------------------------------------
- ! qsat must be > q_minus to activate evaporation
- ! qsat must be < q_plus to activate accretion
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! rain evaporation
- ! -----------------------------------------------------------------------
-
- 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_minus
- ! -----------------------------------------------------------------------
- dq = 0.25 * (qsat - q_minus) ** 2 / dqh
- endif
- qden = qr (k) * den (k)
- t2 = tin * tin
- 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))
- ! evap = max (evap, sink)
- ! -----------------------------------------------------------------------
- qr (k) = qr (k) - evap
- qv (k) = qv (k) + evap
- q_liq (k) = q_liq (k) - evap
- 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
-
- ! -----------------------------------------------------------------------
- ! accretion: pracc
- ! -----------------------------------------------------------------------
-
- ! if (qr (k) > qrmin .and. ql (k) > 1.e-7 .and. qsat < q_plus) 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
- qr (k) = qr (k) + sink
- endif
-
- endif ! warm - rain
- enddo
-
-end subroutine revap_racc
-
-! -----------------------------------------------------------------------
-! definition of vertical subgrid variability
-! used for cloud ice and cloud water autoconversion
-! qi -- > ql & ql -- > qr
-! edges: qe == qbar + / - dm
-! -----------------------------------------------------------------------
-
-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
- do k = 2, km
- dq (k) = 0.5 * (q (k) - q (k - 1))
- enddo
- dm (1) = 0.
-
- ! -----------------------------------------------------------------------
- ! use twice the strength of the positive definiteness limiter (lin et al 1994)
- ! -----------------------------------------------------------------------
-
- do k = 2, km - 1
- dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k))
- if (dq (k) * dq (k + 1) <= 0.) then
- if (dq (k) > 0.) then ! local max
- dm (k) = min (dm (k), dq (k), - dq (k + 1))
- else
- dm (k) = 0.
- endif
- endif
- enddo
- dm (km) = 0.
-
- ! -----------------------------------------------------------------------
- ! impose a presumed background horizontal variability that is proportional to the value itself
- ! -----------------------------------------------------------------------
-
- do k = 1, km
- dm (k) = max (dm (k), qvmin, h_var * q (k))
- enddo
- else
- do k = 1, km
- dm (k) = max (qvmin, h_var * q (k))
- enddo
- endif
-
-end subroutine linear_prof
-
-! =======================================================================
-! ice cloud microphysics processes
-! bulk cloud micro - physics; processes splitting
-! with some un - split sub - grouping
-! time implicit (when possible) accretion and autoconversion
-! author: shian - jiann lin, gfdl
-! =======================================================================
-
-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, 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 :: 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, 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
-
- ! -----------------------------------------------------------------------
- ! define conversion scalar / factor
- ! -----------------------------------------------------------------------
-
- 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 = ks, ke
- q_liq (k) = qlk (k) + qrk (k)
- q_sol (k) = qik (k) + qsk (k) + qgk (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
-
- ! -----------------------------------------------------------------------
- ! 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 (qi0_crt < 0.) then
- qim (k) = - qi0_crt
- else
- qim (k) = qi0_crt / den (k)
- endif
- enddo
-
- if (.not. do_warm_rain_mp) then
-
- ! -----------------------------------------------------------------------
- ! 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
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- if (tzk (k) > tice_mlt .and. qik (k) > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! pimlt: instant melting of cloud ice
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! 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
-
- ! -----------------------------------------------------------------------
- ! do nothing above p_min
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! psacw: accretion of cloud water by snow
- ! only rate is used (for snow melt) since tc > 0.
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! psacr: accretion of rain by melted snow
- ! pracs: accretion of snow by rain
- ! -----------------------------------------------------------------------
-
- 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)
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! melting of graupel
- ! -----------------------------------------------------------------------
-
- if (qg > qcmin .and. tc > 0.) then
-
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
-
- if (qr > qrmin) &
- pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), rdts * qr)
-
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by graupel
- ! -----------------------------------------------------------------------
-
- 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
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! cloud ice proc:
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! psaci: accretion of cloud ice by snow
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! assuming linear subgrid vertical distribution of cloud ice
- ! the mismatch computation following lin et al. 1994, mwr
- ! -----------------------------------------------------------------------
-
- if (const_vi) then
- tmp = fac_i2s
- else
- tmp = fac_i2s * exp (0.025 * tc)
- endif
-
- 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
-
- ! -----------------------------------------------------------------------
- ! 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
- ! -----------------------------------------------------------------------
- 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
-
- endif
-
- ! -----------------------------------------------------------------------
- ! cold - rain proc:
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! rain to ice, snow, graupel processes:
- ! -----------------------------------------------------------------------
-
- tc = tz - tice
-
- if (qr > 1.e-7 .and. tc < 0.) then
-
- ! -----------------------------------------------------------------------
- ! * sink * terms to qr: psacr + pgfr
- ! source terms to qs: psacr
- ! source terms to qg: pgfr
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! psacr accretion of rain by snow
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! pgfr: rain freezing -- > graupel
- ! -----------------------------------------------------------------------
-
- pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
- exp (1.75 * log (qr * den (k)))
-
- ! -----------------------------------------------------------------------
- ! total sink to qr
- ! -----------------------------------------------------------------------
-
- sink = psacr + pgfr
- factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin)
-
- psacr = factor * psacr
- pgfr = factor * pgfr
-
- 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) = 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
-
- ! -----------------------------------------------------------------------
- ! graupel production terms:
- ! -----------------------------------------------------------------------
-
- if (qs > 1.e-7) then
-
- ! -----------------------------------------------------------------------
- ! accretion: snow -- > graupel
- ! -----------------------------------------------------------------------
-
- if (qg > qrmin) then
- sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k))
- else
- sink = 0.
- endif
-
- ! -----------------------------------------------------------------------
- ! autoconversion 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
-
- endif ! snow existed
-
- if (qg > 1.e-7 .and. tz < tice) then
-
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by 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
-
- ! -----------------------------------------------------------------------
- ! 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
-
- endif
-
- tzk (k) = tz
- qvk (k) = qv
- qlk (k) = ql
- qik (k) = qi
- qrk (k) = qr
- qsk (k) = qs
- qgk (k) = qg
-
- 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
-
-! =======================================================================
-! 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, 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, 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, rh_tem
- real :: dqsdt, dwsdt, dq, dq0, factor, tmp, liq, ice
- 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 (- 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)
-
- ! -----------------------------------------------------------------------
- ! define heat capacity and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- q_liq (k) = ql (k) + qr (k)
- q_sol (k) = qi (k) + qs (k) + qg (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
-
- cond = 0
- dep = 0
- reevap = 0
- sub = 0
-
- do k = ks, ke
-
- if (p1 (k) < p_min) cycle
-
- if (.not. do_warm_rain_mp) then
-
- ! -----------------------------------------------------------------------
- ! 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)
- 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
-
- ! -----------------------------------------------------------------------
- ! cloud water < -- > vapor adjustment:
- ! -----------------------------------------------------------------------
-
- tin = tz (k)
- rh_tem = qpz / iqs1 (tin, den (k))
- qsw = wqs2 (tin, den (k), dwsdt)
- dq0 = qsw - qv (k)
- 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) = 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
- ! -----------------------------------------------------------------------
-
- icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
-
- if (.not. do_warm_rain_mp) then
-
- ! -----------------------------------------------------------------------
- ! 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
- ! -----------------------------------------------------------------------
-
- if (do_sat_adj) then
- dt_pisub = 0.5 * dts
- else
- 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
-
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
-
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of ice
- ! -----------------------------------------------------------------------
-
- 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
- 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
-
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
-
- ! -----------------------------------------------------------------------
- ! 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
- 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
- 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
-
- ! -----------------------------------------------------------------------
- ! 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
-
- endif
-
- ! -----------------------------------------------------------------------
- ! compute cloud fraction
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! combine water species
- ! -----------------------------------------------------------------------
-
- if (.not. (do_qa .and. last_step)) cycle
-
- ice = q_sol (k)
- if (rad_snow) then
- 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)
-
- ! -----------------------------------------------------------------------
- ! 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) * 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
- ! -----------------------------------------------------------------------
-
- if (tin <= t_wfr) then
- ! ice phase:
- qstar = iqs1 (tin, den (k))
- elseif (tin >= tice) then
- ! liquid phase:
- qstar = wqs1 (tin, den (k))
- else
- ! mixed phase:
- qsi = iqs1 (tin, den (k))
- qsw = wqs1 (tin, den (k))
- if (q_cond (k) > 3.e-6) then
- rqi = q_sol (k) / q_cond (k)
- else
- ! -----------------------------------------------------------------------
- ! mostly liquid water q_cond (k) at initial cloud development stage
- ! -----------------------------------------------------------------------
- rqi = (tice - tin) / (tice - t_wfr)
- endif
- qstar = rqi * qsi + (1. - rqi) * qsw
- endif
-
- ! -----------------------------------------------------------------------
- ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the
- ! binary cloud scheme
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! 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
-
- enddo
-
-end subroutine subgrid_z_proc
-
-! =======================================================================
-! rain evaporation
-! =======================================================================
-
-subroutine revap_rac1 (hydrostatic, is, ie, dt, tz, qv, ql, qr, qi, qs, qg, den, hvar)
-
- implicit none
-
- 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
-
- integer :: k, k0, m
- logical :: no_fall
-
- dt5 = 0.5 * dtm
- fac_imlt = 1. - exp (- dt5 / tau_imlt)
-
- ! -----------------------------------------------------------------------
- ! define heat capacity and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- m1_sol (k) = 0.
- q_liq (k) = ql (k) + qr (k)
- q_sol (k) = qi (k) + qs (k) + qg (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 = ke
- do k = ks, ke - 1
- if (tz (k) > tice) then
- k0 = k
- exit
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! melting of cloud_ice (before fall) :
- ! -----------------------------------------------------------------------
-
- 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))
- tmp = min (sink, dim (ql_mlt, ql (k)))
- ql (k) = ql (k) + tmp
- qr (k) = qr (k) + sink - tmp
- qi (k) = qi (k) - sink
- q_liq (k) = q_liq (k) + sink
- q_sol (k) = q_sol (k) - sink
- 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
-
- ! -----------------------------------------------------------------------
- ! turn off melting when cloud microphysics time step is small
- ! -----------------------------------------------------------------------
-
- ! sjl, turn off melting of falling cloud ice, snow and graupel
- ! if (dtm < 60.) k0 = ke
- k0 = ke
- ! sjl, turn off melting of falling cloud ice, snow and graupel
-
- ze (ke + 1) = zs
- do k = ke, ks, - 1
- ze (k) = ze (k + 1) - dz (k) ! dz < 0
- enddo
-
- zt (ks) = ze (ks)
-
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- do k = k0, ke
- icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
- enddo
-
- ! -----------------------------------------------------------------------
- ! melting of falling cloud ice into cloud water and rain
- ! -----------------------------------------------------------------------
-
- call check_column (ks, ke, qi, no_fall)
-
- if (vi_fac < 1.e-5 .or. no_fall) then
- i1 = 0.
- else
-
- do k = ks + 1, ke
- zt (k) = ze (k) - dt5 * (vti (k - 1) + vti (k))
- enddo
- zt (ke + 1) = zs - dtm * vti (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
-
- if (k0 < ke) then
- do k = ke - 1, k0, - 1
- if (qi (k) > qrmin) then
- 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))
- sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
- tmp = min (sink, dim (ql_mlt, ql (m)))
- ql (m) = ql (m) + tmp
- qr (m) = qr (m) - tmp + sink
- 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
- enddo
- endif
-
- if (do_sedi_w) then
- 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_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
- 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
-
- endif
-
- ! -----------------------------------------------------------------------
- ! melting of falling snow into rain
- ! -----------------------------------------------------------------------
-
- r1 = 0.
-
- call check_column (ks, ke, qs, no_fall)
-
- if (no_fall) then
- s1 = 0.
- else
-
- do k = ks + 1, ke
- zt (k) = ze (k) - dt5 * (vts (k - 1) + vts (k))
- enddo
- zt (ke + 1) = zs - dtm * vts (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
-
- if (k0 < ke) then
- do k = ke - 1, k0, - 1
- if (qs (k) > qrmin) then
- 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
- dtime = min (1.0, dtime / tau_smlt)
- sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
- tz (m) = tz (m) - sink * icpk (m)
- qs (k) = qs (k) - sink * dp (m) / dp (k)
- if (zt (k) < zs) then
- r1 = r1 + sink * dp (m) ! precip as rain
- else
- ! qr source here will fall next time step (therefore, can evap)
- qr (m) = qr (m) + sink
- endif
- endif
- if (qs (k) < qrmin) exit
- enddo
- endif
- enddo
- endif
-
- if (do_sedi_w) then
- 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 (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
-
- if (do_sedi_w) then
- 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
-
- endif
-
- ! ----------------------------------------------
- ! melting of falling graupel into rain
- ! ----------------------------------------------
-
- call check_column (ks, ke, qg, no_fall)
-
- if (no_fall) then
- g1 = 0.
- else
-
- do k = ks + 1, ke
- zt (k) = ze (k) - dt5 * (vtg (k - 1) + vtg (k))
- enddo
- zt (ke + 1) = zs - dtm * vtg (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
-
- if (k0 < ke) then
- do k = ke - 1, k0, - 1
- if (qg (k) > qrmin) then
- 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
- dtime = min (1., dtime / tau_g2r)
- sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
- tz (m) = tz (m) - sink * icpk (m)
- qg (k) = qg (k) - sink * dp (m) / dp (k)
- if (zt (k) < zs) then
- r1 = r1 + sink * dp (m)
- else
- qr (m) = qr (m) + sink
- endif
- endif
- if (qg (k) < qrmin) exit
- enddo
- endif
- enddo
- endif
-
- if (do_sedi_w) then
- 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 (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
-
- if (do_sedi_w) then
- 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
-
- endif
-
-end subroutine terminal_fall
-
-! =======================================================================
-! check if water species large enough to fall
-! =======================================================================
-
-subroutine check_column (ks, ke, q, no_fall)
-
- implicit none
-
- integer, intent (in) :: ks, ke
- real, intent (in) :: q (ks:ke)
- logical, intent (out) :: no_fall
- integer :: k
-
- no_fall = .true.
-
- do k = ks, ke
- if (q (k) > qrmin) then
- no_fall = .false.
- exit
- endif
- enddo
-
-end subroutine check_column
-
-! =======================================================================
-! time - implicit monotonic scheme
-! developed by sj lin, 2016
-! =======================================================================
-
-subroutine implicit_fall (dt, ks, ke, ze, vt, dp, q, precip, m1)
-
- implicit none
-
- integer, intent (in) :: ks, ke
- real, intent (in) :: dt
- 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 (ks:ke) :: dz, qm, dd
- integer :: k
-
- do k = ks, ke
- dz (k) = ze (k) - ze (k + 1)
- dd (k) = dt * vt (k)
- q (k) = q (k) * dp (k)
- enddo
-
- ! -----------------------------------------------------------------------
- ! sedimentation: non - vectorizable loop
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! qm is density at this stage
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- qm (k) = qm (k) * dz (k)
- enddo
-
- ! -----------------------------------------------------------------------
- ! output mass fluxes: non - vectorizable loop
- ! -----------------------------------------------------------------------
-
- m1 (ks) = q (ks) - qm (ks)
- do k = ks + 1, ke
- m1 (k) = m1 (k - 1) + q (k) - qm (k)
- enddo
- precip = m1 (ke)
-
- ! -----------------------------------------------------------------------
- ! update:
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- q (k) = qm (k) / dp (k)
- enddo
-
-end subroutine implicit_fall
-
-! =======================================================================
-! lagrangian scheme
-! developed by sj lin, around 2006
-! =======================================================================
-
-subroutine lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, q, precip, m1, mono)
-
- implicit none
-
- integer, intent (in) :: ks, ke
- real, intent (in) :: zs
- logical, intent (in) :: mono
- real, intent (in), dimension (ks:ke + 1) :: ze, zt
- real, intent (in), dimension (ks:ke) :: dp
-
- ! m1: flux
- real, intent (inout), dimension (ks:ke) :: q, m1
- real, intent (out) :: precip
- real, dimension (ks:ke) :: qm, dz
-
- 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 = 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)
- qm (k) = 0.
- enddo
-
- ! -----------------------------------------------------------------------
- ! construct vertical profile with zt as coordinate
- ! -----------------------------------------------------------------------
-
- call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1, mono)
-
- 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
- ! entire new grid is within the original grid
- pr = (zt (n) - ze (k + 1)) / dz (n)
- qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - &
- a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2)
- qm (k) = qm (k) * (ze (k) - ze (k + 1))
- k0 = n
- goto 555
- 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 < 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)
- else
- delz = zt (m) - ze (k + 1)
- esl = delz / dz (m)
- qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * &
- (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl)))
- k0 = m
- goto 555
- endif
- enddo
- endif
- goto 555
- endif
- endif
- enddo
- 555 continue
- enddo
-
- m1 (ks) = q (ks) - qm (ks)
- do k = ks + 1, ke
- m1 (k) = m1 (k - 1) + q (k) - qm (k)
- enddo
- 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 = ks, ke
- q (k) = qm (k) / dp (k)
- enddo
-
-end subroutine lagrangian_fall_ppm
-
-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
- real :: pmp_1, lac_1, pmp_2, lac_2
- real :: da1, da2, a6da
-
- integer :: k
-
- logical extm (km)
-
- grat = del (2) / del (1) ! grid ratio
- bet = grat * (grat + 0.5)
- q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet
- gam (1) = (1. + grat * (grat + 1.5)) / bet
-
- do k = 2, km
- d4 = del (k - 1) / del (k)
- bet = 2. + 2. * d4 - gam (k - 1)
- q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet
- gam (k) = d4 / bet
- enddo
-
- a_bot = 1. + d4 * (d4 + 1.5)
- q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) &
- / (d4 * (d4 + 0.5) - a_bot * gam (km))
-
- do k = km, 1, - 1
- q (k) = q (k) - gam (k) * q (k + 1)
- enddo
-
- ! -----------------------------------------------------------------------
- ! apply constraints
- ! -----------------------------------------------------------------------
-
- do k = 2, km
- gam (k) = a4 (1, k) - a4 (1, k - 1)
- enddo
-
- ! -----------------------------------------------------------------------
- ! apply large - scale constraints to all fields if not local max / min
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! top:
- ! -----------------------------------------------------------------------
-
- q (1) = max (q (1), 0.)
- q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2)))
- q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.)
-
- ! -----------------------------------------------------------------------
- ! interior:
- ! -----------------------------------------------------------------------
-
- do k = 3, km - 1
- if (gam (k - 1) * gam (k + 1) > 0.) then
- q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k)))
- q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k)))
- else
- if (gam (k - 1) > 0.) then
- ! there exists a local max
- q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k)))
- else
- ! there exists a local min
- q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k)))
- q (k) = max (q (k), 0.0)
- endif
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! bottom :
- ! -----------------------------------------------------------------------
-
- q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km)))
- q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.)
- ! q (km + 1) = max (q (km + 1), 0.)
-
- ! -----------------------------------------------------------------------
- ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1)
- ! -----------------------------------------------------------------------
-
- do k = 1, km - 1
- a4 (2, k) = q (k)
- a4 (3, k) = q (k + 1)
- enddo
-
- do k = 2, km - 1
- if (gam (k) * gam (k + 1) > 0.0) then
- extm (k) = .false.
- else
- extm (k) = .true.
- endif
- enddo
-
- if (do_mono) then
- do k = 3, km - 2
- if (extm (k)) then
- ! positive definite constraint only if true local extrema
- if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then
- a4 (2, k) = a4 (1, k)
- a4 (3, k) = a4 (1, k)
- endif
- else
- a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k))
- if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then
- ! check within the smooth region if subgrid profile is non - monotonic
- pmp_1 = a4 (1, k) - 2.0 * gam (k + 1)
- lac_1 = pmp_1 + 1.5 * gam (k + 2)
- a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), &
- max (a4 (1, k), pmp_1, lac_1))
- pmp_2 = a4 (1, k) + 2.0 * gam (k)
- lac_2 = pmp_2 - 1.5 * gam (k - 1)
- a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), &
- max (a4 (1, k), pmp_2, lac_2))
- endif
- endif
- enddo
- else
- do k = 3, km - 2
- if (extm (k)) then
- if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then
- a4 (2, k) = a4 (1, k)
- a4 (3, k) = a4 (1, k)
- endif
- endif
- enddo
- endif
-
- do k = 1, km - 1
- a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k))
- enddo
-
- k = km - 1
- if (extm (k)) then
- a4 (2, k) = a4 (1, k)
- a4 (3, k) = a4 (1, k)
- a4 (4, k) = 0.
- else
- da1 = a4 (3, k) - a4 (2, k)
- da2 = da1 ** 2
- a6da = a4 (4, k) * da1
- if (a6da < - da2) then
- a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k))
- a4 (3, k) = a4 (2, k) - a4 (4, k)
- elseif (a6da > da2) then
- a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k))
- a4 (2, k) = a4 (3, k) - a4 (4, k)
- endif
- endif
-
- call cs_limiters (km - 1, a4)
-
- ! -----------------------------------------------------------------------
- ! bottom layer:
- ! -----------------------------------------------------------------------
-
- a4 (2, km) = a4 (1, km)
- a4 (3, km) = a4 (1, km)
- a4 (4, km) = 0.
-
-end subroutine cs_profile
-
-subroutine cs_limiters (km, a4)
-
- implicit none
-
- integer, intent (in) :: km
-
- real, intent (inout) :: a4 (4, km) ! ppm array
-
- real, parameter :: r12 = 1. / 12.
-
- integer :: k
-
- ! -----------------------------------------------------------------------
- ! positive definite constraint
- ! -----------------------------------------------------------------------
-
- do k = 1, km
- if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then
- if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then
- if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then
- a4 (3, k) = a4 (1, k)
- a4 (2, k) = a4 (1, k)
- a4 (4, k) = 0.
- elseif (a4 (3, k) > a4 (2, k)) then
- a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k))
- a4 (3, k) = a4 (2, k) - a4 (4, k)
- else
- a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k))
- a4 (2, k) = a4 (3, k) - a4 (4, k)
- endif
- endif
- endif
- enddo
-
-end subroutine cs_limiters
-
-! =======================================================================
-! calculation of vertical fall speed
-! =======================================================================
-
-subroutine fall_speed (ks, ke, den, qs, qi, qg, ql, tk, vts, vti, vtg)
-
- implicit none
-
- integer, intent (in) :: ks, ke
-
- 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:
-
- real, parameter :: thi = 1.0e-8 ! cloud ice threshold for terminal fall
- real, parameter :: thg = 1.0e-8
- real, parameter :: ths = 1.0e-8
-
- real, parameter :: aa = - 4.14122e-5
- real, parameter :: bb = - 0.00538922
- real, parameter :: cc = - 0.0516344
- real, parameter :: dd = 0.00216078
- real, parameter :: ee = 1.9714
-
- ! marshall - palmer constants
-
- real, parameter :: vcons = 6.6280504
- real, parameter :: vcong = 87.2382675
- 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 ! 115233618.533674
-
- real, dimension (ks:ke) :: qden, tc, rhof
-
- real :: vi0
-
- integer :: k
-
- ! -----------------------------------------------------------------------
- ! marshall - palmer formula
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! try the local air density -- for global model; the true value could be
- ! much smaller than sfcrho over high mountains
- ! -----------------------------------------------------------------------
-
- do k = ks, ke
- rhof (k) = sqrt (min (10., sfcrho / den (k)))
- enddo
-
- ! -----------------------------------------------------------------------
- ! ice:
- ! -----------------------------------------------------------------------
-
- if (const_vi) then
- vti (:) = vi_fac
- else
- ! -----------------------------------------------------------------------
- ! use deng and mace (2008, grl), which gives smaller fall speed than hd90 formula
- ! -----------------------------------------------------------------------
- vi0 = 0.01 * vi_fac
- 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
- 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
- endif
-
- ! -----------------------------------------------------------------------
- ! snow:
- ! -----------------------------------------------------------------------
-
- if (const_vs) then
- vts (:) = vs_fac ! 1. ifs_2016
- else
- do k = ks, ke
- if (qs (k) < ths) then
- vts (k) = vf_min
- else
- vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms))
- vts (k) = min (vs_max, max (vf_min, vts (k)))
- endif
- enddo
- endif
-
- ! -----------------------------------------------------------------------
- ! graupel:
- ! -----------------------------------------------------------------------
-
- if (const_vg) then
- vtg (:) = vg_fac ! 2.
- else
- if (do_hail) then
- do k = ks, ke
- if (qg (k) < thg) then
- vtg (k) = vf_min
- else
- vtg (k) = vg_fac * vconh * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normh)))
- vtg (k) = min (vg_max, max (vf_min, vtg (k)))
- endif
- enddo
- else
- do k = ks, ke
- if (qg (k) < thg) then
- vtg (k) = vf_min
- else
- vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg)))
- vtg (k) = min (vg_max, max (vf_min, vtg (k)))
- endif
- enddo
- endif
- endif
-
-end subroutine fall_speed
-
-! =======================================================================
-! setup gfdl cloud microphysics parameters
-! =======================================================================
-
-subroutine setupm
-
- implicit none
-
- real :: gcon, cd, scm3, pisq, act (8)
- real :: vdifu, tcond
- real :: visk
- real :: ch2o, hltf
- real :: hlts, hltc, ri50
-
- real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, &
- gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, &
- gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, &
- gam625 = 184.860962, gam680 = 496.604067
-
- real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /)
-
- real den_rc
-
- integer :: i, k
-
- pie = 4. * atan (1.0)
-
- ! s. klein's formular (eq 16) from am2
-
- fac_rc = (4. / 3.) * pie * rhor * rthresh ** 3
-
- if (prog_ccn) then
- ! if (master) write (*, *) 'prog_ccn option is .t.'
- else
- den_rc = fac_rc * ccn_o * 1.e6
- ! if (master) write (*, *) 'mp: for ccn_o = ', ccn_o, 'ql_rc = ', den_rc
- den_rc = fac_rc * ccn_l * 1.e6
- ! if (master) write (*, *) 'mp: for ccn_l = ', ccn_l, 'ql_rc = ', den_rc
- endif
-
- vdifu = 2.11e-5
- tcond = 2.36e-2
-
- visk = 1.259e-5
- hlts = hlv + hlf
- hltc = hlv
- hltf = hlf
-
- ch2o = c_liq
- ri50 = 1.e-4
-
- pisq = pie * pie
- scm3 = (visk / vdifu) ** (1. / 3.)
-
- cracs = pisq * rnzr * rnzs * rhos
- csacr = pisq * rnzr * rnzs * rhor
- if (do_hail) then
- cgacr = pisq * rnzr * rnzh * rhor
- cgacs = pisq * rnzh * rnzs * rhos
- else
- cgacr = pisq * rnzr * rnzg * rhor
- cgacs = pisq * rnzg * rnzs * rhos
- endif
- cgacs = cgacs * c_pgacs
-
- ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ;
- ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g)
-
- act (1) = pie * rnzs * rhos
- act (2) = pie * rnzr * rhor
- if (do_hail) then
- act (6) = pie * rnzh * rhoh
- else
- act (6) = pie * rnzg * rhog
- endif
- act (3) = act (2)
- act (4) = act (1)
- act (5) = act (2)
- act (7) = act (1)
- act (8) = act (6)
-
- do i = 1, 3
- do k = 1, 4
- acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25))
- enddo
- enddo
-
- gcon = 40.74 * sqrt (sfcrho) ! 44.628
-
- csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125)
- ! decreasing csacw to reduce cloud water --- > snow
-
- craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95)
- csaci = csacw * c_psaci
-
- if (do_hail) then
- cgacw = pie * rnzh * gam350 * gcon / (4. * act (6) ** 0.875)
- else
- cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875)
- endif
- ! cgaci = cgacw * 0.1
-
- ! sjl, may 28, 2012
- cgaci = cgacw * 0.05
- ! sjl, may 28, 2012
-
- cracw = craci ! cracw = 3.27206196043822
- cracw = c_cracw * cracw
-
- ! subl and revp: five constants for three separate processes
-
- cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs
- if (do_hail) then
- cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzh
- else
- cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg
- endif
- crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr
- cssub (2) = 0.78 / sqrt (act (1))
- cgsub (2) = 0.78 / sqrt (act (6))
- crevp (2) = 0.78 / sqrt (act (2))
- cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625
- cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875
- crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725
- cssub (4) = tcond * rvgas
- cssub (5) = hlts ** 2 * vdifu
- cgsub (4) = cssub (4)
- crevp (4) = cssub (4)
- cgsub (5) = cssub (5)
- crevp (5) = hltc ** 2 * vdifu
-
- cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75
- cgfr (2) = 0.66
-
- ! smlt: five constants (lin et al. 1983)
-
- csmlt (1) = 2. * pie * tcond * rnzs / hltf
- csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf
- csmlt (3) = cssub (2)
- csmlt (4) = cssub (3)
- csmlt (5) = ch2o / hltf
-
- ! gmlt: five constants
-
- if (do_hail) then
- cgmlt (1) = 2. * pie * tcond * rnzh / hltf
- cgmlt (2) = 2. * pie * vdifu * rnzh * hltc / hltf
- else
- cgmlt (1) = 2. * pie * tcond * rnzg / hltf
- cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf
- endif
- cgmlt (3) = cgsub (2)
- cgmlt (4) = cgsub (3)
- cgmlt (5) = ch2o / hltf
-
- es0 = e00
- ces0 = eps * es0
-
-end subroutine setupm
-
-! =======================================================================
-! initialization of gfdl cloud microphysics
-! =======================================================================
-
-subroutine gfdl_cld_mp_init (input_nml_file, logunit)
-
- implicit none
-
- character (len = *), intent (in) :: input_nml_file (:)
- integer, intent (in) :: logunit
-
- logical :: exists
-
- read (input_nml_file, nml = gfdl_mp_nml)
-
- ! write version number and namelist to log file
- write (logunit, *) " ================================================================== "
- write (logunit, *) "gfdl_mp_mod"
- write (logunit, nml = gfdl_mp_nml)
-
- if (do_setup) then
- call setup_con
- call setupm
- do_setup = .false.
- endif
-
- g2 = 0.5 * grav
- log_10 = log (10.)
-
- 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_cld_mp_init
-
-! =======================================================================
-! end of gfdl cloud microphysics
-! =======================================================================
-
-subroutine gfdl_cld_mp_end
-
- implicit none
-
- deallocate (table)
- deallocate (table2)
- deallocate (table3)
- deallocate (tablew)
- deallocate (des)
- deallocate (des2)
- deallocate (des3)
- deallocate (desw)
-
- tables_are_initialized = .false.
-
-end subroutine gfdl_cld_mp_end
-
-! =======================================================================
-! qsmith table initialization
-! =======================================================================
-
-subroutine setup_con
-
- implicit none
-
- ! master = (mpp_pe () .eq.mpp_root_pe ())
-
- if (.not. qsmith_tables_initialized) call qsmith_init
-
- qsmith_tables_initialized = .true.
-
-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.
-
- 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
-
-! =======================================================================
-! compute the gradient of saturated specific humidity for table ii
-! =======================================================================
-
-real function wqsat2_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 = 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 wqsat2_moist
-
-! =======================================================================
-! compute the saturated specific humidity for table ii
-! =======================================================================
-
-real function wqsat_moist (ta, qv, pa)
-
- implicit none
-
- real, intent (in) :: ta, pa, qv
-
- 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)
- wqsat_moist = eps * es * (1. + zvir * qv) / pa
-
-end function wqsat_moist
-
-! =======================================================================
-! compute the saturated specific humidity for table iii
-! =======================================================================
-
-real function qs1d_m (ta, qv, pa)
-
- implicit none
-
- real, intent (in) :: ta, pa, qv
-
- 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)
- qs1d_m = eps * es * (1. + zvir * qv) / pa
-
-end function qs1d_m
-
-! =======================================================================
-! computes the difference in saturation vapor * density * between water and ice
-! =======================================================================
-
-real function d_sat (ta, den)
-
- implicit none
-
- real, intent (in) :: ta, den
-
- real :: es_w, es_i, ap1, tmin
-
- integer :: it
-
- 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 water vapor pressure for table ii
-! =======================================================================
-
-real function esw_table (ta)
-
- implicit none
-
- real, intent (in) :: ta
-
- real :: ap1, tmin
-
- integer :: it
-
- tmin = table_ice - 160.
- ap1 = 10. * dim (ta, tmin) + 1.
- ap1 = min (2621., ap1)
- it = ap1
- esw_table = tablew (it) + (ap1 - it) * desw (it)
-
-end function esw_table
-
-! =======================================================================
-! compute the saturated water vapor pressure for table iii
-! =======================================================================
-
-real function es2_table (ta)
-
- implicit none
-
- real, intent (in) :: ta
-
- real :: ap1, tmin
-
- integer :: it
-
- tmin = table_ice - 160.
- ap1 = 10. * dim (ta, tmin) + 1.
- ap1 = min (2621., ap1)
- it = ap1
- es2_table = table2 (it) + (ap1 - it) * des2 (it)
-
-end function es2_table
-
-! =======================================================================
-! compute the saturated water vapor pressure for table ii
-! =======================================================================
-
-subroutine esw_table1d (ta, es, n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real, intent (in) :: ta (n)
-
- real, intent (out) :: es (n)
-
- real :: ap1, tmin
-
- 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 water vapor pressure for table iii
-! =======================================================================
-
-subroutine es2_table1d (ta, es, n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real, intent (in) :: ta (n)
-
- real, intent (out) :: es (n)
-
- real :: ap1, tmin
-
- 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) = table2 (it) + (ap1 - it) * des2 (it)
- enddo
-
-end subroutine es2_table1d
-
-! =======================================================================
-! compute the saturated water vapor pressure for table iv
-! =======================================================================
-
-subroutine es3_table1d (ta, es, n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real, intent (in) :: ta (n)
-
- real, intent (out) :: es (n)
-
- real :: ap1, tmin
-
- 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) = table3 (it) + (ap1 - it) * des3 (it)
- enddo
-
-end subroutine es3_table1d
-
-! =======================================================================
-! saturation water vapor pressure table ii
-! 1 - phase table
-! =======================================================================
-
-subroutine qs_tablew (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real (kind = r_grid) :: delt = 0.1
- real (kind = r_grid) :: tmin, tem, fac0, fac1, fac2
-
- integer :: i
-
- tmin = table_ice - 160.
-
- ! -----------------------------------------------------------------------
- ! compute es over water
- ! -----------------------------------------------------------------------
-
- do i = 1, n
- tem = tmin + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
- tablew (i) = e00 * exp (fac2)
- enddo
-
-end subroutine qs_tablew
-
-! =======================================================================
-! saturation water vapor pressure table iii
-! 2 - phase table
-! =======================================================================
-
-subroutine qs_table2 (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- real (kind = r_grid) :: delt = 0.1
- real (kind = r_grid) :: tmin, tem0, tem1, fac0, fac1, fac2
-
- integer :: i, i0, i1
-
- tmin = table_ice - 160.
-
- do i = 1, n
- tem0 = tmin + delt * real (i - 1)
- 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 / 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 / t_ice) + fac1) / rvgas
- endif
- table2 (i) = e00 * exp (fac2)
- enddo
-
- ! -----------------------------------------------------------------------
- ! smoother around 0 deg c
- ! -----------------------------------------------------------------------
-
- i0 = 1600
- i1 = 1601
- tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1))
- tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1))
- table2 (i0) = tem0
- table2 (i1) = tem1
-
-end subroutine qs_table2
-
-! =======================================================================
-! saturation water vapor pressure table iv
-! 2 - phase table with " - 2 c" as the transition point
-! =======================================================================
-
-subroutine qs_table3 (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- 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
-
- esbasw = 1013246.0
- tbasw = table_ice + 100.
- esbasi = 6107.1
- tmin = table_ice - 160.
-
- do i = 1, n
- tem = tmin + delt * real (i - 1)
- ! if (i <= 1600) then
- if (i <= 1580) then ! change to - 2 c
- ! -----------------------------------------------------------------------
- ! compute es over ice between - 160 deg c and 0 deg c.
- ! see smithsonian meteorological tables page 350.
- ! -----------------------------------------------------------------------
- aa = - 9.09718 * (table_ice / tem - 1.)
- b = - 3.56654 * log10 (table_ice / tem)
- c = 0.876793 * (1. - tem / table_ice)
- e = log10 (esbasi)
- table3 (i) = 0.1 * 10 ** (aa + b + c + e)
- else
- ! -----------------------------------------------------------------------
- ! compute es over water between - 2 deg c and 102 deg c.
- ! see smithsonian meteorological tables page 350.
- ! -----------------------------------------------------------------------
- aa = - 7.90298 * (tbasw / tem - 1.)
- 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 = log10 (esbasw)
- table3 (i) = 0.1 * 10 ** (aa + b + c + d + e)
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! smoother around - 2 deg c
- ! -----------------------------------------------------------------------
-
- i0 = 1580
- i1 = 1581
- tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1))
- tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1))
- table3 (i0) = tem0
- table3 (i1) = tem1
-
-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
-! 3 - phase table
-! =======================================================================
-
-subroutine qs_table (n)
-
- implicit none
-
- integer, intent (in) :: n
-
- 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
-
- tmin = table_ice - 160.
-
- ! -----------------------------------------------------------------------
- ! compute es over ice between - 160 deg c and 0 deg c.
- ! -----------------------------------------------------------------------
-
- do i = 1, 1600
- tem = tmin + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * li2
- fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas
- table (i) = e00 * exp (fac2)
- enddo
-
- ! -----------------------------------------------------------------------
- ! compute es over water between - 20 deg c and 102 deg c.
- ! -----------------------------------------------------------------------
-
- do i = 1, 1221
- tem = 253.16 + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
- esh20 = e00 * exp (fac2)
- if (i <= 200) then
- esupc (i) = esh20
- else
- table (i + 1400) = esh20
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! derive blended es over ice and supercooled water between - 20 deg c and 0 deg c
- ! -----------------------------------------------------------------------
-
- do i = 1, 200
- tem = 253.16 + delt * real (i - 1)
- wice = 0.05 * (table_ice - tem)
- wh2o = 0.05 * (tem - 253.16)
- table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i)
- enddo
-
-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, cond)
-
- implicit none
-
- 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, dimension (ks:ke) :: lcpk, icpk
-
- real :: dq, cvm
-
- integer :: k
-
- ! -----------------------------------------------------------------------
- ! define heat capacity and latent heat coefficient
- ! -----------------------------------------------------------------------
-
- 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
-
- cond = 0
-
- do k = ks, ke
-
- ! -----------------------------------------------------------------------
- ! ice phase:
- ! -----------------------------------------------------------------------
-
- ! if cloud ice < 0, borrow from snow
- if (qi (k) < 0.) then
- qs (k) = qs (k) + qi (k)
- qi (k) = 0.
- endif
- ! if snow < 0, borrow from graupel
- if (qs (k) < 0.) then
- qg (k) = qg (k) + qs (k)
- qs (k) = 0.
- endif
- ! if graupel < 0, borrow from rain
- if (qg (k) < 0.) then
- qr (k) = qr (k) + qg (k)
- pt (k) = pt (k) - qg (k) * icpk (k) ! heating
- qg (k) = 0.
- endif
-
- ! -----------------------------------------------------------------------
- ! liquid phase:
- ! -----------------------------------------------------------------------
-
- ! if rain < 0, borrow from cloud water
- if (qr (k) < 0.) then
- 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
-
- ! -----------------------------------------------------------------------
- ! fix water vapor; borrow from below
- ! -----------------------------------------------------------------------
-
- 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_cld_mp_mod
diff --git a/model/gfdl_mp.F90 b/model/gfdl_mp.F90
index f9b8b9fd7..eb925fdb9 100644
--- a/model/gfdl_mp.F90
+++ b/model/gfdl_mp.F90
@@ -18,398 +18,1099 @@
!* License along with the FV3 dynamical core.
!* If not, see .
!***********************************************************************
+
! =======================================================================
-! cloud micro - physics package for gfdl global cloud resolving model
-! the algorithms are originally derived from lin et al 1983. most of the
-! key elements have been simplified / improved. this code at this stage
-! 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
+! GFDL Cloud Microphysics Package (GFDL MP) Version 3
+! The algorithms are originally derived from Lin et al. (1983).
+! Most of the key elements have been simplified / improved.
+! This code at this stage bears little to no similarity to the original Lin MP in ZETAC.
+! Developers: Linjiong Zhou and the GFDL FV3 Team
+! References:
+! Version 0: Chen and Lin (2011 doi: 10.1029/2011GL047629, 2013 doi: 10.1175/JCLI-D-12-00061.1)
+! Version 1: Zhou et al. (2019 doi: 10.1175/BAMS-D-17-0246.1)
+! Version 2: Harris et al. (2020 doi: 10.1029/2020MS002223), Zhou et al. (2022 doi: 10.25923/pz3c-8b96)
+! Version 3: Zhou et al. (2022 doi: 10.1029/2021MS002971)
! =======================================================================
module gfdl_mp_mod
-
- 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
- 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.
-
- 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 = 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, 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, 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
-
- ! 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 (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 value
- real, parameter :: hlf0 = hlf ! gfs: fussion latent heat coefficient at 0 deg c
- ! real, parameter :: hlf0 = 3.337e5 ! emanuel value
-
- 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 = 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 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 ! used for correcting flipped height
-
- real, parameter :: sfcrho = 1.2 ! surface air density
-
- 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 :: 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
-
- 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, 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
- 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.
-
- 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
-
+
+ ! -----------------------------------------------------------------------
+ ! interface functions
+ ! -----------------------------------------------------------------------
+
+ interface wqs
+ procedure wes_t
+ procedure wqs_trho
+ procedure wqs_ptqv
+ end interface wqs
+
+ interface mqs
+ procedure mes_t
+ procedure mqs_trho
+ procedure mqs_ptqv
+ end interface mqs
+
+ interface iqs
+ procedure ies_t
+ procedure iqs_trho
+ procedure iqs_ptqv
+ end interface iqs
+
+ interface mhc
+ procedure mhc3
+ procedure mhc4
+ procedure mhc6
+ end interface mhc
+
+ interface wet_bulb
+ procedure wet_bulb_dry
+ procedure wet_bulb_moist
+ end interface wet_bulb
+
+ ! -----------------------------------------------------------------------
+ ! public subroutines, functions, and variables
+ ! -----------------------------------------------------------------------
+
+ public :: gfdl_mp_init
+ public :: gfdl_mp_driver
+ public :: gfdl_mp_end
+ public :: fast_sat_adj, cld_eff_rad, rad_ref
+ public :: qs_init, wqs, mqs, mqs3d
+ public :: c_liq, c_ice, rhow, wet_bulb
+ public :: cv_air, cv_vap, mtetw
+ public :: hlv, hlf, tice
+
+ ! -----------------------------------------------------------------------
+ ! precision definition
+ ! -----------------------------------------------------------------------
+
+ integer, parameter :: r8 = 8 ! double precision
+
+ ! -----------------------------------------------------------------------
+ ! initialization conditions
+ ! -----------------------------------------------------------------------
+
+ logical :: tables_are_initialized = .false. ! initialize satuation tables
+
+ ! -----------------------------------------------------------------------
+ ! physics constants
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS
+
+ real, parameter :: rgrav = 1.0 / grav ! inversion of gravity acceleration (s^2/m)
+
+ real, parameter :: pi = 4.0 * atan (1.0) ! ratio of circle circumference to diameter
+
+ real, parameter :: boltzmann = 1.38064852e-23 ! boltzmann constant (J/K)
+ real, parameter :: avogadro = 6.02214076e23 ! avogadro number (1/mol)
+ real, parameter :: runiver = avogadro * boltzmann ! 8.314459727525675, universal gas constant (J/K/mol)
+ real, parameter :: mmd = 2.89644e-2 ! dry air molar mass (kg/mol), ref: IFS
+ real, parameter :: mmv = 1.80153e-2 ! water vapor molar mass (kg/mol), ref: IFS
+
+ real, parameter :: rdgas = 287.05 ! gas constant for dry air (J/kg/K): ref: GFDL, GFS
+ real, parameter :: rvgas = 461.50 ! gas constant for water vapor (J/kg/K): ref: GFDL, GFS
+ !real, parameter :: rdgas = runiver / mmd ! 287.0578961596192, gas constant for dry air (J/kg/K)
+ !real, parameter :: rvgas = runiver / mmv ! 461.52213549181386, gas constant for water vapor (J/kg/K)
+
+ real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077667316114637
+ real, parameter :: eps = rdgas / rvgas ! 0.6219934994582882
+ real, parameter :: epsm1 = rdgas / rvgas - 1. ! -0.3780065005417118
+
+ real, parameter :: tice = 273.15 ! freezing temperature (K): ref: GFDL, GFS
+ !real, parameter :: tice = 273.16 ! freezing temperature (K), ref: IFS
+
+ real, parameter :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS
+ real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume (J/kg/K): ref: GFDL, GFS
+ !real, parameter :: cp_air = 7. / 2. * rdgas ! 1004.7026365586671, heat capacity of dry air at constant pressure (J/kg/K)
+ !real, parameter :: cv_air = 5. / 2. * rdgas ! 717.644740399048, heat capacity of dry air at constant volume (J/kg/K)
+ real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K)
+ real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5664064754415, heat capacity of water vapor at constant volume (J/kg/K)
+
+ real, parameter :: c_ice = 2.106e3 ! heat capacity of ice at 0 deg C (J/kg/K), ref: IFS
+ real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS
+
+ real, parameter :: dc_vap = cp_vap - c_liq ! - 2371.9114580327446, isobaric heating / cooling (J/kg/K)
+ real, parameter :: dc_ice = c_liq - c_ice ! 2112.0, isobaric heating / colling (J/kg/K)
+ real, parameter :: d2_ice = cp_vap - c_ice ! - 259.9114580327446, isobaric heating / cooling (J/kg/K)
+
+ real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS
+ real, parameter :: hlf = 3.3358e5 ! latent heat of fusion at 0 deg C (J/kg): ref: GFDL, GFS
+ !real, parameter :: hlv = 2.5008e6 ! latent heat of evaporation at 0 deg C (J/kg), ref: IFS
+ !real, parameter :: hlf = 3.345e5 ! latent heat of fusion at 0 deg C (J/kg), ref: IFS
+
+ real, parameter :: visd = 1.717e-5 ! dynamics viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (kg/m/s)
+ real, parameter :: visk = 1.35e-5 ! kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s)
+ real, parameter :: vdifu = 2.25e-5 ! diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s)
+ real, parameter :: tcond = 2.40e-2 ! thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) (J/m/s/K)
+
+ real, parameter :: rho0 = 1.0 ! reference air density (kg/m^3), ref: IFS
+ real, parameter :: cdg = 3.15121 ! drag coefficient of graupel (Locatelli and Hobbs, 1974)
+ real, parameter :: cdh = 0.5 ! drag coefficient of hail (Heymsfield and Wright, 2014)
+
+ real (kind = r8), parameter :: lv0 = hlv - dc_vap * tice ! 3148711.3338762247, evaporation latent heat coeff. at 0 deg K (J/kg)
+ real (kind = r8), parameter :: li0 = hlf - dc_ice * tice ! - 242413.92000000004, fussion latent heat coeff. at 0 deg K (J/kg)
+ real (kind = r8), parameter :: li2 = lv0 + li0 ! 2906297.413876225, sublimation latent heat coeff. at 0 deg K (J/kg)
+
+ real (kind = r8), parameter :: e00 = 611.21 ! saturation vapor pressure at 0 deg C (Pa), ref: IFS
+
+ ! -----------------------------------------------------------------------
+ ! predefined parameters
+ ! -----------------------------------------------------------------------
+
+ integer, parameter :: length = 2621 ! length of the saturation table
+
+ real, parameter :: qcmin = 1.0e-15 ! min value for cloud condensates (kg/kg)
+ real, parameter :: qfmin = 1.0e-8 ! min value for sedimentation (kg/kg)
+
+ real, parameter :: dz_min = 1.0e-2 ! used for correcting flipped height (m)
+
+ real, parameter :: rhow = 1.0e3 ! density of cloud water (kg/m^3)
+ real, parameter :: rhoi = 9.17e2 ! density of cloud ice (kg/m^3)
+ real, parameter :: rhor = 1.0e3 ! density of rain (Lin et al. 1983) (kg/m^3)
+ real, parameter :: rhos = 1.0e2 ! density of snow (Lin et al. 1983) (kg/m^3)
+ real, parameter :: rhog = 4.0e2 ! density of graupel (Rutledge and Hobbs 1984) (kg/m^3)
+ real, parameter :: rhoh = 9.17e2 ! density of hail (Lin et al. 1983) (kg/m^3)
+
+ real, parameter :: dt_fr = 8.0 ! t_wfr - dt_fr: minimum temperature water can exist (Moore and Molinero 2011)
+
+ real (kind = r8), parameter :: one_r8 = 1.0 ! constant 1
+
! -----------------------------------------------------------------------
! namelist parameters
! -----------------------------------------------------------------------
-
+
integer :: ntimes = 1 ! cloud microphysics sub cycles
-
- integer :: icloud_f = 0 ! cloud scheme
+
+ integer :: cfflag = 1 ! cloud fraction scheme
+ ! 1: GFDL cloud scheme
+ ! 2: Xu and Randall (1996)
+ ! 3: Park et al. (2016)
+ ! 4: Gultepe and Isaac (2007)
+
+ integer :: icloud_f = 0 ! GFDL cloud scheme
+ ! 0: subgrid variability based scheme
+ ! 1: same as 0, but for old fvgfs implementation
+ ! 2: binary cloud scheme
+ ! 3: extension of 0
+
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
+ ! 0: subgrid variability based scheme
+ ! 1: no subgrid varaibility
+
+ 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: Fletcher (1962)
+
+ integer :: igflag = 3 ! ice generation scheme
+ ! 1: WSM6
+ ! 2: WSM6 with 0 at 0 C
+ ! 3: WSM6 with 0 at 0 C and fixed value at - 10 C
+ ! 4: combination of 1 and 3
+
+ integer :: ifflag = 1 ! ice fall scheme
+ ! 1: Deng and Mace (2008)
+ ! 2: Heymsfield and Donner (1990)
+
+ integer :: rewflag = 1 ! cloud water effective radius scheme
+ ! 1: Martin et al. (1994)
+ ! 2: Martin et al. (1994), GFDL revision
+ ! 3: Kiehl et al. (1994)
+ ! 4: effective radius
+
+ integer :: reiflag = 5 ! cloud ice effective radius scheme
+ ! 1: Heymsfield and Mcfarquhar (1996)
+ ! 2: Donner et al. (1997)
+ ! 3: Fu (2007)
+ ! 4: Kristjansson et al. (2000)
+ ! 5: Wyser (1998)
+ ! 6: Sun and Rikus (1999), Sun (2001)
+ ! 7: effective radius
+
+ integer :: rerflag = 1 ! rain effective radius scheme
+ ! 1: effective radius
+
+ integer :: resflag = 1 ! snow effective radius scheme
+ ! 1: effective radius
+
+ integer :: regflag = 1 ! graupel effective radius scheme
+ ! 1: effective radius
+
+ integer :: radr_flag = 1 ! radar reflectivity for rain
+ ! 1: Mark Stoelinga (2005)
+ ! 2: Smith et al. (1975), Tong and Xue (2005)
+ ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology))
+
+ integer :: rads_flag = 1 ! radar reflectivity for snow
+ ! 1: Mark Stoelinga (2005)
+ ! 2: Smith et al. (1975), Tong and Xue (2005)
+ ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology))
+
+ integer :: radg_flag = 1 ! radar reflectivity for graupel
+ ! 1: Mark Stoelinga (2005)
+ ! 2: Smith et al. (1975), Tong and Xue (2005)
+ ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology))
+
+ integer :: sedflag = 1 ! sedimentation scheme
+ ! 1: implicit scheme
+ ! 2: explicit scheme
+ ! 3: lagrangian scheme
+ ! 4: combined implicit and lagrangian scheme
+
+ integer :: vdiffflag = 1 ! wind difference scheme in accretion
+ ! 1: Wisner et al. (1972)
+ ! 2: Mizuno (1990)
+ ! 3: Murakami (1990)
+
+ logical :: do_sedi_uv = .true. ! transport of horizontal momentum in sedimentation
+ logical :: do_sedi_w = .true. ! transport of vertical momentum in sedimentation
logical :: do_sedi_heat = .true. ! transport of heat in sedimentation
- logical :: prog_ccn = .false. ! do prognostic ccn (yi ming's method)
+ logical :: do_sedi_melt = .true. ! melt cloud ice, snow, and graupel during sedimentation
+
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 :: rad_snow = .true. ! include snow in cloud fraciton calculation
+ logical :: rad_graupel = .true. ! include graupel in cloud fraction calculation
+ logical :: rad_rain = .true. ! include rain in cloud fraction calculation
+ logical :: do_cld_adj = .false. ! do cloud fraction adjustment
+
+ logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions
+ logical :: z_slope_ice = .true. ! use linear mono slope for autocconversions
+
+ logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation
+ logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation
+
+ logical :: const_vw = .false. ! if .ture., the constants are specified by v * _fac
+ logical :: const_vi = .false. ! if .ture., the constants are specified by v * _fac
+ logical :: const_vs = .false. ! if .ture., the constants are specified by v * _fac
+ logical :: const_vg = .false. ! if .ture., the constants are specified by v * _fac
+ logical :: const_vr = .false. ! if .ture., the constants are specified by v * _fac
+
+ logical :: liq_ice_combine = .false. ! combine all liquid water, combine all solid water
+ logical :: snow_grauple_combine = .true. ! combine snow and graupel
+
+ logical :: prog_ccn = .false. ! do prognostic ccn (Yi Ming's method)
+
+ logical :: fix_negative = .true. ! fix negative water species
+
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)
-
+
+ logical :: do_hail = .false. ! use hail parameters instead of graupel
+
+ logical :: consv_checker = .false. ! turn on energy and water conservation checker
+
+ logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only
+
+ logical :: do_wbf = .false. ! do Wegener Bergeron Findeisen process
+
+ logical :: do_psd_water_fall = .false. ! calculate cloud water terminal velocity based on PSD
+ logical :: do_psd_ice_fall = .false. ! calculate cloud ice terminal velocity based on PSD
+
+ logical :: do_psd_water_num = .false. ! calculate cloud water number concentration based on PSD
+ logical :: do_psd_ice_num = .false. ! calculate cloud ice number concentration based on PSD
+
+ logical :: do_new_acc_water = .false. ! perform the new accretion for cloud water
+ logical :: do_new_acc_ice = .false. ! perform the new accretion for cloud ice
+
+ logical :: cp_heating = .false. ! update temperature based on constant pressure
+
+ real :: mp_time = 150.0 ! maximum microphysics time step (s)
+
+ real :: n0w_sig = 1.1 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994)
+ !real :: n0w_sig = 1.4 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994)
+ real :: n0i_sig = 1.3 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015)
+ !real :: n0i_sig = 9.4 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015)
+ real :: n0r_sig = 8.0 ! intercept parameter (significand) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948)
+ real :: n0s_sig = 3.0 ! intercept parameter (significand) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958)
+ real :: n0g_sig = 4.0 ! intercept parameter (significand) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979)
+ real :: n0h_sig = 4.0 ! intercept parameter (significand) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975)
+
+ real :: n0w_exp = 41 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994)
+ !real :: n0w_exp = 91 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994)
+ real :: n0i_exp = 18 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015)
+ !real :: n0i_exp = 17 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015)
+ real :: n0r_exp = 6 ! intercept parameter (exponent) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948)
+ real :: n0s_exp = 6 ! intercept parameter (exponent) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958)
+ real :: n0g_exp = 6 ! intercept parameter (exponent) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979)
+ real :: n0h_exp = 4 ! intercept parameter (exponent) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975)
+
+ real :: muw = 6.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994)
+ !real :: muw = 16.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994)
+ real :: mui = 3.35 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015)
+ !real :: mui = 3.54 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015)
+ real :: mur = 1.0 ! shape parameter of rain in Gamma distribution (Marshall and Palmer 1948)
+ real :: mus = 1.0 ! shape parameter of snow in Gamma distribution (Gunn and Marshall 1958)
+ real :: mug = 1.0 ! shape parameter of graupel in Gamma distribution (Houze et al. 1979)
+ real :: muh = 1.0 ! shape parameter of hail in Gamma distribution (Federer and Waldvogel 1975)
+
+ real :: alinw = 3.e7 ! "a" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990)
+ real :: alini = 7.e2 ! "a" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990)
+ real :: alinr = 842.0 ! "a" in Lin et al. (1983) for rain (Liu and Orville 1969)
+ real :: alins = 4.8 ! "a" in Lin et al. (1983) for snow (straka 2009)
+ real :: aling = 1.0 ! "a" in Lin et al. (1983), similar to a, but for graupel (Pruppacher and Klett 2010)
+ real :: alinh = 1.0 ! "a" in Lin et al. (1983), similar to a, but for hail (Pruppacher and Klett 2010)
+
+ real :: blinw = 2.0 ! "b" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990)
+ real :: blini = 1.0 ! "b" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990)
+ real :: blinr = 0.8 ! "b" in Lin et al. (1983) for rain (Liu and Orville 1969)
+ real :: blins = 0.25 ! "b" in Lin et al. (1983) for snow (straka 2009)
+ real :: bling = 0.5 ! "b" in Lin et al. (1983), similar to b, but for graupel (Pruppacher and Klett 2010)
+ real :: blinh = 0.5 ! "b" in Lin et al. (1983), similar to b, but for hail (Pruppacher and Klett 2010)
+
+ real :: tice_mlt = 273.16 ! can set ice melting temperature to 268 based on observation (Kay et al. 2016) (K)
+
+ real :: t_min = 178.0 ! minimum temperature to freeze - dry all water vapor (K)
+ real :: t_sub = 184.0 ! minimum temperature for sublimation of cloud ice (K)
+
real :: rh_inc = 0.25 ! rh increment for complete evaporation of cloud water and cloud ice
real :: rh_inr = 0.25 ! rh increment for minimum evaporation of rain
real :: rh_ins = 0.25 ! rh increment for sublimation of snow
-
- real :: tau_r2g = 900. ! rain freezing during fast_sat
- real :: tau_smlt = 900. ! snow melting
- real :: tau_g2r = 600. ! graupel melting to rain
- real :: tau_imlt = 600. ! cloud ice melting
- real :: tau_i2s = 1000. ! cloud ice to snow auto - conversion
- real :: tau_l2r = 900. ! cloud water to rain auto - conversion
- real :: tau_v2l = 150. ! water vapor to cloud water (condensation)
- 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
- real :: tau_revp = 0. ! rain evaporation
-
+
+ real :: tau_r2g = 900.0 ! rain freezing to graupel time scale (s)
+ real :: tau_i2s = 1000.0 ! cloud ice to snow autoconversion time scale (s)
+ real :: tau_l2r = 900.0 ! cloud water to rain autoconversion time scale (s)
+ real :: tau_v2l = 150.0 ! water vapor to cloud water condensation time scale (s)
+ real :: tau_l2v = 300.0 ! cloud water to water vapor evaporation time scale (s)
+ real :: tau_revp = 0.0 ! rain evaporation time scale (s)
+ real :: tau_imlt = 1200.0 ! cloud ice melting time scale (s)
+ real :: tau_smlt = 900.0 ! snow melting time scale (s)
+ real :: tau_gmlt = 600.0 ! graupel melting time scale (s)
+ real :: tau_wbf = 300.0 ! graupel melting time scale (s)
+
real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land
- real :: dw_ocean = 0.10 ! base value for ocean
-
- 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 (micron)
-
+ real :: dw_ocean = 0.10 ! base value for subgrid deviation / variability over ocean
+
+ real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3)
+ real :: ccn_l = 270.0 ! ccn over land (1/cm^3)
+
+ real :: rthresh = 10.0e-6 ! critical cloud drop radius (micron) for autoconversion
+
+ real :: cld_min = 0.05 ! minimum cloud fraction
+
+ real :: qi_lim = 1.0 ! cloud ice limiter (0: no, 1: full, >1: extra) to prevent large ice build up
+
+ real :: ql_mlt = 2.0e-3 ! maximum cloud water allowed from melted cloud ice (kg/kg)
+ real :: qs_mlt = 1.0e-6 ! maximum cloud water allowed from melted snow (kg/kg)
+
+ real :: ql_gen = 1.0e-3 ! maximum cloud water generation during remapping step (kg/kg)
+
+ real :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg)
+ real :: qi0_max = 1.0e-4 ! maximum cloud ice value (autoconverted to snow) (kg/m^3)
+
+ real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3)
+ real :: qs0_crt = 1.0e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3)
+
+ real :: c_paut = 0.55 ! cloud water to rain autoconversion efficiency
+ real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency
+ real :: c_psaci = 0.05 ! cloud ice to snow accretion efficiency (was 0.1 in ZETAC)
+ real :: c_pracw = 0.8 ! cloud water to rain accretion efficiency
+ real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency
+ real :: c_pgacw = 1.0 ! cloud water to graupel accretion efficiency
+ real :: c_pgaci = 0.05 ! cloud ice to graupel accretion efficiency (was 0.1 in ZETAC)
+ real :: c_pracs = 1.0 ! snow to rain accretion efficiency
+ real :: c_psacr = 1.0 ! rain to snow accretion efficiency
+ real :: c_pgacr = 1.0 ! rain to graupel accretion efficiency
+ real :: c_pgacs = 0.01 ! snow to graupel accretion efficiency (was 0.1 in ZETAC)
+
+ real :: is_fac = 0.2 ! cloud ice sublimation temperature factor
+ real :: ss_fac = 0.2 ! snow sublimation temperature factor
+ real :: gs_fac = 0.2 ! graupel sublimation temperature factor
+
+ real :: rh_fac = 10.0 ! cloud water condensation / evaporation relative humidity factor
+
+ real :: sed_fac = 1.0 ! coefficient for sedimentation fall, scale from 1.0 (implicit) to 0.0 (lagrangian)
+
+ real :: vw_fac = 1.0
+ real :: vi_fac = 1.0 ! IFS: if const_vi: 1 / 3
+ real :: vs_fac = 1.0 ! IFS: if const_vs: 1.
+ real :: vg_fac = 1.0 ! IFS: if const_vg: 2.
+ real :: vr_fac = 1.0 ! IFS: if const_vr: 4.
+
+ real :: vw_max = 0.01 ! maximum fall speed for cloud water (m/s)
+ real :: vi_max = 0.5 ! maximum fall speed for cloud ice (m/s)
+ real :: vs_max = 5.0 ! maximum fall speed for snow (m/s)
+ real :: vg_max = 8.0 ! maximum fall speed for graupel (m/s)
+ real :: vr_max = 12.0 ! maximum fall speed for rain (m/s)
+
+ real :: xr_a = 0.25 ! p value in Xu and Randall (1996)
+ real :: xr_b = 100.0 ! 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-5 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time
+ real :: tw_err = 1.e-8 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time
+
+ real :: rh_thres = 0.75 ! minimum relative humidity for cloud fraction
+ real :: rhc_cevap = 0.85 ! maximum relative humidity for cloud water evaporation
+ real :: rhc_revap = 0.85 ! maximum relative humidity for rain evaporation
+
+ real :: f_dq_p = 1.0 ! cloud fraction adjustment for supersaturation
+ real :: f_dq_m = 1.0 ! cloud fraction adjustment for undersaturation
+
+ real :: fi2s_fac = 1.0 ! maximum sink of cloud ice to form snow: 0-1
+ real :: fi2g_fac = 1.0 ! maximum sink of cloud ice to form graupel: 0-1
+ real :: fs2g_fac = 1.0 ! maximum sink of snow to form graupel: 0-1
+
+ real :: beta = 1.22 ! defined in Heymsfield and Mcfarquhar (1996)
+
+ real :: rewmin = 5.0, rewmax = 15.0 ! minimum and maximum effective radius for cloud water (micron)
+ real :: reimin = 10.0, reimax = 150.0 ! minimum and maximum effective radius for cloud ice (micron)
+ real :: rermin = 15.0, rermax = 10000.0 ! minimum and maximum effective radius for rain (micron)
+ real :: resmin = 150.0, resmax = 10000.0 ! minimum and maximum effective radius for snow (micron)
+ real :: regmin = 150.0, regmax = 10000.0 ! minimum and maximum effective radius for graupel
+ !real :: rewmax = 15.0, rermin = 15.0 ! Kokhanovsky (2004)
+
+ real :: rewfac = 1.0 ! this is a tuning parameter to compromise the inconsistency between
+ ! GFDL MP's PSD and cloud water radiative property's PSD assumption.
+ ! after the cloud water radiative property's PSD is rebuilt,
+ ! this parameter should be 1.0.
+ real :: reifac = 1.0 ! this is a tuning parameter to compromise the inconsistency between
+ ! GFDL MP's PSD and cloud ice radiative property's PSD assumption.
+ ! after the cloud ice radiative property's PSD is rebuilt,
+ ! this parameter should be 1.0.
+
! -----------------------------------------------------------------------
- ! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33
- ! optimized: qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp)))
- ! qi_gen ~ 4.808e-7 at 0 c; 1.818e-6 at - 10 c, 9.82679e-5 at - 40c
- ! the following value is constructed such that qc_crt = 0 at zero c and @ - 10c matches
- ! wrf / wsm6 ice initiation scheme; qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den
+ ! local shared variables
! -----------------------------------------------------------------------
+
+ real :: acco (3, 10), acc (20)
+ real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw
+ real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (4), cgmlt (4)
+
+ real :: t_wfr, fac_rc, c_air, c_vap, d0_vap
+
+ real (kind = r8) :: lv00, li00, li20, cpaut
+ real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice
+ real (kind = r8) :: normw, normr, normi, norms, normg, normh
+ real (kind = r8) :: expow, expor, expoi, expos, expog, expoh
+ real (kind = r8) :: pcaw, pcar, pcai, pcas, pcag, pcah
+ real (kind = r8) :: pcbw, pcbr, pcbi, pcbs, pcbg, pcbh
+ real (kind = r8) :: edaw, edar, edai, edas, edag, edah
+ real (kind = r8) :: edbw, edbr, edbi, edbs, edbg, edbh
+ real (kind = r8) :: oeaw, oear, oeai, oeas, oeag, oeah
+ real (kind = r8) :: oebw, oebr, oebi, oebs, oebg, oebh
+ real (kind = r8) :: rraw, rrar, rrai, rras, rrag, rrah
+ real (kind = r8) :: rrbw, rrbr, rrbi, rrbs, rrbg, rrbh
+ real (kind = r8) :: tvaw, tvar, tvai, tvas, tvag, tvah
+ real (kind = r8) :: tvbw, tvbr, tvbi, tvbs, tvbg, tvbh
+
+ real, allocatable :: table0 (:), table1 (:), table2 (:), table3 (:), table4 (:)
+ real, allocatable :: des0 (:), des1 (:), des2 (:), des3 (:), des4 (:)
+
+ ! -----------------------------------------------------------------------
+ ! namelist
+ ! -----------------------------------------------------------------------
+
+ namelist / gfdl_mp_nml / &
+ t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, &
+ vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, &
+ vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, &
+ rh_inc, rh_ins, rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, &
+ ccn_l, ccn_o, igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, &
+ tau_l2r, qi_lim, ql_gen, do_hail, inflag, c_psacw, c_psaci, c_pracs, &
+ c_psacr, c_pgacr, c_pgacs, c_pgacw, c_pgaci, z_slope_liq, z_slope_ice, &
+ prog_ccn, c_pracw, c_praci, rad_snow, rad_graupel, rad_rain, cld_min, &
+ sedflag, sed_fac, do_sedi_uv, do_sedi_w, do_sedi_heat, icloud_f, &
+ irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, do_cond_timescale, &
+ mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, use_rhc_revap, tau_wbf, &
+ do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, rhc_cevap, &
+ rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, &
+ regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, &
+ resmax, regmin, regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, &
+ radr_flag, rads_flag, radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, &
+ n0w_sig, n0i_sig, n0r_sig, n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, &
+ n0r_exp, n0s_exp, n0g_exp, n0h_exp, muw, mui, mur, mus, mug, muh, &
+ alinw, alini, alinr, alins, aling, alinh, blinw, blini, blinr, blins, bling, blinh, &
+ do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac, &
+ snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, &
+ cp_heating
+
+contains
- real :: sat_adj0 = 0.90 ! adjustment factor (0: no, 1: full) during fast_sat_adj
-
- real :: qc_crt = 5.0e-8 ! mini condensate mixing ratio to allow partial cloudiness
-
- real :: qi_lim = 1. ! cloud ice limiter to prevent large ice build up
-
- 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 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) (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
- ! 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: (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 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
-
- 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
-
- 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
-
- 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 :: do_hail = .false. ! use hail parameters instead of graupel
- 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
+! =======================================================================
+! GFDL cloud microphysics initialization
+! =======================================================================
- real :: g2, log_10
+subroutine gfdl_mp_init (input_nml_file, logunit, hydrostatic)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ logical, intent (in) :: hydrostatic
+
+ integer, intent (in) :: logunit
+
+ character (len = *), intent (in) :: input_nml_file (:)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ logical :: exists
+
+ ! -----------------------------------------------------------------------
+ ! read namelist
+ ! -----------------------------------------------------------------------
+
+ read (input_nml_file, nml = gfdl_mp_nml)
+
+ ! -----------------------------------------------------------------------
+ ! write namelist to log file
+ ! -----------------------------------------------------------------------
+
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "gfdl_mp_mod"
+ write (logunit, nml = gfdl_mp_nml)
+
+ ! -----------------------------------------------------------------------
+ ! initialize microphysics variables
+ ! -----------------------------------------------------------------------
+
+ if (.not. tables_are_initialized) call qs_init
+
+ call setup_mp
+
+ ! -----------------------------------------------------------------------
+ ! define various heat capacities and latent heat coefficients at 0 deg K
+ ! -----------------------------------------------------------------------
+
+ call setup_mhc_lhc (hydrostatic)
+
+end subroutine gfdl_mp_init
- real :: rh_thres = 0.75
- real :: rhc_cevap = 0.85 ! cloud water
- real :: rhc_revap = 0.85 ! cloud water
+! =======================================================================
+! GFDL cloud microphysics driver
+! =======================================================================
- real :: f_dq_p = 1.0
- real :: f_dq_m = 1.0
- logical :: do_cld_adj = .false.
+subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, &
+ ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, &
+ hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, &
+ pcw, edw, oew, rrw, tvw, pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, &
+ pcs, eds, oes, rrs, tvs, pcg, edg, oeg, rrg, tvg, &
+ prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, condensation, &
+ deposition, evaporation, sublimation, last_step, do_inline_mp)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: is, ie, ks, ke
+
+ logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp
+
+ real, intent (in) :: dtm
+
+ real, intent (in), dimension (is:ie) :: hs, gsize
+
+ real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
+
+ real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa, te
+ real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+ real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
+
+ real, intent (inout), dimension (is:, ks:) :: q_con, cappa
+
+ real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel
+ real, intent (inout), dimension (is:ie) :: condensation, deposition
+ real, intent (inout), dimension (is:ie) :: evaporation, sublimation
+
+ real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr
+ real, intent (out), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw
+ real, intent (out), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi
+ real, intent (out), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr
+ real, intent (out), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs
+ real, intent (out), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg
- 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
+ real (kind = r8), intent (out), dimension (is:ie) :: dte
! -----------------------------------------------------------------------
- ! namelist
+ ! major cloud microphysics driver
! -----------------------------------------------------------------------
+
+ call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, &
+ qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, &
+ gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, &
+ pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, &
+ pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, &
+ prefluxs, prefluxg, condensation, deposition, evaporation, sublimation, &
+ last_step, do_inline_mp, .false., .true.)
+
+end subroutine gfdl_mp_driver
- 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, 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, 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
+! =======================================================================
+! GFDL cloud microphysics end
+! =======================================================================
-! -----------------------------------------------------------------------
-! the driver of the gfdl cloud microphysics
-! -----------------------------------------------------------------------
+subroutine gfdl_mp_end
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! free up memory
+ ! -----------------------------------------------------------------------
+
+ deallocate (table0)
+ deallocate (table1)
+ deallocate (table2)
+ deallocate (table3)
+ deallocate (table4)
+ deallocate (des0)
+ deallocate (des1)
+ deallocate (des2)
+ deallocate (des3)
+ deallocate (des4)
+
+ tables_are_initialized = .false.
+
+end subroutine gfdl_mp_end
-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, is, ie, ks, ke, q_con, cappa, consv_te, &
- te, condensation, deposition, evaporation, sublimation, last_step, do_inline_mp)
+! =======================================================================
+! setup cloud microphysics parameters
+! =======================================================================
+subroutine setup_mp
+
implicit none
+
+ integer :: i, k
+
+ real :: gcon, hcon, scm3, pisq, act (20), ace (20), occ (3), aone
+
+ ! -----------------------------------------------------------------------
+ ! complete freezing temperature
+ ! -----------------------------------------------------------------------
+
+ if (do_warm_rain_mp) then
+ t_wfr = t_min
+ else
+ t_wfr = tice - 40.0
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! cloud water autoconversion, Hong et al. (2004)
+ ! -----------------------------------------------------------------------
+
+ fac_rc = (4. / 3.) * pi * rhow * rthresh ** 3
+
+ aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.)
+ cpaut = c_paut * aone * grav / visd
+
+ ! -----------------------------------------------------------------------
+ ! terminal velocities parameters, Lin et al. (1983)
+ ! -----------------------------------------------------------------------
+
+ gcon = (4. * grav * rhog / (3. * cdg * rho0)) ** 0.5
+ hcon = (4. * grav * rhoh / (3. * cdh * rho0)) ** 0.5
+
+ ! -----------------------------------------------------------------------
+ ! part of the slope parameters
+ ! -----------------------------------------------------------------------
+
+ normw = pi * rhow * n0w_sig * gamma (muw + 3)
+ normi = pi * rhoi * n0i_sig * gamma (mui + 3)
+ normr = pi * rhor * n0r_sig * gamma (mur + 3)
+ norms = pi * rhos * n0s_sig * gamma (mus + 3)
+ normg = pi * rhog * n0g_sig * gamma (mug + 3)
+ normh = pi * rhoh * n0h_sig * gamma (muh + 3)
+
+ expow = exp (n0w_exp / (muw + 3) * log (10.))
+ expoi = exp (n0i_exp / (mui + 3) * log (10.))
+ expor = exp (n0r_exp / (mur + 3) * log (10.))
+ expos = exp (n0s_exp / (mus + 3) * log (10.))
+ expog = exp (n0g_exp / (mug + 3) * log (10.))
+ expoh = exp (n0h_exp / (muh + 3) * log (10.))
- logical, intent (in) :: hydrostatic
- logical, intent (in) :: last_step
- logical, intent (in) :: consv_te
- logical, intent (in) :: do_inline_mp
+ ! -----------------------------------------------------------------------
+ ! parameters for particle concentration (pc), effective diameter (ed),
+ ! optical extinction (oe), radar reflectivity factor (rr), and
+ ! mass-weighted terminal velocity (tv)
+ ! -----------------------------------------------------------------------
+
+ pcaw = exp (3 / (muw + 3) * log (n0w_sig)) * gamma (muw) * exp (3 * n0w_exp / (muw + 3) * log (10.))
+ pcai = exp (3 / (mui + 3) * log (n0i_sig)) * gamma (mui) * exp (3 * n0i_exp / (mui + 3) * log (10.))
+ pcar = exp (3 / (mur + 3) * log (n0r_sig)) * gamma (mur) * exp (3 * n0r_exp / (mur + 3) * log (10.))
+ pcas = exp (3 / (mus + 3) * log (n0s_sig)) * gamma (mus) * exp (3 * n0s_exp / (mus + 3) * log (10.))
+ pcag = exp (3 / (mug + 3) * log (n0g_sig)) * gamma (mug) * exp (3 * n0g_exp / (mug + 3) * log (10.))
+ pcah = exp (3 / (muh + 3) * log (n0h_sig)) * gamma (muh) * exp (3 * n0h_exp / (muh + 3) * log (10.))
+
+ pcbw = exp (muw / (muw + 3) * log (pi * rhow * gamma (muw + 3)))
+ pcbi = exp (mui / (mui + 3) * log (pi * rhoi * gamma (mui + 3)))
+ pcbr = exp (mur / (mur + 3) * log (pi * rhor * gamma (mur + 3)))
+ pcbs = exp (mus / (mus + 3) * log (pi * rhos * gamma (mus + 3)))
+ pcbg = exp (mug / (mug + 3) * log (pi * rhog * gamma (mug + 3)))
+ pcbh = exp (muh / (muh + 3) * log (pi * rhoh * gamma (muh + 3)))
+
+ edaw = exp (- 1. / (muw + 3) * log (n0w_sig)) * (muw + 2) * exp (- n0w_exp / (muw + 3) * log (10.))
+ edai = exp (- 1. / (mui + 3) * log (n0i_sig)) * (mui + 2) * exp (- n0i_exp / (mui + 3) * log (10.))
+ edar = exp (- 1. / (mur + 3) * log (n0r_sig)) * (mur + 2) * exp (- n0r_exp / (mur + 3) * log (10.))
+ edas = exp (- 1. / (mus + 3) * log (n0s_sig)) * (mus + 2) * exp (- n0s_exp / (mus + 3) * log (10.))
+ edag = exp (- 1. / (mug + 3) * log (n0g_sig)) * (mug + 2) * exp (- n0g_exp / (mug + 3) * log (10.))
+ edah = exp (- 1. / (muh + 3) * log (n0h_sig)) * (muh + 2) * exp (- n0h_exp / (muh + 3) * log (10.))
+
+ edbw = exp (1. / (muw + 3) * log (pi * rhow * gamma (muw + 3)))
+ edbi = exp (1. / (mui + 3) * log (pi * rhoi * gamma (mui + 3)))
+ edbr = exp (1. / (mur + 3) * log (pi * rhor * gamma (mur + 3)))
+ edbs = exp (1. / (mus + 3) * log (pi * rhos * gamma (mus + 3)))
+ edbg = exp (1. / (mug + 3) * log (pi * rhog * gamma (mug + 3)))
+ edbh = exp (1. / (muh + 3) * log (pi * rhoh * gamma (muh + 3)))
+
+ oeaw = exp (1. / (muw + 3) * log (n0w_sig)) * pi * gamma (muw + 2) * &
+ exp (n0w_exp / (muw + 3) * log (10.))
+ oeai = exp (1. / (mui + 3) * log (n0i_sig)) * pi * gamma (mui + 2) * &
+ exp (n0i_exp / (mui + 3) * log (10.))
+ oear = exp (1. / (mur + 3) * log (n0r_sig)) * pi * gamma (mur + 2) * &
+ exp (n0r_exp / (mur + 3) * log (10.))
+ oeas = exp (1. / (mus + 3) * log (n0s_sig)) * pi * gamma (mus + 2) * &
+ exp (n0s_exp / (mus + 3) * log (10.))
+ oeag = exp (1. / (mug + 3) * log (n0g_sig)) * pi * gamma (mug + 2) * &
+ exp (n0g_exp / (mug + 3) * log (10.))
+ oeah = exp (1. / (muh + 3) * log (n0h_sig)) * pi * gamma (muh + 2) * &
+ exp (n0h_exp / (muh + 3) * log (10.))
+
+ oebw = 2 * exp ((muw + 2) / (muw + 3) * log (pi * rhow * gamma (muw + 3)))
+ oebi = 2 * exp ((mui + 2) / (mui + 3) * log (pi * rhoi * gamma (mui + 3)))
+ oebr = 2 * exp ((mur + 2) / (mur + 3) * log (pi * rhor * gamma (mur + 3)))
+ oebs = 2 * exp ((mus + 2) / (mus + 3) * log (pi * rhos * gamma (mus + 3)))
+ oebg = 2 * exp ((mug + 2) / (mug + 3) * log (pi * rhog * gamma (mug + 3)))
+ oebh = 2 * exp ((muh + 2) / (muh + 3) * log (pi * rhoh * gamma (muh + 3)))
+
+ rraw = exp (- 3 / (muw + 3) * log (n0w_sig)) * gamma (muw + 6) * &
+ exp (- 3 * n0w_exp / (muw + 3) * log (10.))
+ rrai = exp (- 3 / (mui + 3) * log (n0i_sig)) * gamma (mui + 6) * &
+ exp (- 3 * n0i_exp / (mui + 3) * log (10.))
+ rrar = exp (- 3 / (mur + 3) * log (n0r_sig)) * gamma (mur + 6) * &
+ exp (- 3 * n0r_exp / (mur + 3) * log (10.))
+ rras = exp (- 3 / (mus + 3) * log (n0s_sig)) * gamma (mus + 6) * &
+ exp (- 3 * n0s_exp / (mus + 3) * log (10.))
+ rrag = exp (- 3 / (mug + 3) * log (n0g_sig)) * gamma (mug + 6) * &
+ exp (- 3 * n0g_exp / (mug + 3) * log (10.))
+ rrah = exp (- 3 / (muh + 3) * log (n0h_sig)) * gamma (muh + 6) * &
+ exp (- 3 * n0h_exp / (muh + 3) * log (10.))
+
+ rrbw = exp ((muw + 6) / (muw + 3) * log (pi * rhow * gamma (muw + 3)))
+ rrbi = exp ((mui + 6) / (mui + 3) * log (pi * rhoi * gamma (mui + 3)))
+ rrbr = exp ((mur + 6) / (mur + 3) * log (pi * rhor * gamma (mur + 3)))
+ rrbs = exp ((mus + 6) / (mus + 3) * log (pi * rhos * gamma (mus + 3)))
+ rrbg = exp ((mug + 6) / (mug + 3) * log (pi * rhog * gamma (mug + 3)))
+ rrbh = exp ((muh + 6) / (muh + 3) * log (pi * rhoh * gamma (muh + 3)))
+
+ tvaw = exp (- blinw / (muw + 3) * log (n0w_sig)) * alinw * gamma (muw + blinw + 3) * &
+ exp (- blinw * n0w_exp / (muw + 3) * log (10.))
+ tvai = exp (- blini / (mui + 3) * log (n0i_sig)) * alini * gamma (mui + blini + 3) * &
+ exp (- blini * n0i_exp / (mui + 3) * log (10.))
+ tvar = exp (- blinr / (mur + 3) * log (n0r_sig)) * alinr * gamma (mur + blinr + 3) * &
+ exp (- blinr * n0r_exp / (mur + 3) * log (10.))
+ tvas = exp (- blins / (mus + 3) * log (n0s_sig)) * alins * gamma (mus + blins + 3) * &
+ exp (- blins * n0s_exp / (mus + 3) * log (10.))
+ tvag = exp (- bling / (mug + 3) * log (n0g_sig)) * aling * gamma (mug + bling + 3) * &
+ exp (- bling * n0g_exp / (mug + 3) * log (10.)) * gcon
+ tvah = exp (- blinh / (muh + 3) * log (n0h_sig)) * alinh * gamma (muh + blinh + 3) * &
+ exp (- blinh * n0h_exp / (muh + 3) * log (10.)) * hcon
+
+ tvbw = exp (blinw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) * gamma (muw + 3)
+ tvbi = exp (blini / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) * gamma (mui + 3)
+ tvbr = exp (blinr / (mur + 3) * log (pi * rhor * gamma (mur + 3))) * gamma (mur + 3)
+ tvbs = exp (blins / (mus + 3) * log (pi * rhos * gamma (mus + 3))) * gamma (mus + 3)
+ tvbg = exp (bling / (mug + 3) * log (pi * rhog * gamma (mug + 3))) * gamma (mug + 3)
+ tvbh = exp (blinh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) * gamma (muh + 3)
+
+ ! -----------------------------------------------------------------------
+ ! Schmidt number, Sc ** (1 / 3) in Lin et al. (1983)
+ ! -----------------------------------------------------------------------
+
+ scm3 = exp (1. / 3. * log (visk / vdifu))
+
+ pisq = pi * pi
+
+ ! -----------------------------------------------------------------------
+ ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983)
+ ! -----------------------------------------------------------------------
- integer, intent (in) :: is, ie ! physics window
- integer, intent (in) :: ks, ke ! vertical dimension
+ cracw = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / &
+ (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * &
+ exp ((1 - blinr) * log (expor))
+ craci = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / &
+ (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * &
+ exp ((1 - blinr) * log (expor))
+ csacw = pi * n0s_sig * alins * gamma (2 + mus + blins) / &
+ (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * &
+ exp ((1 - blins) * log (expos))
+ csaci = pi * n0s_sig * alins * gamma (2 + mus + blins) / &
+ (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * &
+ exp ((1 - blins) * log (expos))
+ if (do_hail) then
+ cgacw = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / &
+ (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * &
+ exp ((1 - blinh) * log (expoh))
+ cgaci = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / &
+ (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * &
+ exp ((1 - blinh) * log (expoh))
+ else
+ cgacw = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / &
+ (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * &
+ exp ((1 - bling) * log (expog))
+ cgaci = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / &
+ (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * &
+ exp ((1 - bling) * log (expog))
+ endif
- real, intent (in) :: dts ! physics time step
+ if (do_new_acc_water) then
+
+ cracw = pisq * n0r_sig * n0w_sig * rhow / 24.
+ csacw = pisq * n0s_sig * n0w_sig * rhow / 24.
+ if (do_hail) then
+ cgacw = pisq * n0h_sig * n0w_sig * rhow / 24.
+ else
+ cgacw = pisq * n0g_sig * n0w_sig * rhow / 24.
+ endif
- real, intent (in), dimension (is:ie) :: hs, gsize
+ endif
- real, intent (in), dimension (is:ie, ks:ke) :: dz
- real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
+ if (do_new_acc_ice) then
+
+ craci = pisq * n0r_sig * n0i_sig * rhoi / 24.
+ csaci = pisq * n0s_sig * n0i_sig * rhoi / 24.
+ if (do_hail) then
+ cgaci = pisq * n0h_sig * n0i_sig * rhoi / 24.
+ else
+ cgaci = pisq * n0g_sig * n0i_sig * rhoi / 24.
+ endif
- 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
+ endif
- 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
+ cracw = cracw * c_pracw
+ craci = craci * c_praci
+ csacw = csacw * c_psacw
+ csaci = csaci * c_psaci
+ cgacw = cgacw * c_pgacw
+ cgaci = cgaci * c_pgaci
- if (last_step) then
- p_min = p0_min ! final clean - up
+ ! -----------------------------------------------------------------------
+ ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983)
+ ! -----------------------------------------------------------------------
+
+ cracs = pisq * n0r_sig * n0s_sig * rhos / 24.
+ csacr = pisq * n0s_sig * n0r_sig * rhor / 24.
+ if (do_hail) then
+ cgacr = pisq * n0h_sig * n0r_sig * rhor / 24.
+ cgacs = pisq * n0h_sig * n0s_sig * rhos / 24.
else
- p_min = 30.e2 ! time saving trick
+ cgacr = pisq * n0g_sig * n0r_sig * rhor / 24.
+ cgacs = pisq * n0g_sig * n0s_sig * rhos / 24.
endif
-
+
+ cracs = cracs * c_pracs
+ csacr = csacr * c_psacr
+ cgacr = cgacr * c_pgacr
+ cgacs = cgacs * c_pgacs
+
+ ! act / ace / acc:
+ ! 1 - 2: racs (s - r)
+ ! 3 - 4: sacr (r - s)
+ ! 5 - 6: gacr (r - g)
+ ! 7 - 8: gacs (s - g)
+ ! 9 - 10: racw (w - r)
+ ! 11 - 12: raci (i - r)
+ ! 13 - 14: sacw (w - s)
+ ! 15 - 16: saci (i - s)
+ ! 17 - 18: sacw (w - g)
+ ! 19 - 20: saci (i - g)
+
+ act (1) = norms
+ act (2) = normr
+ act (3) = act (2)
+ act (4) = act (1)
+ act (5) = act (2)
+ if (do_hail) then
+ act (6) = normh
+ else
+ act (6) = normg
+ endif
+ act (7) = act (1)
+ act (8) = act (6)
+ act (9) = normw
+ act (10) = act (2)
+ act (11) = normi
+ act (12) = act (2)
+ act (13) = act (9)
+ act (14) = act (1)
+ act (15) = act (11)
+ act (16) = act (1)
+ act (17) = act (9)
+ act (18) = act (6)
+ act (19) = act (11)
+ act (20) = act (6)
+
+ ace (1) = expos
+ ace (2) = expor
+ ace (3) = ace (2)
+ ace (4) = ace (1)
+ ace (5) = ace (2)
+ if (do_hail) then
+ ace (6) = expoh
+ else
+ ace (6) = expog
+ endif
+ ace (7) = ace (1)
+ ace (8) = ace (6)
+ ace (9) = expow
+ ace (10) = ace (2)
+ ace (11) = expoi
+ ace (12) = ace (2)
+ ace (13) = ace (9)
+ ace (14) = ace (1)
+ ace (15) = ace (11)
+ ace (16) = ace (1)
+ ace (17) = ace (9)
+ ace (18) = ace (6)
+ ace (19) = ace (11)
+ ace (20) = ace (6)
+
+ acc (1) = mus
+ acc (2) = mur
+ acc (3) = acc (2)
+ acc (4) = acc (1)
+ acc (5) = acc (2)
+ if (do_hail) then
+ acc (6) = muh
+ else
+ acc (6) = mug
+ endif
+ acc (7) = acc (1)
+ acc (8) = acc (6)
+ acc (9) = muw
+ acc (10) = acc (2)
+ acc (11) = mui
+ acc (12) = acc (2)
+ acc (13) = acc (9)
+ acc (14) = acc (1)
+ acc (15) = acc (11)
+ acc (16) = acc (1)
+ acc (17) = acc (9)
+ acc (18) = acc (6)
+ acc (19) = acc (11)
+ acc (20) = acc (6)
+
+ occ (1) = 1.
+ occ (2) = 2.
+ occ (3) = 1.
+
+ do i = 1, 3
+ do k = 1, 10
+ acco (i, k) = occ (i) * gamma (6 + acc (2 * k - 1) - i) * gamma (acc (2 * k) + i - 1) / &
+ (exp ((6 + acc (2 * k - 1) - i) / (acc (2 * k - 1) + 3) * log (act (2 * k - 1))) * &
+ exp ((acc (2 * k) + i - 1) / (acc (2 * k) + 3) * log (act (2 * k)))) * &
+ exp ((i - 3) * log (ace (2 * k - 1))) * exp ((4 - i) * log (ace (2 * k)))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! rain evaporation, snow sublimation, and graupel or hail sublimation, Lin et al. (1983)
+ ! -----------------------------------------------------------------------
+
+ crevp (1) = 2. * pi * vdifu * tcond * rvgas * n0r_sig * gamma (1 + mur) / &
+ exp ((1 + mur) / (mur + 3) * log (normr)) * exp (2.0 * log (expor))
+ crevp (2) = 0.78
+ crevp (3) = 0.31 * scm3 * sqrt (alinr / visk) * gamma ((3 + 2 * mur + blinr) / 2) / &
+ exp ((3 + 2 * mur + blinr) / (mur + 3) / 2 * log (normr)) * &
+ exp ((1 + mur) / (mur + 3) * log (normr)) / gamma (1 + mur) * &
+ exp ((- 1 - blinr) / 2. * log (expor))
+ crevp (4) = tcond * rvgas
+ crevp (5) = vdifu
+
+ cssub (1) = 2. * pi * vdifu * tcond * rvgas * n0s_sig * gamma (1 + mus) / &
+ exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos))
+ cssub (2) = 0.78
+ cssub (3) = 0.31 * scm3 * sqrt (alins / visk) * gamma ((3 + 2 * mus + blins) / 2) / &
+ exp ((3 + 2 * mus + blins) / (mus + 3) / 2 * log (norms)) * &
+ exp ((1 + mus) / (mus + 3) * log (norms)) / gamma (1 + mus) * &
+ exp ((- 1 - blins) / 2. * log (expos))
+ cssub (4) = tcond * rvgas
+ cssub (5) = vdifu
+
+ if (do_hail) then
+ cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0h_sig * gamma (1 + muh) / &
+ exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh))
+ cgsub (2) = 0.78
+ cgsub (3) = 0.31 * scm3 * sqrt (alinh * hcon / visk) * gamma ((3 + 2 * muh + blinh) / 2) / &
+ exp (1. / (muh + 3) * (3 + 2 * muh + blinh) / 2 * log (normh)) * &
+ exp (1. / (muh + 3) * (1 + muh) * log (normh)) / gamma (1 + muh) * &
+ exp ((- 1 - blinh) / 2. * log (expoh))
+ else
+ cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0g_sig * gamma (1 + mug) / &
+ exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog))
+ cgsub (2) = 0.78
+ cgsub (3) = 0.31 * scm3 * sqrt (aling * gcon / visk) * gamma ((3 + 2 * mug + bling) / 2) / &
+ exp ((3 + 2 * mug + bling) / (mug + 3) / 2 * log (normg)) * &
+ exp ((1 + mug) / (mug + 3) * log (normg)) / gamma (1 + mug) * &
+ exp ((- 1 - bling) / 2. * log (expog))
+ endif
+ cgsub (4) = tcond * rvgas
+ cgsub (5) = vdifu
+
! -----------------------------------------------------------------------
- ! define heat capacity of dry air and water vapor based on hydrostatical property
+ ! snow melting, Lin et al. (1983)
! -----------------------------------------------------------------------
+
+ csmlt (1) = 2. * pi * tcond * n0s_sig * gamma (1 + mus) / &
+ exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos))
+ csmlt (2) = 2. * pi * vdifu * n0s_sig * gamma (1 + mus) / &
+ exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos))
+ csmlt (3) = cssub (2)
+ csmlt (4) = cssub (3)
+
+ ! -----------------------------------------------------------------------
+ ! graupel or hail melting, Lin et al. (1983)
+ ! -----------------------------------------------------------------------
+
+ if (do_hail) then
+ cgmlt (1) = 2. * pi * tcond * n0h_sig * gamma (1 + muh) / &
+ exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh))
+ cgmlt (2) = 2. * pi * vdifu * n0h_sig * gamma (1 + muh) / &
+ exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh))
+ else
+ cgmlt (1) = 2. * pi * tcond * n0g_sig * gamma (1 + mug) / &
+ exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog))
+ cgmlt (2) = 2. * pi * vdifu * n0g_sig * gamma (1 + mug) / &
+ exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog))
+ endif
+ cgmlt (3) = cgsub (2)
+ cgmlt (4) = cgsub (3)
+
+ ! -----------------------------------------------------------------------
+ ! rain freezing, Lin et al. (1983)
+ ! -----------------------------------------------------------------------
+
+ cgfr (1) = 1.e2 / 36 * pisq * n0r_sig * rhor * gamma (6 + mur) / &
+ exp ((6 + mur) / (mur + 3) * log (normr)) * exp (- 3.0 * log (expor))
+ cgfr (2) = 0.66
+
+end subroutine setup_mp
+! =======================================================================
+! define various heat capacities and latent heat coefficients at 0 deg K
+! =======================================================================
+
+subroutine setup_mhc_lhc (hydrostatic)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ logical, intent (in) :: hydrostatic
+
if (hydrostatic) then
c_air = cp_air
c_vap = cp_vap
@@ -419,191 +1120,184 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, &
c_vap = cv_vap
endif
d0_vap = c_vap - c_liq
-
- ! scaled constants (to reduce fp errors for 32 - bit) :
+
+ ! scaled constants (to reduce float point errors for 32-bit)
+
d1_vap = d0_vap / c_air
d1_ice = dc_ice / c_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
+
+ lv00 = (hlv - d0_vap * tice) / c_air
+ li00 = (hlf - dc_ice * tice) / c_air
li20 = lv00 + li00
-
+
c1_vap = c_vap / c_air
c1_liq = c_liq / c_air
c1_ice = c_ice / c_air
+
+end subroutine setup_mhc_lhc
- ! -----------------------------------------------------------------------
- ! define latent heat coefficient used in wet bulb and bigg mechanism
- ! -----------------------------------------------------------------------
-
- lat2 = (hlv + hlf) ** 2
-
- lcp = hlv / cp_air
- icp = hlf / cp_air
- tcp = (hlv + hlf) / cp_air
-
- ! tendency zero out for am moist processes should be done outside the driver
+! =======================================================================
+! major cloud microphysics driver
+! =======================================================================
+subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, &
+ qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, &
+ gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, &
+ pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, &
+ pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, &
+ condensation, deposition, evaporation, sublimation, last_step, do_inline_mp, &
+ do_mp_fast, do_mp_full)
+
+ implicit none
+
! -----------------------------------------------------------------------
- ! major cloud microphysics
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- 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_mp_driver
-
-! -----------------------------------------------------------------------
-! gfdl cloud microphysics, major program
-! lin et al., 1983, jam, 1065 - 1092, and
-! rutledge and hobbs, 1984, jas, 2949 - 2972
-! terminal fall is handled lagrangianly by conservative fv algorithm
-! pt: temperature (k)
-! 6 water species:
-! 1) qv: water vapor (kg / kg)
-! 2) ql: cloud water (kg / kg)
-! 3) qr: rain (kg / kg)
-! 4) qi: cloud ice (kg / kg)
-! 5) qs: snow (kg / kg)
-! 6) qg: graupel (kg / kg)
-! -----------------------------------------------------------------------
-
-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
- 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
+
+ logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp
+ logical, intent (in) :: do_mp_fast, do_mp_full
+
+ real, intent (in) :: dtm
+
+ real, intent (in), dimension (is:ie) :: gsize, hs
+
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) :: delp, delz, pt, ua, va, wa
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) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
+
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) :: water, rain, ice, snow, 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, adj_vmr
+ real, intent (out), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw
+ real, intent (out), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi
+ real, intent (out), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr
+ real, intent (out), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs
+ real, intent (out), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg
+
+ real (kind = r8), intent (out), dimension (is:ie) :: dte
- 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
- 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
-
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
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
-
+
+ real :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2
+ real :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni
+
+ real, dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0
+ real, dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz
+ real, dimension (ks:ke) :: den, pz, denfac, ccn, cin
+ real, dimension (ks:ke) :: u, v, w
+
+ real (kind = r8) :: con_r8, c8, cp8
+
+ real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d
+ real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_m, te_end_m, tw_beg_m, tw_end_m
+
+ real (kind = r8), dimension (is:ie) :: te_b_beg_d, te_b_end_d, tw_b_beg_d, tw_b_end_d, te_loss
+ real (kind = r8), dimension (is:ie) :: te_b_beg_m, te_b_end_m, tw_b_beg_m, tw_b_end_m
+
+ real (kind = r8), dimension (ks:ke) :: tz, tzuv, tzw
+
+ ! -----------------------------------------------------------------------
+ ! time steps
+ ! -----------------------------------------------------------------------
+
+ ntimes = max (ntimes, int (dtm / min (dtm, mp_time)))
+ dts = dtm / real (ntimes)
+
+ ! -----------------------------------------------------------------------
+ ! initialization of total energy difference and condensation diag
+ ! -----------------------------------------------------------------------
+
dte = 0.0
-
- ! convert to mm / day
- convt = 86400. * rdt * rgrav
cond = 0.0
-
+ adj_vmr = 1.0
+
! -----------------------------------------------------------------------
- ! use local variables
+ ! unit convert to mm/day
! -----------------------------------------------------------------------
-
+
+ convt = 86400. * rgrav / dts
+
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))))
-#else
- tz (k) = pt (i, k) / (1. + zvir * qv (i, k))
-#endif
- else
+
+ ! -----------------------------------------------------------------------
+ ! conversion of temperature
+ ! -----------------------------------------------------------------------
+
+ if (do_inline_mp) then
+ do k = ks, ke
+ q_cond = 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. - q_cond))
+ enddo
+ else
+ do k = ks, ke
tz (k) = pt (i, k)
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! calculate base total energy
+ ! -----------------------------------------------------------------------
+
+ 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
+ te (i, k) = - mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), &
+ qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav
+ enddo
endif
- enddo
-
+ endif
+
! -----------------------------------------------------------------------
! 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
+ call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), &
+ qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), &
+ delp (i, :), gsize (i), dte (i), 0.0, water (i), rain (i), &
+ ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, :), &
+ tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic)
endif
-
+
do k = ks, ke
- dp0 (k) = delp (i, k)
+
! -----------------------------------------------------------------------
- ! convert moist mixing ratios to dry mixing ratios
+ ! convert specific ratios to mass 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)
- ! 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.
- 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
+ qaz (k) = qa (i, k)
+
+ if (do_inline_mp) then
+ q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k)
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ else
+ con_r8 = one_r8 - qvz (k)
+ endif
+
+ dp0 (k) = delp (i, k)
+ dp (k) = delp (i, k) * con_r8
con_r8 = one_r8 / con_r8
qvz (k) = qvz (k) * con_r8
qlz (k) = qlz (k) * con_r8
@@ -611,302 +1305,245 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
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 transport:
+ ! dry air density and layer-mean pressure thickness
! -----------------------------------------------------------------------
-
- m1 (k) = 0.
- u0 (k) = ua (i, k)
- v0 (k) = va (i, k)
+
+ dz (k) = delz (i, k)
+ den (k) = - dp (k) / (grav * dz (k))
+ pz (k) = den (k) * rdgas * tz (k)
+
+ ! -----------------------------------------------------------------------
+ ! for sedi_momentum transport
+ ! -----------------------------------------------------------------------
+
+ u (k) = ua (i, k)
+ v (k) = va (i, k)
if (.not. hydrostatic) then
- w1 (k) = w (i, k)
+ w (k) = wa (i, k)
endif
- u1 (k) = u0 (k)
- v1 (k) = v0 (k)
- denfac (k) = sqrt (sfcrho / den (k))
+
enddo
-
- ! -----------------------------------------------------------------------
- ! 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
-
+
+ do k = ks, ke
+ denfac (k) = sqrt (den (ke) / den (k))
+ enddo
+
! -----------------------------------------------------------------------
! 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
+ call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, &
+ dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), &
+ snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), &
+ te_b_beg_d (i), tw_b_beg_d (i), .false., hydrostatic)
endif
-
+
! -----------------------------------------------------------------------
- ! calculate cloud condensation nuclei (ccn)
- ! the following is based on klein eq. 15
+ ! cloud condensation nuclei (CCN), cloud ice nuclei (CIN)
! -----------------------------------------------------------------------
-
- cpaut = c_paut * 0.104 * grav / 1.717e-5
-
+
if (prog_ccn) then
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
+ ! boucher and lohmann (1995)
+ nl = min (1., abs (hs (i)) / (10. * grav)) * &
+ (10. ** 2.24 * (qnl (i, k) * den (k) * 1.e9) ** 0.257) + &
+ (1. - min (1., abs (hs (i)) / (10. * grav))) * &
+ (10. ** 2.06 * (qnl (i, k) * den (k) * 1.e9) ** 0.48)
+ ni = qni (i, k)
+ ccn (k) = max (10.0, nl) * 1.e6
+ cin (k) = max (10.0, ni) * 1.e6
ccn (k) = ccn (k) / den (k)
- c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.)
+ cin (k) = cin (k) / den (k)
enddo
else
- ! 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
+ cin0 = 0.0
do k = ks, ke
ccn (k) = ccn0 / den (k)
- c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.)
+ cin (k) = cin0 / den (k)
enddo
endif
-
+
! -----------------------------------------------------------------------
- ! calculate horizontal subgrid variability
- ! total water subgrid deviation in horizontal direction
+ ! subgrid deviation in horizontal direction
! default area dependent form: use dx ~ 100 km as the base
! -----------------------------------------------------------------------
-
- s_leng = sqrt (gsize (i) / 1.e5)
- t_land = dw_land * s_leng
- t_ocean = dw_ocean * s_leng
+
+ t_lnd = dw_land * sqrt (gsize (i) / 1.e5)
+ t_ocn = dw_ocean * sqrt (gsize (i) / 1.e5)
tmp = min (1., abs (hs (i)) / (10. * grav))
- h_var = t_land * tmp + t_ocean * (1. - tmp)
+ h_var = t_lnd * tmp + t_ocn * (1. - tmp)
h_var = min (0.20, max (0.01, h_var))
-
+
! -----------------------------------------------------------------------
! relative humidity thresholds
! -----------------------------------------------------------------------
-
+
rh_adj = 1. - h_var - rh_inc
- rh_rain = max (0.35, rh_adj - rh_inr) ! rh_inr = 0.25
-
+ rh_rain = max (0.35, rh_adj - rh_inr)
+
! -----------------------------------------------------------------------
- ! fix all negative water species
+ ! fix negative water species from outside
! -----------------------------------------------------------------------
-
+
if (fix_negative) &
- call neg_adj (ks, ke, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz, cond)
-
+ call neg_adj (ks, ke, tz, dp, 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
-
- ! -----------------------------------------------------------------------
- ! time - split warm rain processes: 1st 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, reevap, dte (i))
-
- evaporation (i) = evaporation (i) + reevap * convt
- rain (i) = rain (i) + r1 * convt
-
- do k = ks, ke
- m2_rain (i, k) = m2_rain (i, k) + m1_rain (k)
- m1 (k) = m1 (k) + m1_rain (k)
- enddo
-
- ! -----------------------------------------------------------------------
- ! sedimentation of cloud ice, snow, and graupel
- ! -----------------------------------------------------------------------
-
- 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))
-
- 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
+
+ ! -----------------------------------------------------------------------
+ ! fast microphysics loop
+ ! -----------------------------------------------------------------------
+
+ if (do_mp_fast) then
+
+ call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, &
+ ccn, cin, condensation (i), deposition (i), evaporation (i), &
+ sublimation (i), convt)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! full microphysics loop
+ ! -----------------------------------------------------------------------
+
+ if (do_mp_full) then
+
+ call mp_full (ks, ke, ntimes, tz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, &
+ u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte (i), &
+ water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), &
+ prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), &
+ condensation (i), deposition (i), evaporation (i), sublimation (i), convt)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! cloud fraction diagnostic
+ ! -----------------------------------------------------------------------
+
+ if (do_qa .and. last_step) then
+ call cloud_fraction (ks, ke, pz, den, qvz, qlz, qrz, qiz, qsz, qgz, qaz, &
+ tz, h_var, gsize (i))
+ endif
+
+ ! =======================================================================
+ ! calculation of particle concentration (pc), effective diameter (ed),
+ ! optical extinction (oe), radar reflectivity factor (rr), and
+ ! mass-weighted terminal velocity (tv)
+ ! =======================================================================
+
+ pcw (i, :) = 0.0
+ edw (i, :) = 0.0
+ oew (i, :) = 0.0
+ rrw (i, :) = 0.0
+ tvw (i, :) = 0.0
+ pci (i, :) = 0.0
+ edi (i, :) = 0.0
+ oei (i, :) = 0.0
+ rri (i, :) = 0.0
+ tvi (i, :) = 0.0
+ pcr (i, :) = 0.0
+ edr (i, :) = 0.0
+ oer (i, :) = 0.0
+ rrr (i, :) = 0.0
+ tvr (i, :) = 0.0
+ pcs (i, :) = 0.0
+ eds (i, :) = 0.0
+ oes (i, :) = 0.0
+ rrs (i, :) = 0.0
+ tvs (i, :) = 0.0
+ pcg (i, :) = 0.0
+ edg (i, :) = 0.0
+ oeg (i, :) = 0.0
+ rrg (i, :) = 0.0
+ tvg (i, :) = 0.0
+
+ do k = ks, ke
+ if (qlz (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (i, k), &
+ edaw, edbw, edw (i, k), oeaw, oebw, oew (i, k), rraw, rrbw, rrw (i, k), &
+ tvaw, tvbw, tvw (i, k))
endif
-
- ! -----------------------------------------------------------------------
- ! heat transportation during sedimentation
- ! -----------------------------------------------------------------------
-
- if (do_sedi_heat) then
- call sedi_heat (ks, ke, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, &
- qsz, qgz, c_ice)
+ if (qiz (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (i, k), &
+ edai, edbi, edi (i, k), oeai, oebi, oei (i, k), rrai, rrbi, rri (i, k), &
+ tvai, tvbi, tvi (i, k))
endif
-
- ! -----------------------------------------------------------------------
- ! 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)
+ if (qrz (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (i, k), &
+ edar, edbr, edr (i, k), oear, oebr, oer (i, k), rrar, rrbr, rrr (i, k), &
+ tvar, tvbr, tvr (i, k))
+ endif
+ if (qsz (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (i, k), &
+ edas, edbs, eds (i, k), oeas, oebs, oes (i, k), rras, rrbs, rrs (i, k), &
+ tvas, tvbs, tvs (i, k))
+ endif
+ if (do_hail) then
+ if (qgz (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (i, k), &
+ edah, edbh, edg (i, k), oeah, oebh, oeg (i, k), rrah, rrbh, rrg (i, k), &
+ tvah, tvbh, tvg (i, k))
+ endif
+ else
+ if (qgz (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (i, k), &
+ edag, edbg, edg (i, k), oeag, oebg, oeg (i, k), rrag, rrbg, rrg (i, k), &
+ tvag, tvbg, tvg (i, k))
+ endif
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, reevap, dte (i))
-
- evaporation (i) = evaporation (i) + reevap * convt
- rain (i) = rain (i) + r1 * convt
-
- 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)
- enddo
-
- ! -----------------------------------------------------------------------
- ! ice - phase microphysics
- ! -----------------------------------------------------------------------
-
- 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
! -----------------------------------------------------------------------
! momentum transportation during sedimentation
- ! note: dp1 is dry mass; dp0 is the old moist (total) mass
+ ! update temperature before delp and q update
! -----------------------------------------------------------------------
-
- if (sedi_transport) then
- 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))
- ua (i, k) = u1 (k)
- va (i, k) = v1 (k)
+
+ if (do_sedi_uv) then
+ do k = ks, ke
+ c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air
+ tzuv (k) = 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 - (u (k) ** 2 + v (k) ** 2)) / c8
+ tz (k) = tz (k) + tzuv (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
- ! 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)
+ c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air
+ tzw (k) = 0.5 * (wa (i, k) ** 2 - w (k) ** 2) / c8
+ tz (k) = tz (k) + tzw (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
+ call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, &
+ dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), &
+ snow (i), graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), &
+ te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i))
endif
-
- ! -----------------------------------------------------------------------
- ! update moist air mass (actually hydrostatic pressure)
- ! convert to dry mixing ratios
- ! -----------------------------------------------------------------------
-
+
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
+
+ ! -----------------------------------------------------------------------
+ ! convert mass mixing ratios back to specific ratios
+ ! -----------------------------------------------------------------------
+
+ if (do_inline_mp) then
+ q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k)
+ con_r8 = one_r8 + qvz (k) + q_cond
+ else
+ con_r8 = one_r8 + qvz (k)
+ endif
+
+ delp (i, k) = dp (k) * con_r8
con_r8 = one_r8 / con_r8
qvz (k) = qvz (k) * con_r8
qlz (k) = qlz (k) * con_r8
@@ -914,56 +1551,95 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
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:
+
+ q1 = qv (i, k) + ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k)
+ q2 = qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k)
+ adj_vmr (i, k) = ((one_r8 - q1) / (one_r8 - q2)) / (one_r8 + q2 - q1)
+
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)
+ qa (i, k) = qaz (k)
+
+ ! -----------------------------------------------------------------------
+ ! calculate some more variables needed outside
+ ! -----------------------------------------------------------------------
+
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
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air
+
+#ifdef USE_COND
q_con (i, k) = q_cond
- 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))
+ tmp = rdgas * (1. + zvir * qvz (k))
+ cappa (i, k) = tmp / (tmp + c8)
#endif
- else
- pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * cvm (k) / cp_air
- endif
+
enddo
-
+
! -----------------------------------------------------------------------
- ! total energy checker
+ ! momentum transportation during sedimentation
+ ! update temperature after delp and q update
! -----------------------------------------------------------------------
-
- if (consv_checker) then
+
+ if (do_sedi_uv) then
+ do k = ks, ke
+ tz (k) = tz (k) - tzuv (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)
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air
+ tzuv (k) = (0.5 * (ua (i, k) ** 2 + va (i, k) ** 2) * dp0 (k) - &
+ 0.5 * (u (k) ** 2 + v (k) ** 2) * delp (i, k)) / c8 / delp (i, k)
+ tz (k) = tz (k) + tzuv (k)
+ enddo
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
+ ua (i, k) = u (k)
+ va (i, k) = v (k)
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
-
+
+ if (do_sedi_w) then
+ do k = ks, ke
+ tz (k) = tz (k) - tzw (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)
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air
+ tzw (k) = (0.5 * (wa (i, k) ** 2) * dp0 (k) - &
+ 0.5 * (w (k) ** 2) * delp (i, k)) / c8 / delp (i, k)
+ tz (k) = tz (k) + tzw (k)
+ enddo
+ do k = ks, ke
+ wa (i, k) = w (k)
+ enddo
+ endif
+
! -----------------------------------------------------------------------
- ! fix energy conservation
+ ! total energy checker
! -----------------------------------------------------------------------
-
+
+ if (consv_checker) then
+ call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), &
+ qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), &
+ delp (i, :), gsize (i), dte (i), 0.0, water (i), rain (i), &
+ ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), &
+ tw_end_m (i, :), te_b_end_m (i), tw_b_end_m (i), .true., hydrostatic)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! calculate total energy loss or gain
+ ! -----------------------------------------------------------------------
+
if (consv_te) then
if (hydrostatic) then
do k = ks, ke
@@ -971,1467 +1647,3042 @@ subroutine mpdrv (hydrostatic, ua, va, w, delp, pt, qv, ql, qr, qi, qs, &
enddo
else
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
+ te (i, k) = te (i, k) + mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), &
+ qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav
enddo
endif
endif
-
+
! -----------------------------------------------------------------------
- ! update cloud fraction tendency
+ ! conversion of temperature
! -----------------------------------------------------------------------
-
- 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_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))
+
+ if (do_inline_mp) then
+ do k = ks, ke
+ q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k)
+ if (cp_heating) then
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air
+ cp8 = con_r8 * cp_air + qvz (k) * cp_vap + q_liq (k) * c_liq + q_sol (k) * c_ice
+ delz (i, k) = delz (i, k) / pt (i, k)
+ pt (i, k) = pt (i, k) + (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8
+ delz (i, k) = delz (i, k) * pt (i, k)
+ else
+ pt (i, k) = tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond))
+ endif
+ enddo
+ else
+ do k = ks, ke
+ q_liq (k) = qlz (k) + qrz (k)
+ q_sol (k) = qiz (k) + qsz (k) + qgz (k)
+ q_cond = q_liq (k) + q_sol (k)
+ con_r8 = one_r8 - (qvz (k) + q_cond)
+ c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air
+ pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * c8 / cp_air
+ enddo
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))
+
+ ! -----------------------------------------------------------------------
+ ! total energy checker
+ ! -----------------------------------------------------------------------
+
+ if (consv_checker) then
+ if (abs (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / &
+ (sum (te_beg_d (i, :)) + te_b_beg_d (i)) .gt. te_err) then
+ print*, "GFDL-MP-DRY TE: ", &
+ !(sum (te_beg_d (i, :)) + te_b_beg_d (i)) / (gsize (i) ** 2), &
+ !(sum (te_end_d (i, :)) + te_b_end_d (i)) / (gsize (i) ** 2), &
+ (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / &
+ (sum (te_beg_d (i, :)) + te_b_beg_d (i))
+ endif
+ if (abs (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / &
+ (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) .gt. tw_err) then
+ print*, "GFDL-MP-DRY TW: ", &
+ !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) / (gsize (i) ** 2), &
+ !(sum (tw_end_d (i, :)) + tw_b_end_d (i)) / (gsize (i) ** 2), &
+ (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / &
+ (sum (tw_beg_d (i, :)) + tw_b_beg_d (i))
+ endif
+ !print*, "GFDL MP TE DRY LOSS (%) : ", te_loss (i) / (sum (te_beg_d (i, :)) + te_b_beg_d (i)) * 100.0
+ if (abs (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / &
+ (sum (te_beg_m (i, :)) + te_b_beg_m (i)) .gt. te_err) then
+ print*, "GFDL-MP-WET TE: ", &
+ !(sum (te_beg_m (i, :)) + te_b_beg_m (i)) / (gsize (i) ** 2), &
+ !(sum (te_end_m (i, :)) + te_b_end_m (i)) / (gsize (i) ** 2), &
+ (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / &
+ (sum (te_beg_m (i, :)) + te_b_beg_m (i))
+ endif
+ if (abs (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / &
+ (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) .gt. tw_err) then
+ print*, "GFDL-MP-WET TW: ", &
+ !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) / (gsize (i) ** 2), &
+ !(sum (tw_end_m (i, :)) + tw_b_end_m (i)) / (gsize (i) ** 2), &
+ (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / &
+ (sum (tw_beg_m (i, :)) + tw_b_beg_m (i))
+ endif
+ !print*, "GFDL MP TE WET LOSS (%) : ", te_loss_0 (i) / (sum (te_beg_m (i, :)) + te_b_beg_m (i)) * 100.0
endif
- ! print *, "gfdl_mp te loss (%) : ", sum (te_loss) / (sum (te_beg) + sum (te_b_beg)) * 100.0
- endif
-
+
+ enddo ! i loop
+
end subroutine mpdrv
-! -----------------------------------------------------------------------
-! sedimentation of heat
-! -----------------------------------------------------------------------
+! =======================================================================
+! fix negative water species
+! =======================================================================
-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
+subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond)
+
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
- ! local:
- real, dimension (ks:ke) :: dgz, cv0
- integer :: k
-
- ! 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
+
! -----------------------------------------------------------------------
- ! implicit algorithm: can't be vectorized
- ! needs an inner i - loop for vectorization
+ ! input / output arguments
! -----------------------------------------------------------------------
- ! 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
-
-! -----------------------------------------------------------------------
-! warm rain cloud microphysics
-! -----------------------------------------------------------------------
-
-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) :: 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 (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 (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
+
+ real, intent (in), dimension (ks:ke) :: dp
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real, intent (out) :: cond
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: k
-
- logical :: no_fall
-
- dt5 = 0.5 * dt
-
+
+ real :: dq, sink
+
+ real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: cvm, te8
+
! -----------------------------------------------------------------------
- ! terminal speed of rain
+ ! initialization
! -----------------------------------------------------------------------
-
- m1_rain (:) = 0.
-
- call check_column (ks, ke, qr, no_fall)
-
- reevap = 0
-
- if (no_fall) then
- vtr (:) = vf_min
- r1 = 0.
- else
-
+
+ cond = 0
+
+ ! -----------------------------------------------------------------------
+ ! calculate moist heat capacity and latent heat coefficients
+ ! -----------------------------------------------------------------------
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
+ do k = ks, ke
+
! -----------------------------------------------------------------------
- ! fall speed of rain
+ ! fix negative solid-phase hydrometeors
! -----------------------------------------------------------------------
-
- if (const_vr) then
- vtr (:) = vr_fac ! ifs_2016: 4.0
- else
- do k = ks, ke
- qden = qr (k) * den (k)
- if (qr (k) < thr) then
- vtr (k) = vr_min
- else
- vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * &
- exp (0.2 * log (qden / normr))
- vtr (k) = min (vr_max, max (vr_min, vtr (k)))
- endif
- enddo
+
+ ! if cloud ice < 0, borrow from snow
+ if (qi (k) .lt. 0.) then
+ sink = min (- qi (k), max (0., qs (k)))
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., sink, - sink, 0.)
endif
-
- ze (ke + 1) = zs
- do k = ke, ks, - 1
- ze (k) = ze (k + 1) - dz (k) ! dz < 0
- enddo
-
+
+ ! if snow < 0, borrow from graupel
+ if (qs (k) .lt. 0.) then
+ sink = min (- qs (k), max (0., qg (k)))
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., 0., sink, - sink)
+ endif
+
+ ! if graupel < 0, borrow from rain
+ if (qg (k) .lt. 0.) then
+ sink = min (- qg (k), max (0., qr (k)))
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+ endif
+
! -----------------------------------------------------------------------
- ! evaporation and accretion of rain for the first 1 / 2 time step
+ ! fix negative liquid-phase hydrometeors
! -----------------------------------------------------------------------
-
- 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
- dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k))
- enddo
+
+ ! if rain < 0, borrow from cloud water
+ if (qr (k) .lt. 0.) then
+ sink = min (- qr (k), max (0., ql (k)))
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, sink, 0., 0., 0.)
+ endif
+
+ ! if cloud water < 0, borrow from water vapor
+ if (ql (k) .lt. 0.) then
+ sink = min (- ql (k), max (0., qv (k)))
+ cond = cond + sink * dp (k)
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ - sink, sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+ endif
+
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! fix negative water vapor
+ ! -----------------------------------------------------------------------
+
+ ! if water vapor < 0, borrow water vapor from below
+ do k = ks, ke - 1
+ if (qv (k) .lt. 0.) then
+ qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1)
+ qv (k) = 0.
endif
+ enddo
+
+ ! if water vapor < 0, borrow water vapor from above
+ if (qv (ke) .lt. 0. .and. qv (ke - 1) .gt. 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
+
+! =======================================================================
+! full microphysics loop
+! =======================================================================
+subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, &
+ den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, &
+ snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, &
+ condensation, deposition, evaporation, sublimation, convt)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke, ntimes
+
+ real, intent (in) :: dts, rh_adj, rh_rain, h_var, convt
+
+ real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w, ccn, cin
+ real, intent (inout), dimension (ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (inout) :: water, rain, ice, snow, graupel
+ real, intent (inout) :: condensation, deposition
+ real, intent (inout) :: evaporation, sublimation
+
+ real (kind = r8), intent (inout) :: dte
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: n
+
+ real :: w1, r1, i1, s1, g1, cond, dep, reevap, sub
+
+ real, dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg
+
+ do n = 1, ntimes
+
! -----------------------------------------------------------------------
- ! energy loss during sedimentation
+ ! sedimentation of cloud ice, snow, graupel or hail, and rain
! -----------------------------------------------------------------------
-
- 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
-
+
+ call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, &
+ dz, dp, vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, &
+ u, v, w, den, denfac, dte)
+
+ water = water + w1 * convt
+ rain = rain + r1 * convt
+ ice = ice + i1 * convt
+ snow = snow + s1 * convt
+ graupel = graupel + g1 * convt
+
+ prefluxw = prefluxw + pfw * convt
+ prefluxr = prefluxr + pfr * convt
+ prefluxi = prefluxi + pfi * convt
+ prefluxs = prefluxs + pfs * convt
+ prefluxg = prefluxg + pfg * convt
+
! -----------------------------------------------------------------------
- ! mass flux induced by falling rain
+ ! warm rain cloud microphysics
! -----------------------------------------------------------------------
-
- 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 (ke + 1) = zs - dt * vtr (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
- call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof)
- else
- call implicit_fall (dt, ks, ke, ze, vtr, dp, qr, r1, m1_rain)
- endif
-
+
+ call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
+ den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap)
+
+ evaporation = evaporation + reevap * convt
+
! -----------------------------------------------------------------------
- ! energy loss during sedimentation
+ ! ice cloud microphysics
! -----------------------------------------------------------------------
-
- 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
-
+
+ call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, &
+ denfac, vtw, vtr, vti, vts, vtg, dts, h_var)
+
! -----------------------------------------------------------------------
- ! vertical velocity transportation during sedimentation
+ ! temperature sentive high vertical resolution processes
! -----------------------------------------------------------------------
+
+ call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, &
+ qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub)
+
+ condensation = condensation + cond * convt
+ deposition = deposition + dep * convt
+ evaporation = evaporation + reevap * convt
+ sublimation = sublimation + sub * convt
+
+ enddo
+
+end subroutine mp_full
- if (do_sedi_w) then
- ! 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
+! =======================================================================
+! fast microphysics loop
+! =======================================================================
+subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, &
+ ccn, cin, condensation, deposition, evaporation, sublimation, convt)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dtm, convt
+
+ real, intent (in), dimension (ks:ke) :: dp, den
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (inout) :: condensation, deposition
+ real, intent (inout) :: evaporation, sublimation
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: cond, dep, reevap, sub
+
+ real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: cvm, te8
+
+ ! -----------------------------------------------------------------------
+ ! initialization
+ ! -----------------------------------------------------------------------
+
+ cond = 0
+ dep = 0
+ reevap = 0
+ sub = 0
+
+ ! -----------------------------------------------------------------------
+ ! calculate heat capacities and latent heat coefficients
+ ! -----------------------------------------------------------------------
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
+ if (.not. do_warm_rain_mp) then
+
! -----------------------------------------------------------------------
- ! energy loss during sedimentation heating
+ ! cloud ice melting to form cloud water and rain
! -----------------------------------------------------------------------
-
- 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
-
+
+ call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
+ lcpk, icpk, tcpk, tcp3)
+
! -----------------------------------------------------------------------
- ! heat exchanges during sedimentation
+ ! enforce complete freezing below t_wfr
! -----------------------------------------------------------------------
-
- if (do_sedi_heat) then
- call sedi_heat (ks, ke, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq)
- endif
-
+
+ call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
+ lcpk, icpk, tcpk, tcp3)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! cloud water condensation and evaporation
+ ! -----------------------------------------------------------------------
+
+ call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, cond, reevap)
+
+ condensation = condensation + cond * convt
+ evaporation = evaporation + reevap * convt
+
+ if (.not. do_warm_rain_mp) then
+
! -----------------------------------------------------------------------
- ! energy loss during sedimentation heating
+ ! cloud water freezing to form cloud ice and snow
! -----------------------------------------------------------------------
-
- 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
-
-
+
+ call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! Wegener Bergeron Findeisen process
+ ! -----------------------------------------------------------------------
+
+ call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! Bigg freezing mechanism
+ ! -----------------------------------------------------------------------
+
+ call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, &
+ lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! rain freezing to form graupel
+ ! -----------------------------------------------------------------------
+
+ call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
+ lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! snow melting to form cloud water and rain
! -----------------------------------------------------------------------
- ! evaporation and accretion of rain for the remaing 1 / 2 time step
+
+ call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
+ lcpk, icpk, tcpk, tcp3)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! cloud water to rain autoconversion
+ ! -----------------------------------------------------------------------
+
+ call praut_simp (ks, ke, dtm, tz, qv, ql, qr, qi, qs, qg)
+
+ if (.not. do_warm_rain_mp) then
+
! -----------------------------------------------------------------------
+ ! cloud ice deposition and sublimation
+ ! -----------------------------------------------------------------------
+
+ call pidep_pisub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, cin, dep, sub)
+
+ deposition = deposition + dep * convt
+ sublimation = sublimation + sub * convt
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice to snow autoconversion
+ ! -----------------------------------------------------------------------
+
+ call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den)
+
+ endif
+
+end subroutine mp_fast
- call revap_racc (ks, ke, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
+! =======================================================================
+! sedimentation of cloud ice, snow, graupel or hail, and rain
+! =======================================================================
+
+subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, &
+ u, v, w, den, denfac, dte)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w
+
+ real, intent (out) :: w1, r1, i1, s1, g1
+
+ real, intent (out), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg
+
+ real (kind = r8), intent (inout) :: dte
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: te8, cvm
+
+ w1 = 0.
+ r1 = 0.
+ i1 = 0.
+ s1 = 0.
+ g1 = 0.
+
+ vtw = 0.
+ vtr = 0.
+ vti = 0.
+ vts = 0.
+ vtg = 0.
+
+ pfw = 0.
+ pfr = 0.
+ pfi = 0.
+ pfs = 0.
+ pfg = 0.
+ ! -----------------------------------------------------------------------
+ ! calculate heat capacities and latent heat coefficients
+ ! -----------------------------------------------------------------------
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! terminal fall and melting of falling cloud ice into rain
+ ! -----------------------------------------------------------------------
+
+ if (do_psd_ice_fall) then
+ call term_rsg (ks, ke, qi, den, denfac, vi_fac, blini, mui, tvai, tvbi, vi_max, const_vi, vti)
+ else
+ call term_ice (ks, ke, tz, qi, den, vi_fac, vi_max, const_vi, vti)
endif
+
+ if (do_sedi_melt) then
+ call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vti, r1, tau_imlt, icpk, "qi")
+ endif
+
+ call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vti, i1, pfi, u, v, w, dte, "qi")
+
+ pfi (ks) = max (0.0, pfi (ks))
+ do k = ke, ks + 1, -1
+ pfi (k) = max (0.0, pfi (k) - pfi (k - 1))
+ enddo
! -----------------------------------------------------------------------
- ! auto - conversion
- ! assuming linear subgrid vertical distribution of cloud water
- ! following lin et al. 1994, mwr
+ ! terminal fall and melting of falling snow into rain
! -----------------------------------------------------------------------
+
+ call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_max, const_vs, vts)
+
+ if (do_sedi_melt) then
+ call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vts, r1, tau_smlt, icpk, "qs")
+ endif
+
+ call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vts, s1, pfs, u, v, w, dte, "qs")
+
+ pfs (ks) = max (0.0, pfs (ks))
+ do k = ke, ks + 1, -1
+ pfs (k) = max (0.0, pfs (k) - pfs (k - 1))
+ enddo
- if (irain_f /= 0) then
+ ! -----------------------------------------------------------------------
+ ! terminal fall and melting of falling graupel into rain
+ ! -----------------------------------------------------------------------
+
+ if (do_hail) then
+ call term_rsg (ks, ke, qg, den, denfac, vg_fac, blinh, muh, tvah, tvbh, vg_max, const_vg, vtg)
+ else
+ call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_max, const_vg, vtg)
+ endif
+
+ if (do_sedi_melt) then
+ call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vtg, r1, tau_gmlt, icpk, "qg")
+ endif
+
+ call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vtg, g1, pfg, u, v, w, dte, "qg")
+
+ pfg (ks) = max (0.0, pfg (ks))
+ do k = ke, ks + 1, -1
+ pfg (k) = max (0.0, pfg (k) - pfg (k - 1))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! terminal fall of cloud water
+ ! -----------------------------------------------------------------------
+
+ if (do_psd_water_fall) then
- ! -----------------------------------------------------------------------
- ! no subgrid varaibility
- ! -----------------------------------------------------------------------
+ call term_rsg (ks, ke, ql, den, denfac, vw_fac, blinw, muw, tvaw, tvbw, vw_max, const_vw, vtw)
+
+ call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vtw, w1, pfw, u, v, w, dte, "ql")
- do k = ks, ke
- qc = fac_rc * ccn (k)
- if (tz (k) > t_wfr) then
- dq = ql (k) - qc
- if (dq > 0.) then
- sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))))
- ql (k) = ql (k) - sink
- qr (k) = qr (k) + sink
- endif
- endif
+ pfw (ks) = max (0.0, pfw (ks))
+ do k = ke, ks + 1, -1
+ pfw (k) = max (0.0, pfw (k) - pfw (k - 1))
enddo
- else
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! terminal fall of rain
+ ! -----------------------------------------------------------------------
+
+ call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_max, const_vr, vtr)
+
+ call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vtr, r1, pfr, u, v, w, dte, "qr")
+
+ pfr (ks) = max (0.0, pfr (ks))
+ do k = ke, ks + 1, -1
+ pfr (k) = max (0.0, pfr (k) - pfr (k - 1))
+ enddo
- ! -----------------------------------------------------------------------
- ! with subgrid varaibility
- ! -----------------------------------------------------------------------
+end subroutine sedimentation
- call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var)
+! =======================================================================
+! terminal velocity for cloud ice
+! =======================================================================
+subroutine term_ice (ks, ke, tz, q, den, v_fac, v_max, const_v, vt)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ logical, intent (in) :: const_v
+
+ real, intent (in) :: v_fac, v_max
+
+ real, intent (in), dimension (ks:ke) :: q, den
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: tz
+
+ real, intent (out), dimension (ks:ke) :: vt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: qden
+
+ real, parameter :: aa = - 4.14122e-5
+ real, parameter :: bb = - 0.00538922
+ real, parameter :: cc = - 0.0516344
+ real, parameter :: dd = 0.00216078
+ real, parameter :: ee = 1.9714
+
+ real, dimension (ks:ke) :: tc
+
+ if (const_v) then
+ vt (:) = v_fac
+ else
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)
- ! --------------------------------------------------------------------
- dq = 0.5 * (ql (k) + dl (k) - qc)
- ! --------------------------------------------------------------------
- ! dq = dl if qc == q_minus = ql - dl
- ! dq = 0 if qc == q_plus = ql + dl
- ! --------------------------------------------------------------------
- if (dq > 0.) then ! q_plus > qc
- ! --------------------------------------------------------------------
- ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl
- ! --------------------------------------------------------------------
- sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))
- ql (k) = ql (k) - sink
- qr (k) = qr (k) + sink
+ qden = q (k) * den (k)
+ if (q (k) .lt. qfmin) then
+ vt (k) = 0.0
+ else
+ tc (k) = tz (k) - tice
+ if (ifflag .eq. 1) then
+ vt (k) = (3. + log10 (qden)) * (tc (k) * (aa * tc (k) + bb) + cc) + &
+ dd * tc (k) + ee
+ vt (k) = 0.01 * v_fac * exp (vt (k) * log (10.))
endif
+ if (ifflag .eq. 2) &
+ vt (k) = v_fac * 3.29 * exp (0.16 * log (qden))
+ vt (k) = min (v_max, max (0.0, vt (k)))
endif
enddo
endif
+
+end subroutine term_ice
-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, dp, reevap)
+! =======================================================================
+! terminal velocity for rain, snow, and graupel, Lin et al. (1983)
+! =======================================================================
+subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_max, const_v, vt)
+
implicit none
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
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, 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
-
+
+ logical, intent (in) :: const_v
+
+ real, intent (in) :: v_fac, blin, v_max, mu
+
+ real (kind = r8), intent (in) :: tva, tvb
+
+ real, intent (in), dimension (ks:ke) :: q, den, denfac
+
+ real, intent (out), dimension (ks:ke) :: vt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: k
-
- if (tau_revp .gt. 1.e-6) then
- fac_revp = 1. - exp (- dt / tau_revp)
+
+ if (const_v) then
+ vt (:) = v_fac
else
- fac_revp = 1.
+ do k = ks, ke
+ if (q (k) .lt. qfmin) then
+ vt (k) = 0.0
+ else
+ call cal_pc_ed_oe_rr_tv (q (k), den (k), blin, mu, &
+ tva = tva, tvb = tvb, tv = vt (k))
+ vt (k) = v_fac * vt (k) * denfac (k)
+ vt (k) = min (v_max, max (0.0, vt (k)))
+ endif
+ enddo
endif
+
+end subroutine term_rsg
- do k = ks, ke
+! =======================================================================
+! melting during sedimentation
+! =======================================================================
- if (tz (k) > t_wfr .and. qr (k) > qrmin) then
+subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vt, r1, tau_mlt, icpk, qflag)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts, tau_mlt
+
+ real, intent (in), dimension (ks:ke) :: vt, dp, dz, icpk
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real, intent (inout) :: r1
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ character (len = 2), intent (in) :: qflag
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k, m
+
+ real :: dtime, sink, zs
+
+ real, dimension (ks:ke) :: q
+
+ real, dimension (ks:ke + 1) :: ze, zt
+
+ real (kind = r8), dimension (ks:ke) :: cvm
+
+ call zezt (ks, ke, dts, zs, dz, vt, ze, zt)
+
+ select case (qflag)
+ case ("qi")
+ q = qi
+ case ("qs")
+ q = qs
+ case ("qg")
+ q = qg
+ case default
+ print *, "gfdl_mp: qflag error!"
+ end select
+
+ ! -----------------------------------------------------------------------
+ ! melting to rain
+ ! -----------------------------------------------------------------------
+
+ do k = ke - 1, ks, - 1
+ if (vt (k) .lt. 1.e-10) cycle
+ if (q (k) .gt. qcmin) then
+ do m = k + 1, ke
+ if (zt (k + 1) .ge. ze (m)) exit
+ if (zt (k) .lt. ze (m + 1) .and. tz (m) .gt. tice) then
+ cvm (k) = mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k))
+ cvm (m) = mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m))
+ dtime = min (dts, (ze (m) - ze (m + 1)) / vt (k))
+ dtime = min (1.0, dtime / tau_mlt)
+ sink = min (q (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
+ q (k) = q (k) - sink * dp (m) / dp (k)
+ if (zt (k) .lt. zs) then
+ r1 = r1 + sink * dp (m)
+ else
+ qr (m) = qr (m) + sink
+ endif
+ select case (qflag)
+ case ("qi")
+ qi (k) = q (k)
+ case ("qs")
+ qs (k) = q (k)
+ case ("qg")
+ qg (k) = q (k)
+ case default
+ print *, "gfdl_mp: qflag error!"
+ end select
+ tz (k) = (tz (k) * cvm (k) - li00 * sink * dp (m) / dp (k)) / &
+ mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k))
+ tz (m) = (tz (m) * cvm (m)) / &
+ mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m))
+ endif
+ if (q (k) .lt. qcmin) exit
+ enddo
+ endif
+ enddo
+
+end subroutine sedi_melt
- ! -----------------------------------------------------------------------
- ! define heat capacity and latent heat coefficient
- ! -----------------------------------------------------------------------
+! =======================================================================
+! melting during sedimentation
+! =======================================================================
- q_liq (k) = ql (k) + qr (k)
- q_sol (k) = qi (k) + qs (k) + qg (k)
+subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
+ vt, x1, m1, u, v, w, dte, qflag)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: vt, dp, dz
+
+ character (len = 2), intent (in) :: qflag
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w
+
+ real, intent (inout) :: x1
+
+ real (kind = r8), intent (inout) :: dte
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (out), dimension (ks:ke) :: m1
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ logical :: no_fall
+
+ real :: zs
+
+ real, dimension (ks:ke) :: dm, q
+
+ real, dimension (ks:ke + 1) :: ze, zt
+
+ real (kind = r8), dimension (ks:ke) :: te1, te2
+
+ m1 = 0.0
+
+ call zezt (ks, ke, dts, zs, dz, vt, ze, zt)
+
+ select case (qflag)
+ case ("ql")
+ q = ql
+ case ("qr")
+ q = qr
+ case ("qi")
+ q = qi
+ case ("qs")
+ q = qs
+ case ("qg")
+ q = qg
+ case default
+ print *, "gfdl_mp: qflag error!"
+ end select
+
+ call check_column (ks, ke, q, no_fall)
+
+ if (no_fall) return
+
+ ! -----------------------------------------------------------------------
+ ! momentum transportation during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (do_sedi_w) then
+ do k = ks, ke
+ dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k))
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy change during sedimentation
+ ! -----------------------------------------------------------------------
+
+ do k = ks, ke
+ te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.)
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! sedimentation
+ ! -----------------------------------------------------------------------
+
+ select case (qflag)
+ case ("ql")
+ q = ql
+ case ("qr")
+ q = qr
+ case ("qi")
+ q = qi
+ case ("qs")
+ q = qs
+ case ("qg")
+ q = qg
+ case default
+ print *, "gfdl_mp: qflag error!"
+ end select
+
+ if (sedflag .eq. 1) &
+ call implicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1)
+ if (sedflag .eq. 2) &
+ call explicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1)
+ if (sedflag .eq. 3) &
+ call lagrangian_fall (ks, ke, zs, ze, zt, dp, q, x1, m1)
+ if (sedflag .eq. 4) &
+ call implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, &
+ x1, m1, sed_fac)
+
+ select case (qflag)
+ case ("ql")
+ ql = q
+ case ("qr")
+ qr = q
+ case ("qi")
+ qi = q
+ case ("qs")
+ qs = q
+ case ("qg")
+ qg = q
+ case default
+ print *, "gfdl_mp: qflag error!"
+ end select
+
+ ! -----------------------------------------------------------------------
+ ! energy change during sedimentation
+ ! -----------------------------------------------------------------------
+
+ do k = ks, ke
+ te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+
+ ! -----------------------------------------------------------------------
+ ! momentum transportation during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (do_sedi_uv) then
+ call sedi_uv (ks, ke, m1, dp, u, v)
+ endif
+
+ if (do_sedi_w) then
+ call sedi_w (ks, ke, m1, w, vt, dm)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy change during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ do k = ks, ke
+ te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.)
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! heat exchanges during sedimentation
+ ! -----------------------------------------------------------------------
+
+ if (do_sedi_heat) then
+ call sedi_heat (ks, ke, dp, m1, dz, tz, qv, ql, qr, qi, qs, qg, c_ice)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! energy change during sedimentation heating
+ ! -----------------------------------------------------------------------
+
+ do k = ks, ke
+ te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.)
+ enddo
+ dte = dte + sum (te1) - sum (te2)
+
+end subroutine terminal_fall
- 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)
+! =======================================================================
+! calculate ze zt for sedimentation
+! =======================================================================
- 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
+subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: dz, vt
+
+ real, intent (out) :: zs
+
+ real, intent (out), dimension (ks:ke + 1) :: ze, zt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: dt5
+
+ dt5 = 0.5 * dts
+ zs = 0.0
+ ze (ke + 1) = zs
+ do k = ke, ks, - 1
+ ze (k) = ze (k + 1) - dz (k)
+ enddo
+ zt (ks) = ze (ks)
+ do k = ks + 1, ke
+ zt (k) = ze (k) - dt5 * (vt (k - 1) + vt (k))
+ enddo
+ zt (ke + 1) = zs - dts * vt (ke)
+ do k = ks, ke
+ if (zt (k + 1) .ge. zt (k)) zt (k + 1) = zt (k) - dz_min
+ enddo
+
+end subroutine zezt
- ! -----------------------------------------------------------------------
- ! qsat must be > q_minus to activate evaporation
- ! qsat must be < q_plus to activate accretion
- ! -----------------------------------------------------------------------
+! =======================================================================
+! check if water species is large enough to fall
+! =======================================================================
- ! -----------------------------------------------------------------------
- ! rain evaporation
- ! -----------------------------------------------------------------------
+subroutine check_column (ks, ke, q, no_fall)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: q (ks:ke)
+
+ logical, intent (out) :: no_fall
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ no_fall = .true.
+
+ do k = ks, ke
+ if (q (k) .gt. qfmin) then
+ no_fall = .false.
+ exit
+ endif
+ enddo
+
+end subroutine check_column
- rh_tem = qpz / iqs1 (tin, den (k))
+! =======================================================================
+! warm rain cloud microphysics
+! =======================================================================
- 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 * (qsat - q_minus) ** 2 / dqh
- endif
- qden = qr (k) * den (k)
- t2 = tin * tin
- 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)
+subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
+ den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts, rh_rain, h_var
+
+ real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac, vtw, vtr
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (out) :: reevap
+
+ ! -----------------------------------------------------------------------
+ ! initialization
+ ! -----------------------------------------------------------------------
+
+ reevap = 0
+
+ ! -----------------------------------------------------------------------
+ ! rain evaporation to form water vapor
+ ! -----------------------------------------------------------------------
+
+ call prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
+
+ ! -----------------------------------------------------------------------
+ ! rain accretion with cloud water
+ ! -----------------------------------------------------------------------
+
+ call pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr)
+
+ ! -----------------------------------------------------------------------
+ ! cloud water to rain autoconversion
+ ! -----------------------------------------------------------------------
+
+ call praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var)
+
+end subroutine warm_rain
- ! -----------------------------------------------------------------------
- ! alternative minimum evap in dry environmental air
- ! 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
- q_liq (k) = q_liq (k) - evap
- 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
+! =======================================================================
+! rain evaporation to form water vapor, Lin et al. (1983)
+! =======================================================================
+
+subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts, rh_rain, h_var
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, dp
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg
+
+ real, intent (out) :: reevap
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: dqv, qsat, dqdt, tmp, t2, qden, q_plus, q_minus, sink
+ real :: qpz, dq, dqh, tin, fac_revp, rh_tem
+
+ real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: cvm, te8
+
+ ! -----------------------------------------------------------------------
+ ! initialization
+ ! -----------------------------------------------------------------------
+
+ reevap = 0
+
+ ! -----------------------------------------------------------------------
+ ! time-scale factor
+ ! -----------------------------------------------------------------------
+
+ fac_revp = 1.
+ if (tau_revp .gt. 1.e-6) then
+ fac_revp = 1. - exp (- dts / tau_revp)
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! calculate heat capacities and latent heat coefficients
+ ! -----------------------------------------------------------------------
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
+ do k = ks, ke
+
+ tin = (tz (k) * cvm (k) - lv00 * ql (k)) / mhc (qv (k) + ql (k), qr (k), q_sol (k))
+
+ ! -----------------------------------------------------------------------
+ ! calculate supersaturation and subgrid variability of water
+ ! -----------------------------------------------------------------------
+
+ qpz = qv (k) + ql (k)
+ qsat = wqs (tin, den (k), dqdt)
+ dqv = qsat - qv (k)
+
+ dqh = max (ql (k), h_var * max (qpz, qcmin))
+ dqh = min (dqh, 0.2 * qpz)
+ q_minus = qpz - dqh
+ q_plus = qpz + dqh
+
+ ! -----------------------------------------------------------------------
+ ! rain evaporation
+ ! -----------------------------------------------------------------------
+
+ rh_tem = qpz / qsat
+
+ if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then
+ if (qsat .gt. q_plus) then
+ dq = qsat - qpz
+ else
+ dq = 0.25 * (qsat - q_minus) ** 2 / dqh
+ endif
+ qden = qr (k) * den (k)
+ t2 = tin * tin
+ sink = psub (t2, dq, qden, qsat, crevp, den (k), denfac (k), blinr, mur, lcpk (k), cvm (k))
+ sink = min (qr (k), dts * fac_revp * sink, dqv / (1. + lcpk (k) * dqdt))
+ if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then
+ sink = 0.0
+ endif
+
! -----------------------------------------------------------------------
- ! accretion: pracc
+ ! alternative minimum evaporation in dry environmental air
! -----------------------------------------------------------------------
+ ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt))
+ ! sink = max (sink, tmp)
+
+ reevap = reevap + sink * dp (k)
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ sink, 0., - sink, 0., 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo ! k loop
+
+end subroutine prevp
+
+! =======================================================================
+! rain accretion with cloud water, Lin et al. (1983)
+! =======================================================================
- ! if (qr (k) > qrmin .and. ql (k) > 1.e-7 .and. qsat < q_plus) 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)))
+subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: qden, sink
+
+ do k = ks, ke
+
+ if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. ql (k) .gt. qcmin) then
+
+ qden = qr (k) * den (k)
+ if (do_new_acc_water) then
+ sink = dts * acr3d (vtr (k), vtw (k), ql (k), qr (k), cracw, acco (:, 5), &
+ acc (9), acc (10), den (k))
+ else
+ sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur)
sink = sink / (1. + sink) * ql (k)
- ql (k) = ql (k) - sink
- qr (k) = qr (k) + sink
endif
-
- endif ! warm - rain
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, sink, 0., 0., 0.)
+
+ endif
+
enddo
+
+end subroutine pracw
-end subroutine revap_racc
-
-! -----------------------------------------------------------------------
-! definition of vertical subgrid variability
-! used for cloud ice and cloud water autoconversion
-! qi -- > ql & ql -- > qr
-! edges: qe == qbar + / - dm
-! -----------------------------------------------------------------------
-
-subroutine linear_prof (km, q, dm, z_var, h_var)
+! =======================================================================
+! cloud water to rain autoconversion, Hong et al. (2004)
+! =======================================================================
+subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var)
+
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)
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts, h_var
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: so3 = 7.0 / 3.0
+ real, parameter :: so1 = - 1.0 / 3.0
+
integer :: k
+
+ real :: sink, dq, qc
+
+ real, dimension (ks:ke) :: dl, c_praut
- if (z_var) then
- do k = 2, km
- dq (k) = 0.5 * (q (k) - q (k - 1))
- enddo
- dm (1) = 0.
-
- ! -----------------------------------------------------------------------
- ! use twice the strength of the positive definiteness limiter (lin et al 1994)
- ! -----------------------------------------------------------------------
+ if (irain_f .eq. 0) then
+
+ call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var)
+
+ do k = ks, ke
+
+ if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then
+
+ if (do_psd_water_num) then
+ call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, &
+ pca = pcaw, pcb = pcbw, pc = ccn (k))
+ ccn (k) = ccn (k) / den (k)
+ endif
- do k = 2, km - 1
- dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k))
- if (dq (k) * dq (k + 1) <= 0.) then
- if (dq (k) > 0.) then ! local max
- dm (k) = min (dm (k), dq (k), - dq (k + 1))
- else
- dm (k) = 0.
+ qc = fac_rc * ccn (k)
+ dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k))
+ dq = 0.5 * (ql (k) + dl (k) - qc)
+
+ if (dq .gt. 0.) then
+
+ c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow))
+ sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * &
+ exp (so3 * log (ql (k)))
+ sink = min (ql (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, sink, 0., 0., 0.)
+
endif
+
endif
+
enddo
- dm (km) = 0.
-
- ! -----------------------------------------------------------------------
- ! impose a presumed background horizontal variability that is proportional to the value itself
- ! -----------------------------------------------------------------------
+
+ endif
+
+ if (irain_f .eq. 1) then
+
+ do k = ks, ke
+
+ if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then
+
+ if (do_psd_water_num) then
+ call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, &
+ pca = pcaw, pcb = pcbw, pc = ccn (k))
+ ccn (k) = ccn (k) / den (k)
+ endif
- do k = 1, km
- dm (k) = max (dm (k), qvmin, h_var * q (k))
- enddo
- else
- do k = 1, km
- dm (k) = max (qvmin, h_var * q (k))
+ qc = fac_rc * ccn (k)
+ dq = ql (k) - qc
+
+ if (dq .gt. 0.) then
+
+ c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow))
+ sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k))))
+ sink = min (ql (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, sink, 0., 0., 0.)
+
+ endif
+
+ endif
+
enddo
+
endif
-end subroutine linear_prof
-
+end subroutine praut
+
! =======================================================================
-! ice cloud microphysics processes
-! bulk cloud micro - physics; processes splitting
-! with some un - split sub - grouping
-! time implicit (when possible) accretion and autoconversion
-! author: shian - jiann lin, gfdl
+! ice cloud microphysics
! =======================================================================
-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)
-
+subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, &
+ denfac, vtw, vtr, vti, vts, vtg, dts, h_var)
+
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, 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 :: 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, 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
-
+
! -----------------------------------------------------------------------
- ! define conversion scalar / factor
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- 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)
-
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts, h_var
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
! -----------------------------------------------------------------------
- ! define heat capacity and latend heat coefficient
+ ! local variables
! -----------------------------------------------------------------------
-
- do k = ks, ke
- q_liq (k) = qlk (k) + qrk (k)
- q_sol (k) = qik (k) + qsk (k) + qgk (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
-
+
+ real, dimension (ks:ke) :: di, q_liq, q_sol, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: cvm, te8
+
! -----------------------------------------------------------------------
- ! similar to lfo 1983: eq. 21 solved implicitly
- ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4
+ ! calculate heat capacities and latent heat coefficients
! -----------------------------------------------------------------------
-
- do k = ks, ke
- if (qi0_crt < 0.) then
- qim (k) = - qi0_crt
- else
- qim (k) = qi0_crt / den (k)
- endif
- enddo
-
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
if (.not. do_warm_rain_mp) then
-
+
! -----------------------------------------------------------------------
- ! 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
+ ! cloud ice melting to form cloud water and rain
! -----------------------------------------------------------------------
-
- do k = ks, ke
- if (tzk (k) > tice_mlt .and. qik (k) > qcmin) then
-
- ! -----------------------------------------------------------------------
- ! pimlt: instant melting of cloud ice
- ! -----------------------------------------------------------------------
-
- 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
-
+
+ call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! cloud water freezing to form cloud ice and snow
+ ! -----------------------------------------------------------------------
+
+ call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
+
! -----------------------------------------------------------------------
! vertical subgrid variability
! -----------------------------------------------------------------------
-
- call linear_prof (ke - ks + 1, qik (ks), di (ks), z_slope_ice, h_var)
-
+
+ call linear_prof (ke - ks + 1, qi, di, z_slope_ice, h_var)
+
! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
+ ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain
! -----------------------------------------------------------------------
+
+ call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtw, vtr, vts, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! graupel melting (includes graupel accretion with cloud water and rain) to form rain
+ ! -----------------------------------------------------------------------
+
+ call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! snow accretion with cloud ice
+ ! -----------------------------------------------------------------------
+
+ call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts)
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice to snow autoconversion
+ ! -----------------------------------------------------------------------
+
+ call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di)
+
+ ! -----------------------------------------------------------------------
+ ! graupel accretion with cloud ice
+ ! -----------------------------------------------------------------------
+
+ call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg)
+
+ ! -----------------------------------------------------------------------
+ ! snow accretion with rain and rain freezing to form graupel
+ ! -----------------------------------------------------------------------
+
+ call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtr, vts, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! graupel accretion with snow
+ ! -----------------------------------------------------------------------
+
+ call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg)
+
+ ! -----------------------------------------------------------------------
+ ! snow to graupel autoconversion
+ ! -----------------------------------------------------------------------
+
+ call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den)
+
+ ! -----------------------------------------------------------------------
+ ! graupel accretion with cloud water and rain
+ ! -----------------------------------------------------------------------
+
+ call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtr, vtg, lcpk, icpk, tcpk, tcp3)
+
+ endif ! do_warm_rain_mp
+
+end subroutine ice_cloud
- 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
-
- ! -----------------------------------------------------------------------
- ! do nothing above p_min
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! psacw: accretion of cloud water by snow
- ! only rate is used (for snow melt) since tc > 0.
- ! -----------------------------------------------------------------------
+! =======================================================================
+! cloud ice melting to form cloud water and rain, Lin et al. (1983)
+! =======================================================================
- 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
+subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, tmp, sink, fac_imlt
+
+ fac_imlt = 1. - exp (- dts / tau_imlt)
+
+ do k = ks, ke
+
+ tc = tz (k) - tice_mlt
+
+ if (tc .gt. 0 .and. qi (k) .gt. qcmin) then
+
+ sink = fac_imlt * tc / icpk (k)
+ sink = min (qi (k), sink)
+ tmp = min (sink, dim (ql_mlt, ql (k)))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pimlt
- ! -----------------------------------------------------------------------
- ! psacr: accretion of rain by melted snow
- ! pracs: accretion of snow by rain
- ! -----------------------------------------------------------------------
+! =======================================================================
+! cloud water freezing to form cloud ice and snow, Lin et al. (1983)
+! =======================================================================
- 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
+subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, tmp, sink, qim
+
+ do k = ks, ke
+
+ tc = t_wfr - tz (k)
+
+ if (tc .gt. 0. .and. ql (k) .gt. qcmin) then
+
+ sink = ql (k) * tc / dt_fr
+ sink = min (ql (k), sink, tc / icpk (k))
+ qim = qi0_crt / den (k)
+ tmp = min (sink, dim (qim, qi (k)))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pifr
- ! -----------------------------------------------------------------------
- ! total snow sink:
- ! psmlt: snow melt (due to rain accretion)
- ! -----------------------------------------------------------------------
-
- 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)
+! =======================================================================
+! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain
+! Lin et al. (1983)
+! =======================================================================
+subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtw, vtr, vts, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, factor, tmp, sink, qden, dqdt, tin, dq, qsi
+ real :: psacw, psacr, pracs
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .ge. 0. .and. qs (k) .gt. qcmin) then
+
+ psacw = 0.
+ qden = qs (k) * den (k)
+ if (ql (k) .gt. qcmin) then
+ if (do_new_acc_water) then
+ psacw = acr3d (vts (k), vtw (k), ql (k), qs (k), csacw, acco (:, 7), &
+ acc (13), acc (14), den (k))
+ else
+ factor = acr2d (qden, csacw, denfac (k), blins, mus)
+ psacw = factor / (1. + dts * factor) * ql (k)
endif
+ endif
+
+ psacr = 0.
+ pracs = 0.
+ if (qr (k) .gt. qcmin) then
+ psacr = min (acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), &
+ acc (3), acc (4), den (k)), qr (k) / dts)
+ pracs = acr3d (vtr (k), vts (k), qs (k), qr (k), cracs, acco (:, 1), &
+ acc (1), acc (2), den (k))
+ endif
+
+ tin = tz (k)
+ qsi = iqs (tin, den (k), dqdt)
+ dq = qsi - qv (k)
+ sink = max (0., pmlt (tc, dq, qden, psacw, psacr, csmlt, den (k), denfac (k), blins, mus, &
+ lcpk (k), icpk (k), cvm (k)))
+
+ sink = min (qs (k), (sink + pracs) * dts, tc / icpk (k))
+ tmp = min (sink, dim (qs_mlt, ql (k)))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine psmlt
- ! -----------------------------------------------------------------------
- ! melting of graupel
- ! -----------------------------------------------------------------------
-
- if (qg > qcmin .and. tc > 0.) then
-
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
-
- if (qr > qrmin) &
- pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), rdts * qr)
-
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by graupel
- ! -----------------------------------------------------------------------
+! =======================================================================
+! graupel melting (includes graupel accretion with cloud water and rain) to form rain
+! Lin et al. (1983)
+! =======================================================================
- qden = qg * den (k)
- if (ql > qrmin) then
- factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden)))
- pgacw = factor / (1. + dts * factor) * ql ! rate
+subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, factor, sink, qden, dqdt, tin, dq, qsi
+ real :: pgacw, pgacr
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .ge. 0. .and. qg (k) .gt. qcmin) then
+
+ pgacw = 0.
+ qden = qg (k) * den (k)
+ if (ql (k) .gt. qcmin) then
+ if (do_new_acc_water) then
+ pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw, acco (:, 9), &
+ acc (17), acc (18), den (k))
+ else
+ if (do_hail) then
+ factor = acr2d (qden, cgacw, denfac (k), blinh, muh)
+ else
+ factor = acr2d (qden, cgacw, denfac (k), bling, mug)
endif
-
- ! -----------------------------------------------------------------------
- ! 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)
+ pgacw = factor / (1. + dts * factor) * ql (k)
endif
-
+ endif
+
+ pgacr = 0.
+ if (qr (k) .gt. qcmin) then
+ pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), &
+ acc (5), acc (6), den (k)), qr (k) / dts)
+ endif
+
+ tin = tz (k)
+ qsi = iqs (tin, den (k), dqdt)
+ dq = qsi - qv (k)
+ if (do_hail) then
+ sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), &
+ blinh, muh, lcpk (k), icpk (k), cvm (k)))
else
+ sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), &
+ bling, mug, lcpk (k), icpk (k), cvm (k)))
+ endif
+
+ sink = min (qg (k), sink * dts, tc / icpk (k))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., sink, 0., 0., - sink, te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pgmlt
- ! -----------------------------------------------------------------------
- ! cloud ice proc:
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! psaci: accretion of cloud ice by snow
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! assuming linear subgrid vertical distribution of cloud ice
- ! the mismatch computation following lin et al. 1994, mwr
- ! -----------------------------------------------------------------------
-
- if (const_vi) then
- tmp = fac_i2s
- else
- tmp = fac_i2s * exp (0.025 * tc)
- endif
-
- 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
-
- ! -----------------------------------------------------------------------
- ! 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
- ! -----------------------------------------------------------------------
- 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
+! =======================================================================
+! snow accretion with cloud ice, Lin et al. (1983)
+! =======================================================================
+subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, factor, sink, qden
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qi (k) .gt. qcmin) then
+
+ sink = 0.
+ qden = qs (k) * den (k)
+ if (qs (k) .gt. qcmin) then
+ if (do_new_acc_ice) then
+ sink = dts * acr3d (vts (k), vti (k), qi (k), qs (k), csaci, acco (:, 8), &
+ acc (15), acc (16), den (k))
+ else
+ factor = dts * acr2d (qden, csaci, denfac (k), blins, mus)
+ sink = factor / (1. + factor) * qi (k)
endif
+ endif
+
+ sink = min (fi2s_fac * qi (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., - sink, sink, 0.)
+
+ endif
+
+ enddo
+
+end subroutine psaci
- ! -----------------------------------------------------------------------
- ! cold - rain proc:
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! rain to ice, snow, graupel processes:
- ! -----------------------------------------------------------------------
-
- tc = tz - tice
-
- if (qr > 1.e-7 .and. tc < 0.) then
-
- ! -----------------------------------------------------------------------
- ! * sink * terms to qr: psacr + pgfr
- ! source terms to qs: psacr
- ! source terms to qg: pgfr
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! psacr accretion of rain by snow
- ! -----------------------------------------------------------------------
-
- 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
-
- ! -----------------------------------------------------------------------
- ! pgfr: rain freezing -- > graupel
- ! -----------------------------------------------------------------------
-
- pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
- exp (1.75 * log (qr * den (k)))
-
- ! -----------------------------------------------------------------------
- ! total sink to qr
- ! -----------------------------------------------------------------------
-
- sink = psacr + pgfr
- factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin)
-
- psacr = factor * psacr
- pgfr = factor * pgfr
-
- 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
+! =======================================================================
+! cloud ice to snow autoconversion, Lin et al. (1983)
+! =======================================================================
- 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)
+subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, di
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, sink, fac_i2s, q_plus, qim, dq, tmp
+
+ fac_i2s = 1. - exp (- dts / tau_i2s)
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qi (k) .gt. qcmin) then
+
+ sink = 0.
+ tmp = fac_i2s * exp (0.025 * tc)
+ di (k) = max (di (k), qcmin)
+ q_plus = qi (k) + di (k)
+ qim = qi0_crt / den (k)
+ if (q_plus .gt. (qim + qcmin)) then
+ if (qim .gt. (qi (k) - di (k))) then
+ dq = (0.25 * (q_plus - qim) ** 2) / di (k)
+ else
+ dq = qi (k) - qim
endif
+ sink = tmp * dq
+ endif
+
+ sink = min (fi2s_fac * qi (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., - sink, sink, 0.)
+
+ endif
+
+ enddo
+
+end subroutine psaut
- ! -----------------------------------------------------------------------
- ! graupel production terms:
- ! -----------------------------------------------------------------------
-
- if (qs > 1.e-7) then
-
- ! -----------------------------------------------------------------------
- ! accretion: snow -- > graupel
- ! -----------------------------------------------------------------------
-
- if (qg > qrmin) then
- sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k))
- else
- sink = 0.
- endif
-
- ! -----------------------------------------------------------------------
- ! autoconversion 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
-
- endif ! snow existed
-
- if (qg > 1.e-7 .and. tz < tice) then
-
- ! -----------------------------------------------------------------------
- ! pgacw: accretion of cloud water by 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
-
- ! -----------------------------------------------------------------------
- ! pgacr: accretion of rain by graupel
- ! -----------------------------------------------------------------------
+! =======================================================================
+! graupel accretion with cloud ice, Lin et al. (1983)
+! =======================================================================
- if (qr > 1.e-6) then
- pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), &
- den (k)), qr)
+subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, factor, sink, qden
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qi (k) .gt. qcmin) then
+
+ sink = 0.
+ qden = qg (k) * den (k)
+ if (qg (k) .gt. qcmin) then
+ if (do_new_acc_ice) then
+ sink = dts * acr3d (vtg (k), vti (k), qi (k), qg (k), cgaci, acco (:, 10), &
+ acc (19), acc (20), den (k))
+ else
+ if (do_hail) then
+ factor = dts * acr2d (qden, cgaci, denfac (k), blinh, muh)
else
- pgacr = 0.
+ factor = dts * acr2d (qden, cgaci, denfac (k), bling, mug)
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)
+ sink = factor / (1. + factor) * qi (k)
endif
-
endif
-
- tzk (k) = tz
- qvk (k) = qv
- qlk (k) = ql
- qik (k) = qi
- qrk (k) = qr
- qsk (k) = qs
- qgk (k) = qg
-
- 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
+
+ sink = min (fi2g_fac * qi (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., - sink, 0., sink)
+
+ endif
+
+ enddo
+
+end subroutine pgaci
! =======================================================================
-! temperature sentive high vertical resolution processes
+! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983)
! =======================================================================
-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)
-
+subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtr, vts, lcpk, icpk, tcpk, tcp3)
+
implicit none
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
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, rh_tem
- real :: dqsdt, dwsdt, dq, dq0, factor, tmp, liq, ice
- 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
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: k
+
+ real :: tc, factor, sink
+ real :: psacr, pgfr
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qr (k) .gt. qcmin) then
+
+ psacr = 0.
+ if (qs (k) .gt. qcmin) then
+ psacr = dts * acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), &
+ acc (3), acc (4), den (k))
+ endif
+
+ pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * &
+ exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k)))
+
+ sink = psacr + pgfr
+ factor = min (sink, qr (k), - tc / icpk (k)) / max (sink, qcmin)
+ psacr = factor * psacr
+ pgfr = factor * pgfr
+
+ sink = min (qr (k), psacr + pgfr)
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., - sink, 0., psacr, pgfr, te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine psacr_pgfr
- if (do_sat_adj) then
- dt_evap = 0.5 * dts
- else
- dt_evap = dts
- endif
+! =======================================================================
+! graupel accretion with snow, Lin et al. (1983)
+! =======================================================================
+subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg)
+
+ implicit none
+
! -----------------------------------------------------------------------
- ! define conversion scalar / factor
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- 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)
-
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, vts, vtg
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
! -----------------------------------------------------------------------
- ! define heat capacity and latend heat coefficient
+ ! local variables
! -----------------------------------------------------------------------
-
+
+ integer :: k
+
+ real :: sink
+
do k = ks, ke
- q_liq (k) = ql (k) + qr (k)
- q_sol (k) = qi (k) + qs (k) + qg (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))
+
+ if (tz (k) .lt. tice .and. qs (k) .gt. qcmin .and. qg (k) .gt. qcmin) then
+
+ sink = dts * acr3d (vtg (k), vts (k), qs (k), qg (k), cgacs, acco (:, 4), &
+ acc (7), acc (8), den (k))
+ sink = min (fs2g_fac * qs (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., 0., - sink, sink)
+
+ endif
+
enddo
+
+end subroutine pgacs
- cond = 0
- dep = 0
- reevap = 0
- sub = 0
+! =======================================================================
+! snow to graupel autoconversion, Lin et al. (1983)
+! =======================================================================
+subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, factor, sink, qsm
+
do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qs (k) .gt. qcmin) then
+
+ sink = 0
+ qsm = qs0_crt / den (k)
+ if (qs (k) .gt. qsm) then
+ factor = dts * 1.e-3 * exp (0.09 * (tz (k) - tice))
+ sink = factor / (1. + factor) * (qs (k) - qsm)
+ endif
+
+ sink = min (fs2g_fac * qs (k), sink)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., 0., - sink, sink)
+
+ endif
+
+ enddo
+
+end subroutine pgaut
- if (p1 (k) < p_min) cycle
+! =======================================================================
+! graupel accretion with cloud water and rain, Lin et al. (1983)
+! =======================================================================
- if (.not. do_warm_rain_mp) then
+subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
+ vtr, vtg, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, factor, sink, qden
+ real :: pgacw, pgacr
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qg (k) .gt. qcmin) then
+
+ pgacw = 0.
+ if (ql (k) .gt. qcmin) then
+ qden = qg (k) * den (k)
+ if (do_hail) then
+ factor = dts * acr2d (qden, cgacw, denfac (k), blinh, muh)
+ else
+ factor = dts * acr2d (qden, cgacw, denfac (k), bling, mug)
+ endif
+ pgacw = factor / (1. + factor) * ql (k)
+ endif
+
+ pgacr = 0.
+ if (qr (k) .gt. qcmin) then
+ pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), &
+ acc (5), acc (6), den (k)), qr (k))
+ endif
+
+ sink = pgacr + pgacw
+ factor = min (sink, dim (tice, tz (k)) / icpk (k)) / max (sink, qcmin)
+ pgacr = factor * pgacr
+ pgacw = factor * pgacw
+
+ sink = pgacr + pgacw
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - pgacw, - pgacr, 0., 0., sink, te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pgacw_pgacr
- ! -----------------------------------------------------------------------
- ! instant deposit all water vapor to cloud ice when temperature is super low
- ! -----------------------------------------------------------------------
+! =======================================================================
+! temperature sentive high vertical resolution processes
+! =======================================================================
- 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
+subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, &
+ qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts, rh_adj
+
+ real, intent (in), dimension (ks:ke) :: den, denfac, dp
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin
+
+ real, intent (out) :: cond, dep, reevap, sub
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: cvm, te8
+
+ ! -----------------------------------------------------------------------
+ ! initialization
+ ! -----------------------------------------------------------------------
+
+ cond = 0
+ dep = 0
+ reevap = 0
+ sub = 0
+
+ ! -----------------------------------------------------------------------
+ ! calculate heat capacities and latent heat coefficients
+ ! -----------------------------------------------------------------------
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! instant processes (include deposition, evaporation, and sublimation)
+ ! -----------------------------------------------------------------------
+
+ if (.not. do_warm_rain_mp) then
+
+ call pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! cloud water condensation and evaporation
+ ! -----------------------------------------------------------------------
+
+ call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, cond, reevap)
+
+ if (.not. do_warm_rain_mp) then
+
+ ! -----------------------------------------------------------------------
+ ! enforce complete freezing below t_wfr
+ ! -----------------------------------------------------------------------
+
+ call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! Wegener Bergeron Findeisen process
+ ! -----------------------------------------------------------------------
+
+ call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! Bigg freezing mechanism
+ ! -----------------------------------------------------------------------
+
+ call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3)
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice deposition and sublimation
+ ! -----------------------------------------------------------------------
+
+ call pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, cin, dep, sub)
+
+ ! -----------------------------------------------------------------------
+ ! snow deposition and sublimation
+ ! -----------------------------------------------------------------------
+
+ call psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
+
+ ! -----------------------------------------------------------------------
+ ! graupel deposition and sublimation
+ ! -----------------------------------------------------------------------
+
+ call pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
+
+ endif
+
+end subroutine subgrid_z_proc
- ! -----------------------------------------------------------------------
- ! 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
+! =======================================================================
+! instant processes (include deposition, evaporation, and sublimation)
+! =======================================================================
+subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: rh_adj
+
+ real, intent (in), dimension (ks:ke) :: den, dp
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ real, intent (out) :: dep, reevap, sub
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: sink, tin, qpz, rh, dqdt, tmp, qsi
+
+ do k = ks, ke
+
+ ! -----------------------------------------------------------------------
+ ! instant deposit all water vapor to cloud ice when temperature is super low
+ ! -----------------------------------------------------------------------
+
+ if (tz (k) .lt. t_min) then
+
+ sink = dim (qv (k), qcmin)
+ dep = dep + sink * dp (k)
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
endif
-
+
! -----------------------------------------------------------------------
- ! cloud water < -- > vapor adjustment:
+ ! instant evaporation / sublimation of all clouds when rh < rh_adj
! -----------------------------------------------------------------------
+
+ qpz = qv (k) + ql (k) + qi (k)
+ tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / &
+ mhc (qpz, qr (k), qs (k) + qg (k))
+
+ if (tin .gt. t_sub + 6.) then
+
+ qsi = iqs (tin, den (k), dqdt)
+ rh = qpz / qsi
+ if (rh .lt. rh_adj) then
+
+ sink = ql (k)
+ tmp = qi (k)
+
+ reevap = reevap + sink * dp (k)
+ sub = sub + tmp * dp (k)
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ sink + tmp, - sink, 0., - tmp, 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ endif
+
+ enddo
+
+end subroutine pinst
+
+! =======================================================================
+! cloud water condensation and evaporation, Hong and Lim (2006)
+! =======================================================================
+subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, cond, reevap)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, dp
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ real, intent (out) :: cond, reevap
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: sink, tin, qpz, dqdt, qsw, rh_tem, dq, factor, fac_l2v, fac_v2l
+
+ fac_l2v = 1. - exp (- dts / tau_l2v)
+ fac_v2l = 1. - exp (- dts / tau_v2l)
+
+ do k = ks, ke
+
tin = tz (k)
- rh_tem = qpz / iqs1 (tin, den (k))
- qsw = wqs2 (tin, den (k), dwsdt)
- dq0 = qsw - qv (k)
- 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
+ qsw = wqs (tin, den (k), dqdt)
+ qpz = qv (k) + ql (k) + qi (k)
+ rh_tem = qpz / qsw
+ dq = qsw - qv (k)
+ if (dq .gt. 0.) then
+ factor = min (1., fac_l2v * (rh_fac * dq / qsw))
+ sink = min (ql (k), factor * dq / (1. + tcp3 (k) * dqdt))
+ if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then
+ sink = 0.
endif
+ reevap = reevap + sink * dp (k)
+ elseif (do_cond_timescale) then
+ factor = min (1., fac_v2l * (rh_fac * (- dq) / qsw))
+ sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt))
+ cond = cond - sink * dp (k)
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
+ sink = - min (qv (k), - dq / (1. + tcp3 (k) * dqdt))
+ cond = cond - sink * dp (k)
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) = 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)
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ sink, - sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ enddo
+
+end subroutine pcond_pevap
- ! -----------------------------------------------------------------------
- ! update heat capacity and latend heat coefficient
- ! -----------------------------------------------------------------------
+! =======================================================================
+! enforce complete freezing below t_wfr, Lin et al. (1983)
+! =======================================================================
- icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
+subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, sink
+
+ do k = ks, ke
+
+ tc = t_wfr - tz (k)
+
+ if (tc .gt. 0. .and. ql (k) .gt. qcmin) then
+
+ sink = ql (k) * tc / dt_fr
+ sink = min (ql (k), sink, tc / icpk (k))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pcomp
- if (.not. do_warm_rain_mp) then
+! =======================================================================
+! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015)
+! =======================================================================
- ! -----------------------------------------------------------------------
- ! enforce complete freezing below - 48 c
- ! -----------------------------------------------------------------------
+subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf
- 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
+ if (.not. do_wbf) return
+
+ fac_wbf = 1. - exp (- dts / tau_wbf)
+
+ do k = ks, ke
+
+ tc = tice - tz (k)
+
+ tin = tz (k)
+ qsw = wqs (tin, den (k), dqdt)
+ qsi = iqs (tin, den (k), dqdt)
+
+ if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. &
+ qv (k) .gt. qsi .and. qv (k) .lt. qsw) then
+
+ sink = min (fac_wbf * ql (k), tc / icpk (k))
+ qim = qi0_crt / den (k)
+ tmp = min (sink, dim (qim, qi (k)))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pwbf
- ! -----------------------------------------------------------------------
- ! bigg mechanism
- ! -----------------------------------------------------------------------
+! =======================================================================
+! Bigg freezing mechanism, Bigg (1953)
+! =======================================================================
- if (do_sat_adj) then
- dt_pisub = 0.5 * dts
- else
- 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
+subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: sink, tc
+
+ do k = ks, ke
+
+ tc = tice - tz (k)
+
+ if (tc .gt. 0 .and. ql (k) .gt. qcmin) then
+
+ if (do_psd_water_num) then
+ call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, &
+ pca = pcaw, pcb = pcbw, pc = ccn (k))
+ ccn (k) = ccn (k) / den (k)
endif
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
+ sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2
+ sink = min (ql (k), sink, tc / icpk (k))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of ice
- ! -----------------------------------------------------------------------
+end subroutine pbigg
+
+! =======================================================================
+! cloud ice deposition and sublimation, Hong et al. (2004)
+! =======================================================================
- 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
- pidep = 0.
+subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ lcpk, icpk, tcpk, tcp3, cin, dep, sub)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, dp
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, cin
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ real, intent (out) :: dep, sub
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: sink, tin, dqdt, qsi, dq, pidep, tmp, tc, qi_gen, qi_crt
+
+ do k = ks, ke
+
+ if (tz (k) .lt. tice) then
+
+ pidep = 0.
+ tin = tz (k)
+ qsi = iqs (tin, den (k), dqdt)
+ dq = qv (k) - qsi
+ tmp = dq / (1. + tcpk (k) * dqdt)
+
+ if (qi (k) .gt. qcmin) then
+ if (.not. prog_ccn) then
+ if (inflag .eq. 1) &
+ cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k)))
+ if (inflag .eq. 2) &
+ cin (k) = exp (- 2.80 + 0.262 * (tice - tz (k))) * 1000.0
+ if (inflag .eq. 3) &
+ cin (k) = exp (- 0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0
+ if (inflag .eq. 4) &
+ cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0
+ if (inflag .eq. 5) &
+ cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.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)
+ if (do_psd_ice_num) then
+ call cal_pc_ed_oe_rr_tv (qi (k), den (k), blini, mui, &
+ pca = pcai, pcb = pcbi, pc = cin (k))
+ cin (k) = cin (k) / den (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)
+ pidep = dts * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) / &
+ (qsi * den (k) * (tcpk (k) * cvm (k)) ** 2 / (tcond * rvgas * tz (k) ** 2) + &
+ 1. / vdifu)
endif
+
+ if (dq .gt. 0.) then
+ tc = tice - tz (k)
+ qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tc)))
+ if (igflag .eq. 1) &
+ qi_crt = qi_gen / den (k)
+ if (igflag .eq. 2) &
+ qi_crt = qi_gen * min (qi_lim, 0.1 * tc) / den (k)
+ if (igflag .eq. 3) &
+ qi_crt = 1.82e-6 * min (qi_lim, 0.1 * tc) / den (k)
+ if (igflag .eq. 4) &
+ qi_crt = max (qi_gen, 1.82e-6) * min (qi_lim, 0.1 * tc) / den (k)
+ sink = min (tmp, max (qi_crt - qi (k), pidep), tc / tcpk (k))
+ dep = dep + sink * dp (k)
+ else
+ pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac)
+ sink = max (pidep, tmp, - qi (k))
+ sub = sub - sink * dp (k)
+ endif
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pidep_pisub
- ! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
- ! -----------------------------------------------------------------------
-
- tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
-
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of snow
- ! this process happens for all temp rage
- ! -----------------------------------------------------------------------
+! =======================================================================
+! snow deposition and sublimation, Lin et al. (1983)
+! =======================================================================
- 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
- 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)
+subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, dp, denfac
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ real, intent (out) :: dep, sub
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: sink, tin, dqdt, qsi, qden, t2, dq, pssub
+
+ do k = ks, ke
+
+ if (qs (k) .gt. qcmin) then
+
+ tin = tz (k)
+ qsi = iqs (tin, den (k), dqdt)
+ qden = qs (k) * den (k)
+ t2 = tz (k) * tz (k)
+ dq = qsi - qv (k)
+ pssub = psub (t2, dq, qden, qsi, cssub, den (k), denfac (k), blins, mus, tcpk (k), cvm (k))
+ pssub = dts * pssub
+ dq = dq / (1. + tcpk (k) * dqdt)
+ if (pssub .gt. 0.) then
+ sink = min (pssub * min (1., dim (tz (k), t_sub) * ss_fac), qs (k))
+ sub = sub + sink * dp (k)
+ else
+ sink = 0.
+ if (tz (k) .le. tice) then
+ sink = max (pssub, dq, (tz (k) - tice) / tcpk (k))
endif
- 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)
+ dep = dep - sink * dp (k)
endif
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ sink, 0., 0., 0., - sink, 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine psdep_pssub
- ! -----------------------------------------------------------------------
- ! sublimation / deposition of graupel
- ! this process happens for all temp rage
- ! -----------------------------------------------------------------------
+! =======================================================================
+! graupel deposition and sublimation, Lin et al. (1983)
+! =======================================================================
- 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)
+subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
+ denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den, dp, denfac
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ real, intent (out) :: dep, sub
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub
+
+ do k = ks, ke
+
+ if (qg (k) .gt. qcmin) then
+
+ tin = tz (k)
+ qsi = iqs (tin, den (k), dqdt)
+ qden = qg (k) * den (k)
+ t2 = tz (k) * tz (k)
+ dq = qsi - qv (k)
+ if (do_hail) then
+ pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), &
+ blinh, muh, tcpk (k), cvm (k))
+ else
+ pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), &
+ bling, mug, tcpk (k), cvm (k))
+ endif
+ pgsub = dts * pgsub
+ dq = dq / (1. + tcpk (k) * dqdt)
+ if (pgsub .gt. 0.) then
+ sink = min (pgsub * min (1., dim (tz (k), t_sub) * gs_fac), qg (k))
+ sub = sub + sink * dp (k)
+ else
+ sink = 0.
+ if (tz (k) .le. tice) then
+ sink = max (pgsub, dq, (tz (k) - tice) / tcpk (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)
+ dep = dep - sink * dp (k)
endif
-
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ sink, 0., 0., 0., 0., - sink, te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
endif
+
+ enddo
+
+end subroutine pgdep_pgsub
- ! -----------------------------------------------------------------------
- ! compute cloud fraction
- ! -----------------------------------------------------------------------
+! =======================================================================
+! cloud fraction diagnostic
+! =======================================================================
- ! -----------------------------------------------------------------------
+subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_var, gsize)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: h_var, gsize
+
+ real, intent (in), dimension (ks:ke) :: pz, den
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: tz
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: q_plus, q_minus
+ real :: rh, rqi, tin, qsw, qsi, qpz, qstar, sigma, gam
+ real :: dqdt, dq, liq, ice
+ real :: qa10, qa100
+
+ real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), dimension (ks:ke) :: cvm, te8
+
+ ! -----------------------------------------------------------------------
+ ! calculate heat capacities and latent heat coefficients
+ ! -----------------------------------------------------------------------
+
+ call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
+ lcpk, icpk, tcpk, tcp3)
+
+ do k = ks, ke
+
! combine water species
- ! -----------------------------------------------------------------------
-
- if (.not. (do_qa .and. last_step)) cycle
-
+
ice = q_sol (k)
+ q_sol (k) = qi (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)
+ q_liq (k) = ql (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)
-
- ! -----------------------------------------------------------------------
+
! 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) * 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
- ! -----------------------------------------------------------------------
-
- if (tin <= t_wfr) then
- ! ice phase:
- qstar = iqs1 (tin, den (k))
- elseif (tin >= tice) then
- ! liquid phase:
- qstar = wqs1 (tin, den (k))
+ tin = (te8 (k) - lv00 * qpz + li00 * ice) / mhc (qpz, liq, ice)
+
+ ! calculate saturated specific humidity
+
+ if (tin .le. t_wfr) then
+ qstar = iqs (tin, den (k), dqdt)
+ elseif (tin .ge. tice) then
+ qstar = wqs (tin, den (k), dqdt)
else
- ! mixed phase:
- qsi = iqs1 (tin, den (k))
- qsw = wqs1 (tin, den (k))
- if (q_cond (k) > 3.e-6) then
+ qsi = iqs (tin, den (k), dqdt)
+ qsw = wqs (tin, den (k), dqdt)
+ if (q_cond (k) .gt. qcmin) then
rqi = q_sol (k) / q_cond (k)
else
- ! -----------------------------------------------------------------------
- ! mostly liquid water q_cond (k) at initial cloud development stage
- ! -----------------------------------------------------------------------
rqi = (tice - tin) / (tice - t_wfr)
endif
qstar = rqi * qsi + (1. - rqi) * qsw
endif
-
- ! -----------------------------------------------------------------------
- ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the
- ! binary cloud scheme
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! 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
+
+ ! cloud schemes
+
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
-
+
+ if (cfflag .eq. 1) then
+ if (rh .gt. rh_thres .and. qpz .gt. qcmin) 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)))
+ q_plus = qpz + dq * f_dq_p * min (1.0, max (0.0, (pz (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
+ if (qstar .lt. qpz) then
qa (k) = 1.
else
qa (k) = 0.
endif
elseif (icloud_f .eq. 3) then
- if (qstar < qpz) then
+ if (qstar .lt. qpz) then
qa (k) = 1.
else
- if (qstar < q_plus) then
+ if (qstar .lt. 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
+ if (q_cond (k) .gt. qcmin) then
qa (k) = max (cld_min, qa (k))
endif
qa (k) = min (1., qa (k))
endif
else
- if (qstar < q_minus) then
+ if (qstar .lt. q_minus) then
qa (k) = 1.
else
- if (qstar < q_plus) then
+ if (qstar .lt. 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)))
+ 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
+ if (q_cond (k) .gt. qcmin) then
qa (k) = max (cld_min, qa (k))
endif
qa (k) = min (1., qa (k))
@@ -2441,2157 +4692,2923 @@ subroutine subgrid_z_proc (ks, ke, p1, den, denfac, dts, rh_adj, tz, qv, ql, qr,
qa (k) = 0.
endif
endif
-
+
+ if (cfflag .eq. 2) then
+ if (rh .ge. 1.0) then
+ qa (k) = 1.0
+ elseif (rh .gt. rh_thres .and. q_cond (k) .gt. qcmin) then
+ qa (k) = exp (xr_a * log (rh)) * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / &
+ max (1.e-5, exp (xr_c * log (max (1.e-10, 1.0 - rh) * qstar)))))
+ qa (k) = max (0.0, min (1., qa (k)))
+ else
+ qa (k) = 0.0
+ endif
+ endif
+
+ if (cfflag .eq. 3) then
+ if (q_cond (k) .gt. qcmin) then
+ qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * &
+ exp (1.07 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + &
+ 4.82 * (gsize / 1000. - 50.) * &
+ exp (0.94 * log (max (qcmin * 1000., q_cond (k) * 1000.))))
+ 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
+ endif
+
+ if (cfflag .eq. 4) then
+ sigma = 0.28 + exp (0.49 * log (max (qcmin * 1000., q_cond (k) * 1000.)))
+ gam = max (0.0, q_cond (k) * 1000.) / sigma
+ if (gam .lt. 0.18) then
+ qa10 = 0.
+ elseif (gam .gt. 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 .lt. 0.12) then
+ qa100 = 0.
+ elseif (gam .gt. 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)))
+ endif
+
enddo
-
-end subroutine subgrid_z_proc
+
+end subroutine cloud_fraction
! =======================================================================
-! rain evaporation
+! piecewise parabolic lagrangian scheme
+! this subroutine is the same as map1_q2 in fv_mapz_mod.
! =======================================================================
-subroutine revap_rac1 (hydrostatic, is, ie, dt, tz, qv, ql, qr, qi, qs, qg, den, hvar)
-
+subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1)
+
implicit none
-
- 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
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- 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))
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: zs
+
+ real, intent (in), dimension (ks:ke + 1) :: ze, zt
+
+ real, intent (in), dimension (ks:ke) :: dp
+
+ real, intent (inout), dimension (ks:ke) :: q
+
+ real, intent (inout) :: precip
+
+ real, intent (out), dimension (ks:ke) :: m1
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k, k0, n, m
+
+ real :: a4 (4, ks:ke), pl, pr, delz, esl
+
+ real, parameter :: r3 = 1. / 3., r23 = 2. / 3.
+
+ real, dimension (ks:ke) :: qm, dz
+
+ ! -----------------------------------------------------------------------
+ ! density:
+ ! -----------------------------------------------------------------------
+
+ do k = ks, ke
+ dz (k) = zt (k) - zt (k + 1)
+ q (k) = q (k) * dp (k)
+ a4 (1, k) = q (k) / dz (k)
+ qm (k) = 0.
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
+
+ ! -----------------------------------------------------------------------
+ ! construct vertical profile with zt as coordinate
+ ! -----------------------------------------------------------------------
+
+ call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1)
+
+ k0 = ks
+ do k = ks, ke
+ do n = k0, ke
+ if (ze (k) .le. zt (n) .and. ze (k) .ge. zt (n + 1)) then
+ pl = (zt (n) - ze (k)) / dz (n)
+ if (zt (n + 1) .le. ze (k + 1)) then
+ ! entire new grid is within the original grid
+ pr = (zt (n) - ze (k + 1)) / dz (n)
+ qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - &
+ a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2)
+ qm (k) = qm (k) * (ze (k) - ze (k + 1))
+ k0 = n
+ goto 555
else
- ! q_minus < qsat < q_plus
- ! dq == dqh if qsat == q_minus
- dq = 0.25 * (q_minus - qsat) ** 2 / dqh
+ 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 .lt. ke) then
+ do m = n + 1, ke
+ ! locate the bottom edge: ze (k + 1)
+ if (ze (k + 1) .lt. zt (m + 1)) then
+ qm (k) = qm (k) + q (m)
+ else
+ delz = zt (m) - ze (k + 1)
+ esl = delz / dz (m)
+ qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * &
+ (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl)))
+ k0 = m
+ goto 555
+ endif
+ enddo
+ endif
+ goto 555
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
+ 555 continue
enddo
-
-end subroutine revap_rac1
+
+ m1 (ks) = q (ks) - qm (ks)
+ do k = ks + 1, ke
+ m1 (k) = m1 (k - 1) + q (k) - qm (k)
+ enddo
+ precip = 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 = ks, ke
+ q (k) = qm (k) / dp (k)
+ enddo
+
+end subroutine lagrangian_fall
! =======================================================================
-! compute terminal fall speed
-! consider cloud ice, snow, and graupel's melting during fall
+! vertical profile reconstruction
+! this subroutine is the same as cs_profile in fv_mapz_mod where iv = 0 and kord = 9
! =======================================================================
-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)
-
+subroutine cs_profile (a4, del, km)
+
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
-
- integer :: k, k0, m
- logical :: no_fall
-
- dt5 = 0.5 * dtm
- fac_imlt = 1. - exp (- dt5 / tau_imlt)
-
+
! -----------------------------------------------------------------------
- ! define heat capacity and latend heat coefficient
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- do k = ks, ke
- m1_sol (k) = 0.
- q_liq (k) = ql (k) + qr (k)
- q_sol (k) = qi (k) + qs (k) + qg (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)
+
+ integer, intent (in) :: km
+
+ real, intent (in) :: del (km)
+
+ real, intent (inout) :: a4 (4, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ logical :: extm (km)
+
+ real :: gam (km), q (km + 1), d4, bet, a_bot, grat, pmp, lac
+ real :: pmp_1, lac_1, pmp_2, lac_2, da1, da2, a6da
+
+ grat = del (2) / del (1) ! grid ratio
+ bet = grat * (grat + 0.5)
+ q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet
+ gam (1) = (1. + grat * (grat + 1.5)) / bet
+
+ do k = 2, km
+ d4 = del (k - 1) / del (k)
+ bet = 2. + 2. * d4 - gam (k - 1)
+ q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet
+ gam (k) = d4 / bet
enddo
-
+
+ a_bot = 1. + d4 * (d4 + 1.5)
+ q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) &
+ / (d4 * (d4 + 0.5) - a_bot * gam (km))
+
+ do k = km, 1, - 1
+ q (k) = q (k) - gam (k) * q (k + 1)
+ enddo
+
! -----------------------------------------------------------------------
- ! find significant melting level
+ ! apply constraints
! -----------------------------------------------------------------------
-
- k0 = ke
- do k = ks, ke - 1
- if (tz (k) > tice) then
- k0 = k
- exit
- endif
+
+ do k = 2, km
+ gam (k) = a4 (1, k) - a4 (1, k - 1)
enddo
-
+
+ ! -----------------------------------------------------------------------
+ ! top:
! -----------------------------------------------------------------------
- ! melting of cloud_ice (before fall) :
+
+ q (1) = max (q (1), 0.)
+ q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2)))
+ q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.)
+
! -----------------------------------------------------------------------
-
- 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))
- tmp = min (sink, dim (ql_mlt, ql (k)))
- ql (k) = ql (k) + tmp
- qr (k) = qr (k) + sink - tmp
- qi (k) = qi (k) - sink
- q_liq (k) = q_liq (k) + sink
- q_sol (k) = q_sol (k) - sink
- 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
+ ! interior:
+ ! -----------------------------------------------------------------------
+
+ do k = 3, km - 1
+ if (gam (k - 1) * gam (k + 1) .gt. 0.) then
+ ! apply large - scale constraints to all fields if not local max / min
+ q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k)))
+ q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k)))
+ else
+ if (gam (k - 1) .gt. 0.) then
+ ! there exists a local max
+ q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k)))
+ else
+ ! there exists a local min
+ q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k)))
+ ! positive-definite
+ q (k) = max (q (k), 0.0)
+ endif
endif
enddo
-
+
! -----------------------------------------------------------------------
- ! turn off melting when cloud microphysics time step is small
+ ! bottom:
! -----------------------------------------------------------------------
-
- ! sjl, turn off melting of falling cloud ice, snow and graupel
- ! if (dtm < 60.) k0 = ke
- k0 = ke
- ! sjl, turn off melting of falling cloud ice, snow and graupel
-
- ze (ke + 1) = zs
- do k = ke, ks, - 1
- ze (k) = ze (k + 1) - dz (k) ! dz < 0
+
+ q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km)))
+ q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.)
+ q (km + 1) = max (q (km + 1), 0.)
+
+ do k = 1, km
+ a4 (2, k) = q (k)
+ a4 (3, k) = q (k + 1)
+ enddo
+
+ do k = 1, km
+ if (k .eq. 1 .or. k .eq. km) then
+ extm (k) = (a4 (2, k) - a4 (1, k)) * (a4 (3, k) - a4 (1, k)) .gt. 0.
+ else
+ extm (k) = gam (k) * gam (k + 1) .lt. 0.
+ endif
enddo
-
- zt (ks) = ze (ks)
! -----------------------------------------------------------------------
- ! update capacity heat and latend heat coefficient
+ ! apply constraints
+ ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1)
+ ! always use monotonic mapping
! -----------------------------------------------------------------------
- do k = k0, ke
- icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
- enddo
-
! -----------------------------------------------------------------------
- ! melting of falling cloud ice into cloud water and rain
+ ! top:
! -----------------------------------------------------------------------
- call check_column (ks, ke, qi, no_fall)
-
- if (vi_fac < 1.e-5 .or. no_fall) then
- i1 = 0.
- else
+ a4 (2, 1) = max (0., a4 (2, 1))
+
+ ! -----------------------------------------------------------------------
+ ! Huynh's 2nd constraint for interior:
+ ! -----------------------------------------------------------------------
- do k = ks + 1, ke
- zt (k) = ze (k) - dt5 * (vti (k - 1) + vti (k))
- enddo
- zt (ke + 1) = zs - dtm * vti (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
-
- if (k0 < ke) then
- do k = ke - 1, k0, - 1
- if (qi (k) > qrmin) then
- 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))
- sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
- tmp = min (sink, dim (ql_mlt, ql (m)))
- ql (m) = ql (m) + tmp
- qr (m) = qr (m) - tmp + sink
- 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
- enddo
- endif
-
- if (do_sedi_w) then
- 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_ice) then
- call lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof)
+ do k = 3, km - 2
+ if (extm (k)) then
+ ! positive definite constraint only if true local extrema
+ if (a4 (1, k) .lt. qcmin .or. extm (k - 1) .or. extm (k + 1)) then
+ a4 (2, k) = a4 (1, k)
+ a4 (3, k) = a4 (1, k)
+ endif
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)
+ a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k))
+ if (abs (a4 (4, k)) .gt. abs (a4 (2, k) - a4 (3, k))) then
+ ! check within the smooth region if subgrid profile is non - monotonic
+ pmp_1 = a4 (1, k) - 2.0 * gam (k + 1)
+ lac_1 = pmp_1 + 1.5 * gam (k + 2)
+ a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), &
+ max (a4 (1, k), pmp_1, lac_1))
+ pmp_2 = a4 (1, k) + 2.0 * gam (k)
+ lac_2 = pmp_2 - 1.5 * gam (k - 1)
+ a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), &
+ max (a4 (1, k), pmp_2, lac_2))
+ endif
endif
-
- if (do_sedi_w) then
- 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
+ enddo
+
+ do k = 1, km - 1
+ a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k))
+ enddo
+
+ k = km - 1
+ if (extm (k)) then
+ a4 (2, k) = a4 (1, k)
+ a4 (3, k) = a4 (1, k)
+ a4 (4, k) = 0.
+ else
+ da1 = a4 (3, k) - a4 (2, k)
+ da2 = da1 ** 2
+ a6da = a4 (4, k) * da1
+ if (a6da .lt. - da2) then
+ a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k))
+ a4 (3, k) = a4 (2, k) - a4 (4, k)
+ elseif (a6da .gt. da2) then
+ a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k))
+ a4 (2, k) = a4 (3, k) - a4 (4, k)
endif
-
endif
-
+
+ call cs_limiters (km - 1, a4)
+
! -----------------------------------------------------------------------
- ! melting of falling snow into rain
+ ! bottom:
! -----------------------------------------------------------------------
-
- r1 = 0.
-
- call check_column (ks, ke, qs, no_fall)
-
- if (no_fall) then
- s1 = 0.
- else
-
- do k = ks + 1, ke
- zt (k) = ze (k) - dt5 * (vts (k - 1) + vts (k))
- enddo
- zt (ke + 1) = zs - dtm * vts (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
-
- if (k0 < ke) then
- do k = ke - 1, k0, - 1
- if (qs (k) > qrmin) then
- 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
- dtime = min (1.0, dtime / tau_smlt)
- sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
- tz (m) = tz (m) - sink * icpk (m)
- qs (k) = qs (k) - sink * dp (m) / dp (k)
- if (zt (k) < zs) then
- r1 = r1 + sink * dp (m) ! precip as rain
- else
- ! qr source here will fall next time step (therefore, can evap)
- qr (m) = qr (m) + sink
- endif
- endif
- if (qs (k) < qrmin) exit
- enddo
- endif
- enddo
- endif
-
- if (do_sedi_w) then
- 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 (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
-
- if (do_sedi_w) then
- 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
-
- endif
-
- ! ----------------------------------------------
- ! melting of falling graupel into rain
- ! ----------------------------------------------
-
- call check_column (ks, ke, qg, no_fall)
-
- if (no_fall) then
- g1 = 0.
- else
-
- do k = ks + 1, ke
- zt (k) = ze (k) - dt5 * (vtg (k - 1) + vtg (k))
- enddo
- zt (ke + 1) = zs - dtm * vtg (ke)
-
- do k = ks, ke
- if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min
- enddo
-
- if (k0 < ke) then
- do k = ke - 1, k0, - 1
- if (qg (k) > qrmin) then
- 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
- dtime = min (1., dtime / tau_g2r)
- sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m))
- tz (m) = tz (m) - sink * icpk (m)
- qg (k) = qg (k) - sink * dp (m) / dp (k)
- if (zt (k) < zs) then
- r1 = r1 + sink * dp (m)
- else
- qr (m) = qr (m) + sink
- endif
- endif
- if (qg (k) < qrmin) exit
- enddo
- endif
- enddo
- endif
-
- if (do_sedi_w) then
- 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 (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
-
- if (do_sedi_w) then
- 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
-
- endif
-
-end subroutine terminal_fall
+
+ a4 (2, km) = a4 (1, km)
+ a4 (3, km) = a4 (1, km)
+ a4 (4, km) = 0.
+
+end subroutine cs_profile
! =======================================================================
-! check if water species large enough to fall
+! cubic spline (cs) limiters or boundary conditions
+! a positive-definite constraint (iv = 0) is applied to tracers in every layer,
+! adjusting the top-most and bottom-most interface values to enforce positive.
+! this subroutine is the same as cs_limiters in fv_mapz_mod where iv = 0.
! =======================================================================
-subroutine check_column (ks, ke, q, no_fall)
-
+subroutine cs_limiters (km, a4)
+
implicit none
-
- integer, intent (in) :: ks, ke
- real, intent (in) :: q (ks:ke)
- logical, intent (out) :: no_fall
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: km
+
+ real, intent (inout) :: a4 (4, km) ! ppm array
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: k
-
- no_fall = .true.
-
- do k = ks, ke
- if (q (k) > qrmin) then
- no_fall = .false.
- exit
+
+ real, parameter :: r12 = 1. / 12.
+
+ do k = 1, km
+ if (a4 (1, k) .le. 0.) then
+ a4 (2, k) = a4 (1, k)
+ a4 (3, k) = a4 (1, k)
+ a4 (4, k) = 0.
+ else
+ if (abs (a4 (3, k) - a4 (2, k)) .lt. - a4 (4, k)) then
+ if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + &
+ a4 (4, k) * r12) .lt. 0.) then
+ ! local minimum is negative
+ if (a4 (1, k) .lt. a4 (3, k) .and. a4 (1, k) .lt. a4 (2, k)) then
+ a4 (3, k) = a4 (1, k)
+ a4 (2, k) = a4 (1, k)
+ a4 (4, k) = 0.
+ elseif (a4 (3, k) .gt. a4 (2, k)) then
+ a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k))
+ a4 (3, k) = a4 (2, k) - a4 (4, k)
+ else
+ a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k))
+ a4 (2, k) = a4 (3, k) - a4 (4, k)
+ endif
+ endif
+ endif
endif
enddo
-
-end subroutine check_column
+
+end subroutine cs_limiters
! =======================================================================
-! time - implicit monotonic scheme
-! developed by sj lin, 2016
+! time-implicit monotonic scheme
! =======================================================================
-subroutine implicit_fall (dt, ks, ke, ze, vt, dp, q, precip, m1)
-
+subroutine implicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1)
+
implicit none
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
integer, intent (in) :: ks, ke
- real, intent (in) :: dt
+
+ real, intent (in) :: dts
+
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 (inout) :: precip
+
real, intent (out), dimension (ks:ke) :: m1
- real, intent (out) :: precip
- real, dimension (ks:ke) :: dz, qm, dd
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: k
-
+
+ real, dimension (ks:ke) :: dz, qm, dd
+
do k = ks, ke
dz (k) = ze (k) - ze (k + 1)
- dd (k) = dt * vt (k)
+ dd (k) = dts * vt (k)
q (k) = q (k) * dp (k)
enddo
-
- ! -----------------------------------------------------------------------
- ! sedimentation: non - vectorizable loop
- ! -----------------------------------------------------------------------
-
+
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))
+ qm (k) = (q (k) + qm (k - 1) * dd (k - 1)) / (dz (k) + dd (k))
enddo
-
- ! -----------------------------------------------------------------------
- ! qm is density at this stage
- ! -----------------------------------------------------------------------
-
+
do k = ks, ke
qm (k) = qm (k) * dz (k)
enddo
-
- ! -----------------------------------------------------------------------
- ! output mass fluxes: non - vectorizable loop
- ! -----------------------------------------------------------------------
-
+
m1 (ks) = q (ks) - qm (ks)
do k = ks + 1, ke
m1 (k) = m1 (k - 1) + q (k) - qm (k)
enddo
- precip = m1 (ke)
-
- ! -----------------------------------------------------------------------
- ! update:
- ! -----------------------------------------------------------------------
-
+ precip = precip + m1 (ke)
+
do k = ks, ke
- q (k) = qm (k) / dp (k) !dry dp used inside MP
+ q (k) = qm (k) / dp (k)
enddo
-
+
end subroutine implicit_fall
! =======================================================================
-! lagrangian scheme
-! developed by sj lin, around 2006
+! time-explicit monotonic scheme
! =======================================================================
-subroutine lagrangian_fall_ppm (ks, ke, zs, ze, zt, dp, q, precip, m1, mono)
-
+subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1)
+
implicit none
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
integer, intent (in) :: ks, ke
- real, intent (in) :: zs
- logical, intent (in) :: mono
- real, intent (in), dimension (ks:ke + 1) :: ze, zt
- real, intent (in), dimension (ks:ke) :: dp
-
- ! m1: flux
- real, intent (inout), dimension (ks:ke) :: q, m1
- real, intent (out) :: precip
- real, dimension (ks:ke) :: qm, dz
-
- real :: a4 (4, ks:ke)
- real :: pl, pr, delz, esl
- integer :: k, k0, n, m
- real, parameter :: r3 = 1. / 3., r23 = 2. / 3.
-
+
+ real, intent (in) :: dts
+
+ 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 (inout) :: precip
+
+ real, intent (out), dimension (ks:ke) :: m1
+
! -----------------------------------------------------------------------
- ! density:
+ ! local variables
! -----------------------------------------------------------------------
-
+
+ integer :: n, k, nstep
+
+ real, dimension (ks:ke) :: dz, qm, q0, dd
+
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)
- qm (k) = 0.
+ dz (k) = ze (k) - ze (k + 1)
+ dd (k) = dts * vt (k)
+ q0 (k) = q (k) * dp (k)
+ enddo
+
+ nstep = 1 + int (maxval (dd / dz))
+ do k = ks, ke
+ dd (k) = dd (k) / nstep
+ q (k) = q0 (k)
+ enddo
+
+ do n = 1, nstep
+ qm (ks) = q (ks) - q (ks) * dd (ks) / dz (ks)
+ do k = ks + 1, ke
+ qm (k) = q (k) - q (k) * dd (k) / dz (k) + q (k - 1) * dd (k - 1) / dz (k - 1)
+ enddo
+ q = qm
+ enddo
+
+ m1 (ks) = q0 (ks) - qm (ks)
+ do k = ks + 1, ke
+ m1 (k) = m1 (k - 1) + q0 (k) - qm (k)
enddo
+ precip = precip + m1 (ke)
+
+ do k = ks, ke
+ q (k) = qm (k) / dp (k)
+ enddo
+
+end subroutine explicit_fall
+
+! =======================================================================
+! combine time-implicit monotonic scheme with the piecewise parabolic lagrangian scheme
+! =======================================================================
+subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, &
+ precip, flux, sed_fac)
+
+ implicit none
+
! -----------------------------------------------------------------------
- ! construct vertical profile with zt as coordinate
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1, mono)
-
- 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
- ! entire new grid is within the original grid
- pr = (zt (n) - ze (k + 1)) / dz (n)
- qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - &
- a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2)
- qm (k) = qm (k) * (ze (k) - ze (k + 1))
- k0 = n
- goto 555
- 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 < 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)
- else
- delz = zt (m) - ze (k + 1)
- esl = delz / dz (m)
- qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * &
- (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl)))
- k0 = m
- goto 555
- endif
- enddo
- endif
- goto 555
- endif
- endif
- enddo
- 555 continue
- enddo
-
- m1 (ks) = q (ks) - qm (ks)
- do k = ks + 1, ke
- m1 (k) = m1 (k - 1) + q (k) - qm (k)
- enddo
- 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 = ks, ke
- q (k) = qm (k) / dp (k)
- enddo
-
-end subroutine lagrangian_fall_ppm
-
-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
- real :: pmp_1, lac_1, pmp_2, lac_2
- real :: da1, da2, a6da
-
- integer :: k
-
- logical extm (km)
-
- grat = del (2) / del (1) ! grid ratio
- bet = grat * (grat + 0.5)
- q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet
- gam (1) = (1. + grat * (grat + 1.5)) / bet
-
- do k = 2, km
- d4 = del (k - 1) / del (k)
- bet = 2. + 2. * d4 - gam (k - 1)
- q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet
- gam (k) = d4 / bet
- enddo
-
- a_bot = 1. + d4 * (d4 + 1.5)
- q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) &
- / (d4 * (d4 + 0.5) - a_bot * gam (km))
-
- do k = km, 1, - 1
- q (k) = q (k) - gam (k) * q (k + 1)
- enddo
-
- ! -----------------------------------------------------------------------
- ! apply constraints
- ! -----------------------------------------------------------------------
-
- do k = 2, km
- gam (k) = a4 (1, k) - a4 (1, k - 1)
- enddo
-
- ! -----------------------------------------------------------------------
- ! apply large - scale constraints to all fields if not local max / min
- ! -----------------------------------------------------------------------
-
- ! -----------------------------------------------------------------------
- ! top:
- ! -----------------------------------------------------------------------
-
- q (1) = max (q (1), 0.)
- q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2)))
- q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.)
-
- ! -----------------------------------------------------------------------
- ! interior:
- ! -----------------------------------------------------------------------
-
- do k = 3, km - 1
- if (gam (k - 1) * gam (k + 1) > 0.) then
- q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k)))
- q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k)))
- else
- if (gam (k - 1) > 0.) then
- ! there exists a local max
- q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k)))
- else
- ! there exists a local min
- q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k)))
- q (k) = max (q (k), 0.0)
- endif
- endif
- enddo
-
- ! -----------------------------------------------------------------------
- ! bottom :
- ! -----------------------------------------------------------------------
-
- q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km)))
- q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.)
- ! q (km + 1) = max (q (km + 1), 0.)
-
- ! -----------------------------------------------------------------------
- ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1)
- ! -----------------------------------------------------------------------
-
- do k = 1, km - 1
- a4 (2, k) = q (k)
- a4 (3, k) = q (k + 1)
- enddo
-
- do k = 2, km - 1
- if (gam (k) * gam (k + 1) > 0.0) then
- extm (k) = .false.
- else
- extm (k) = .true.
- endif
- enddo
-
- if (do_mono) then
- do k = 3, km - 2
- if (extm (k)) then
- ! positive definite constraint only if true local extrema
- if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then
- a4 (2, k) = a4 (1, k)
- a4 (3, k) = a4 (1, k)
- endif
- else
- a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k))
- if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then
- ! check within the smooth region if subgrid profile is non - monotonic
- pmp_1 = a4 (1, k) - 2.0 * gam (k + 1)
- lac_1 = pmp_1 + 1.5 * gam (k + 2)
- a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), &
- max (a4 (1, k), pmp_1, lac_1))
- pmp_2 = a4 (1, k) + 2.0 * gam (k)
- lac_2 = pmp_2 - 1.5 * gam (k - 1)
- a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), &
- max (a4 (1, k), pmp_2, lac_2))
- endif
- endif
- enddo
- else
- do k = 3, km - 2
- if (extm (k)) then
- if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then
- a4 (2, k) = a4 (1, k)
- a4 (3, k) = a4 (1, k)
- endif
- endif
- enddo
- endif
-
- do k = 1, km - 1
- a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k))
- enddo
-
- k = km - 1
- if (extm (k)) then
- a4 (2, k) = a4 (1, k)
- a4 (3, k) = a4 (1, k)
- a4 (4, k) = 0.
- else
- da1 = a4 (3, k) - a4 (2, k)
- da2 = da1 ** 2
- a6da = a4 (4, k) * da1
- if (a6da < - da2) then
- a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k))
- a4 (3, k) = a4 (2, k) - a4 (4, k)
- elseif (a6da > da2) then
- a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k))
- a4 (2, k) = a4 (3, k) - a4 (4, k)
- endif
- endif
-
- call cs_limiters (km - 1, a4)
-
- ! -----------------------------------------------------------------------
- ! bottom layer:
- ! -----------------------------------------------------------------------
-
- a4 (2, km) = a4 (1, km)
- a4 (3, km) = a4 (1, km)
- a4 (4, km) = 0.
-
-end subroutine cs_profile
-
-subroutine cs_limiters (km, a4)
-
- implicit none
-
- integer, intent (in) :: km
-
- real, intent (inout) :: a4 (4, km) ! ppm array
-
- real, parameter :: r12 = 1. / 12.
-
- integer :: k
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: zs, dts, sed_fac
+
+ real, intent (in), dimension (ks:ke + 1) :: ze, zt
+
+ real, intent (in), dimension (ks:ke) :: vt, dp
+
+ real, intent (inout), dimension (ks:ke) :: q
+
+ real, intent (inout) :: precip
+
+ real, intent (out), dimension (ks:ke) :: flux
! -----------------------------------------------------------------------
- ! positive definite constraint
+ ! local variables
! -----------------------------------------------------------------------
-
- do k = 1, km
- if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then
- if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then
- if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then
- a4 (3, k) = a4 (1, k)
- a4 (2, k) = a4 (1, k)
- a4 (4, k) = 0.
- elseif (a4 (3, k) > a4 (2, k)) then
- a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k))
- a4 (3, k) = a4 (2, k) - a4 (4, k)
- else
- a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k))
- a4 (2, k) = a4 (3, k) - a4 (4, k)
- endif
- endif
- endif
- enddo
-
-end subroutine cs_limiters
-
+
+ real :: pre0, pre1
+
+ real, dimension (ks:ke) :: q0, q1, m0, m1
+
+ q0 = q
+ pre0 = precip
+
+ call implicit_fall (dts, ks, ke, ze, vt, dp, q0, pre0, m0)
+
+ q1 = q
+ pre1 = precip
+
+ call lagrangian_fall (ks, ke, zs, ze, zt, dp, q1, pre1, m1)
+
+ q = q0 * sed_fac + q1 * (1.0 - sed_fac)
+ flux = m0 * sed_fac + m1 * (1.0 - sed_fac)
+ precip = pre0 * sed_fac + pre1 * (1.0 - sed_fac)
+
+end subroutine implicit_lagrangian_fall
+
! =======================================================================
-! calculation of vertical fall speed
+! vertical subgrid variability used for cloud ice and cloud water autoconversion
+! edges: qe == qbar + / - dm
! =======================================================================
-subroutine fall_speed (ks, ke, den, qs, qi, qg, ql, tk, vts, vti, vtg)
-
+subroutine linear_prof (km, q, dm, z_var, h_var)
+
implicit none
-
- integer, intent (in) :: ks, ke
-
- 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:
-
- real, parameter :: thi = 1.0e-8 ! cloud ice threshold for terminal fall
- real, parameter :: thg = 1.0e-8
- real, parameter :: ths = 1.0e-8
-
- real, parameter :: aa = - 4.14122e-5
- real, parameter :: bb = - 0.00538922
- real, parameter :: cc = - 0.0516344
- real, parameter :: dd = 0.00216078
- real, parameter :: ee = 1.9714
-
- ! marshall - palmer constants
-
- real, parameter :: vcons = 6.6280504
- real, parameter :: vcong = 87.2382675
- 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 ! 115233618.533674
-
- real, dimension (ks:ke) :: qden, tc, rhof
-
- real :: vi0
-
- integer :: k
-
- ! -----------------------------------------------------------------------
- ! marshall - palmer formula
- ! -----------------------------------------------------------------------
-
+
! -----------------------------------------------------------------------
- ! try the local air density -- for global model; the true value could be
- ! much smaller than sfcrho over high mountains
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- do k = ks, ke
- rhof (k) = sqrt (min (10., sfcrho / den (k)))
- enddo
-
+
+ integer, intent (in) :: km
+
+ logical, intent (in) :: z_var
+
+ real, intent (in) :: q (km), h_var
+
+ real, intent (out) :: dm (km)
+
! -----------------------------------------------------------------------
- ! ice:
+ ! local variables
! -----------------------------------------------------------------------
-
- if (const_vi) then
- vti (:) = vi_fac
- else
+
+ integer :: k
+
+ real :: dq (km)
+
+ if (z_var) then
+ do k = 2, km
+ dq (k) = 0.5 * (q (k) - q (k - 1))
+ enddo
+ dm (1) = 0.
! -----------------------------------------------------------------------
- ! use deng and mace (2008, grl), which gives smaller fall speed than hd90 formula
+ ! use twice the strength of the positive definiteness limiter (Lin et al. 1994)
! -----------------------------------------------------------------------
- vi0 = 0.01 * vi_fac
- 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
- if (hd_icefall) then
- ! heymsfield and donner, 1990, jas
- vti (k) = vi_fac * 3.29 * (qi (k) * den (k)) ** 0.16
+ do k = 2, km - 1
+ dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k))
+ if (dq (k) * dq (k + 1) .le. 0.) then
+ if (dq (k) .gt. 0.) then
+ dm (k) = min (dm (k), dq (k), - dq (k + 1))
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))
+ dm (k) = 0.
endif
- vti (k) = min (vi_max, max (vf_min, vti (k)))
- endif
- enddo
- endif
-
- ! -----------------------------------------------------------------------
- ! snow:
- ! -----------------------------------------------------------------------
-
- if (const_vs) then
- vts (:) = vs_fac ! 1. ifs_2016
- else
- do k = ks, ke
- if (qs (k) < ths) then
- vts (k) = vf_min
- else
- vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms))
- vts (k) = min (vs_max, max (vf_min, vts (k)))
endif
enddo
- endif
-
- ! -----------------------------------------------------------------------
- ! graupel:
- ! -----------------------------------------------------------------------
-
- if (const_vg) then
- vtg (:) = vg_fac ! 2.
- else
- if (do_hail) then
- do k = ks, ke
- if (qg (k) < thg) then
- vtg (k) = vf_min
- else
- vtg (k) = vg_fac * vconh * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normh)))
- vtg (k) = min (vg_max, max (vf_min, vtg (k)))
- endif
- enddo
- else
- do k = ks, ke
- if (qg (k) < thg) then
- vtg (k) = vf_min
- else
- vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg)))
- vtg (k) = min (vg_max, max (vf_min, vtg (k)))
- endif
- enddo
- endif
- endif
-
-end subroutine fall_speed
-
-! =======================================================================
-! setup gfdl cloud microphysics parameters
-! =======================================================================
-
-subroutine setupm
-
- implicit none
-
- real :: gcon, cd, scm3, pisq, act (8)
- real :: vdifu, tcond
- real :: visk
- real :: ch2o, hltf
- real :: hlts, hltc, ri50
-
- real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, &
- gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, &
- gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, &
- gam625 = 184.860962, gam680 = 496.604067
-
- real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /)
-
- real den_rc
-
- integer :: i, k
-
- pie = 4. * atan (1.0)
-
- ! s. klein's formular (eq 16) from am2
-
- fac_rc = (4. / 3.) * pie * rhor * rthresh ** 3
-
- if (prog_ccn) then
- ! if (master) write (*, *) 'prog_ccn option is .t.'
- else
- den_rc = fac_rc * ccn_o * 1.e6
- ! if (master) write (*, *) 'mp: for ccn_o = ', ccn_o, 'ql_rc = ', den_rc
- den_rc = fac_rc * ccn_l * 1.e6
- ! if (master) write (*, *) 'mp: for ccn_l = ', ccn_l, 'ql_rc = ', den_rc
- endif
-
- vdifu = 2.11e-5
- tcond = 2.36e-2
-
- visk = 1.259e-5
- hlts = hlv + hlf
- hltc = hlv
- hltf = hlf
-
- ch2o = c_liq
- ri50 = 1.e-4
-
- pisq = pie * pie
- scm3 = (visk / vdifu) ** (1. / 3.)
-
- cracs = pisq * rnzr * rnzs * rhos
- csacr = pisq * rnzr * rnzs * rhor
- if (do_hail) then
- cgacr = pisq * rnzr * rnzh * rhor
- cgacs = pisq * rnzh * rnzs * rhos
- else
- cgacr = pisq * rnzr * rnzg * rhor
- cgacs = pisq * rnzg * rnzs * rhos
- endif
- cgacs = cgacs * c_pgacs
-
- ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ;
- ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g)
-
- act (1) = pie * rnzs * rhos
- act (2) = pie * rnzr * rhor
- if (do_hail) then
- act (6) = pie * rnzh * rhoh
- else
- act (6) = pie * rnzg * rhog
- endif
- act (3) = act (2)
- act (4) = act (1)
- act (5) = act (2)
- act (7) = act (1)
- act (8) = act (6)
-
- do i = 1, 3
- do k = 1, 4
- acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25))
+ dm (km) = 0.
+ ! -----------------------------------------------------------------------
+ ! impose a presumed background horizontal variability that is proportional to the value itself
+ ! -----------------------------------------------------------------------
+ do k = 1, km
+ dm (k) = max (dm (k), 0.0, h_var * q (k))
enddo
- enddo
-
- gcon = 40.74 * sqrt (sfcrho) ! 44.628
-
- csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125)
- ! decreasing csacw to reduce cloud water --- > snow
-
- craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95)
- csaci = csacw * c_psaci
-
- if (do_hail) then
- cgacw = pie * rnzh * gam350 * gcon / (4. * act (6) ** 0.875)
- else
- cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875)
- endif
- ! cgaci = cgacw * 0.1
-
- ! sjl, may 28, 2012
- cgaci = cgacw * 0.05
- ! sjl, may 28, 2012
-
- cracw = craci ! cracw = 3.27206196043822
- cracw = c_cracw * cracw
-
- ! subl and revp: five constants for three separate processes
-
- cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs
- if (do_hail) then
- cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzh
- else
- cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg
- endif
- crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr
- cssub (2) = 0.78 / sqrt (act (1))
- cgsub (2) = 0.78 / sqrt (act (6))
- crevp (2) = 0.78 / sqrt (act (2))
- cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625
- cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875
- crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725
- cssub (4) = tcond * rvgas
- cssub (5) = hlts ** 2 * vdifu
- cgsub (4) = cssub (4)
- crevp (4) = cssub (4)
- cgsub (5) = cssub (5)
- crevp (5) = hltc ** 2 * vdifu
-
- cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75
- cgfr (2) = 0.66
-
- ! smlt: five constants (lin et al. 1983)
-
- csmlt (1) = 2. * pie * tcond * rnzs / hltf
- csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf
- csmlt (3) = cssub (2)
- csmlt (4) = cssub (3)
- csmlt (5) = ch2o / hltf
-
- ! gmlt: five constants
-
- if (do_hail) then
- cgmlt (1) = 2. * pie * tcond * rnzh / hltf
- cgmlt (2) = 2. * pie * vdifu * rnzh * hltc / hltf
- else
- cgmlt (1) = 2. * pie * tcond * rnzg / hltf
- cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf
- endif
- cgmlt (3) = cgsub (2)
- cgmlt (4) = cgsub (3)
- cgmlt (5) = ch2o / hltf
-
- es0 = e00
- ces0 = eps * es0
-
-end subroutine setupm
-
-! =======================================================================
-! initialization of gfdl cloud microphysics
-! =======================================================================
-
-subroutine gfdl_mp_init (input_nml_file, logunit)
-
- implicit none
-
- character (len = *), intent (in) :: input_nml_file (:)
- integer, intent (in) :: logunit
-
- logical :: exists
-
- read (input_nml_file, nml = gfdl_mp_nml)
-
- ! write version number and namelist to log file
- write (logunit, *) " ================================================================== "
- write (logunit, *) "gfdl_mp_mod"
- write (logunit, nml = gfdl_mp_nml)
-
- if (do_setup) then
- call setup_con
- call setupm
- do_setup = .false.
- endif
-
- g2 = 0.5 * grav
- log_10 = log (10.)
-
- 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_mp_init
-
-! =======================================================================
-! end of gfdl cloud microphysics
-! =======================================================================
-
-subroutine gfdl_mp_end
-
- implicit none
-
- deallocate (table)
- deallocate (table2)
- deallocate (table3)
- deallocate (tablew)
- deallocate (des)
- deallocate (des2)
- deallocate (des3)
- deallocate (desw)
-
- tables_are_initialized = .false.
-
-end subroutine gfdl_mp_end
-
-! =======================================================================
-! qsmith table initialization
-! =======================================================================
-
-subroutine setup_con
-
- implicit none
-
- ! master = (mpp_pe () .eq.mpp_root_pe ())
-
- if (.not. qsmith_tables_initialized) call qsmith_init
-
- qsmith_tables_initialized = .true.
-
-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))
+ do k = 1, km
+ dm (k) = max (0.0, h_var * q (k))
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
+
+end subroutine linear_prof
! =======================================================================
-! compute the saturated specific humidity for table ii
+! accretion function, Lin et al. (1983)
! =======================================================================
-real function wqs1 (ta, den)
-
+function acr2d (qden, c, denfac, blin, mu)
+
implicit none
+
+ real :: acr2d
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: qden, c, denfac, blin, mu
+
+ acr2d = denfac * c * exp ((2 + mu + blin) / (mu + 3) * log (6 * qden))
+
+end function acr2d
- ! pure water phase; universal dry / moist formular using air density
- ! input "den" can be either dry or moist air density
+! =======================================================================
+! accretion function, Lin et al. (1983)
+! =======================================================================
- real, intent (in) :: ta, den
+function acr3d (v1, v2, q1, q2, c, acco, acc1, acc2, den)
+
+ implicit none
+
+ real :: acr3d
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: v1, v2, c, den, q1, q2, acco (3), acc1, acc2
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i
+
+ real :: t1, t2, tmp, vdiff
+
+ t1 = exp (1. / (acc1 + 3) * log (6 * q1 * den))
+ t2 = exp (1. / (acc2 + 3) * log (6 * q2 * den))
+
+ if (vdiffflag .eq. 1) vdiff = abs (v1 - v2)
+ if (vdiffflag .eq. 2) vdiff = sqrt ((1.20 * v1 - 0.95 * v2) ** 2. + 0.08 * v1 * v2)
+ if (vdiffflag .eq. 3) vdiff = sqrt ((1.00 * v1 - 1.00 * v2) ** 2. + 0.04 * v1 * v2)
+
+ acr3d = c * vdiff / den
+
+ tmp = 0
+ do i = 1, 3
+ tmp = tmp + acco (i) * exp ((6 + acc1 - i) * log (t1)) * exp ((acc2 + i - 1) * log (t2))
+ enddo
+
+ acr3d = acr3d * tmp
+
+end function acr3d
- real :: es, ap1, tmin
+! =======================================================================
+! ventilation coefficient, Lin et al. (1983)
+! =======================================================================
- integer :: it
+function vent_coeff (qden, c1, c2, denfac, blin, mu)
+
+ implicit none
+
+ real :: vent_coeff
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: qden, c1, c2, denfac, blin, mu
+
+ vent_coeff = c1 + c2 * exp ((3 + 2 * mu + blin) / (mu + 3) / 2 * log (6 * qden)) * &
+ sqrt (denfac) / exp ((1 + mu) / (mu + 3) * log (6 * qden))
+
+end function vent_coeff
- 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)
+! =======================================================================
+! sublimation or evaporation function, Lin et al. (1983)
+! =======================================================================
-end function wqs1
+function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm)
+
+ implicit none
+
+ real :: psub
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: t2, dq, qden, qsat, c (5), den, denfac, blin, cpk, mu
+
+ real (kind = r8), intent (in) :: cvm
+
+ psub = c (1) * t2 * dq * exp ((1 + mu) / (mu + 3) * log (6 * qden)) * &
+ vent_coeff (qden, c (2), c (3), denfac, blin, mu) / &
+ (c (4) * t2 + c (5) * (cpk * cvm) ** 2 * qsat * den)
+
+end function psub
! =======================================================================
-! compute the gradient of saturated specific humidity for table ii
+! melting function, Lin et al. (1983)
! =======================================================================
-real function wqs2 (ta, den, dqdt)
-
+function pmlt (tc, dq, qden, pxacw, pxacr, c, den, denfac, blin, mu, lcpk, icpk, cvm)
+
implicit none
+
+ real :: pmlt
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tc, dq, qden, pxacw, pxacr, c (4), den, denfac, blin, lcpk, icpk, mu
+
+ real (kind = r8), intent (in) :: cvm
+
+ pmlt = (c (1) / (icpk * cvm) * tc / den - c (2) * lcpk / icpk * dq) * &
+ exp ((1 + mu) / (mu + 3) * log (6 * qden)) * &
+ vent_coeff (qden, c (3), c (4), denfac, blin, mu) + &
+ c_liq / (icpk * cvm) * tc * (pxacw + pxacr)
+
+end function pmlt
- ! pure water phase; universal dry / moist formular using air density
- ! input "den" can be either dry or moist air density
+! =======================================================================
+! sedimentation of horizontal momentum
+! =======================================================================
- real, intent (in) :: ta, den
- real, intent (out) :: dqdt
- real :: es, ap1, tmin
- integer :: it
+subroutine sedi_uv (ks, ke, m1, dp, u, v)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in), dimension (ks:ke) :: m1, dp
+
+ real, intent (inout), dimension (ks:ke) :: u, v
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ do k = ks + 1, ke
+ u (k) = (dp (k) * u (k) + m1 (k - 1) * u (k - 1)) / (dp (k) + m1 (k - 1))
+ v (k) = (dp (k) * v (k) + m1 (k - 1) * v (k - 1)) / (dp (k) + m1 (k - 1))
+ enddo
+
+end subroutine sedi_uv
- tmin = table_ice - 160.
+! =======================================================================
+! sedimentation of vertical momentum
+! =======================================================================
- if (.not. tables_are_initialized) call qsmith_init
+subroutine sedi_w (ks, ke, m1, w, vt, dm)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in), dimension (ks:ke) :: m1, vt, dm
+
+ real, intent (inout), dimension (ks:ke) :: w
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ w (ks) = w (ks) + m1 (ks) * vt (ks) / dm (ks)
+ do k = ks + 1, ke
+ w (k) = (dm (k) * w (k) + m1 (k - 1) * (w (k - 1) - vt (k - 1)) + m1 (k) * vt (k)) / &
+ (dm (k) + m1 (k - 1))
+ enddo
+
+end subroutine sedi_w
- 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)
+! =======================================================================
+! sedimentation of heat
+! =======================================================================
-end function wqs2
+subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: cw
+
+ real, intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real, dimension (ks:ke) :: dgz, cv0
+
+ do k = ks + 1, ke
+ dgz (k) = - 0.5 * grav * (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))
+ enddo
+
+ 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
! =======================================================================
-! compute the gradient of saturated specific humidity for table ii
-! it is the same as "wqs2", but written as vector function
+! fast saturation adjustments
! =======================================================================
-subroutine wqs2_vect (is, ie, ta, den, wqsat, dqdt)
-
+subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, &
+ adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, &
+ pt, delp, q_con, cappa, gsize, last_step, condensation, &
+ evaporation, deposition, sublimation, do_sat_adj)
+
implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: is, ie, ks, ke
+
+ logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj
+
+ real, intent (in) :: dtm
+
+ real, intent (in), dimension (is:ie) :: hs, gsize
+
+ real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni
+
+ real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, te
+ real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
+
+ real, intent (inout), dimension (is:, ks:) :: q_con, cappa
+
+ real, intent (inout), dimension (is:ie) :: condensation, deposition
+ real, intent (inout), dimension (is:ie) :: evaporation, sublimation
+
+ real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr
- ! 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 (kind = r8), intent (out), dimension (is:ie) :: dte
- real, intent (in), dimension (is:ie) :: ta, den
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real, dimension (is:ie, ks:ke) :: ua, va, wa, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
+
+ real, dimension (is:ie) :: water, rain, ice, snow, graupel
+
+ real, dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw
+ real, dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi
+ real, dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr
+ real, dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs
+ real, dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg
- real, intent (out), dimension (is:ie) :: wqsat, dqdt
+ ! -----------------------------------------------------------------------
+ ! initialization
+ ! -----------------------------------------------------------------------
+
+ ua = 0.0
+ va = 0.0
+ wa = 0.0
+
+ water = 0.0
+ rain = 0.0
+ ice = 0.0
+ snow = 0.0
+ graupel = 0.0
+
+ prefluxw = 0.0
+ prefluxr = 0.0
+ prefluxi = 0.0
+ prefluxs = 0.0
+ prefluxg = 0.0
+
+ ! -----------------------------------------------------------------------
+ ! major cloud microphysics driver
+ ! -----------------------------------------------------------------------
+
+ call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, &
+ qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, &
+ gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, &
+ pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, &
+ pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, &
+ prefluxs, prefluxg, condensation, deposition, evaporation, sublimation, &
+ last_step, .true., do_sat_adj, .false.)
+
+end subroutine fast_sat_adj
- real :: es, ap1, tmin
+! =======================================================================
+! rain freezing to form graupel, simple version
+! =======================================================================
- integer :: i, it
+subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
+ lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, sink, fac_r2g
+
+ fac_r2g = 1. - exp (- dts / tau_r2g)
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .lt. 0. .and. qr (k) .gt. qcmin) then
+
+ sink = (- tc * 0.025) ** 2 * qr (k)
+ sink = min (qr (k), sink, - fac_r2g * tc / icpk (k))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
+ enddo
+
+end subroutine pgfr_simp
- tmin = t_ice - 160.
+! =======================================================================
+! snow melting to form cloud water and rain, simple version
+! =======================================================================
- 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))
+subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
+ lcpk, icpk, tcpk, tcp3)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: te8
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+ real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, tmp, sink, fac_smlt
+
+ fac_smlt = 1. - exp (- dts / tau_smlt)
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ if (tc .ge. 0. .and. qs (k) .gt. qcmin) then
+
+ sink = (tc * 0.1) ** 2 * qs (k)
+ sink = min (qs (k), sink, fac_smlt * tc / icpk (k))
+ tmp = min (sink, dim (qs_mlt, ql (k)))
+
+ call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), &
+ lcpk (k), icpk (k), tcpk (k), tcp3 (k))
+
+ endif
+
enddo
-
-end subroutine wqs2_vect
+
+end subroutine psmlt_simp
! =======================================================================
-! compute wet buld temperature
+! cloud water to rain autoconversion, simple version
! =======================================================================
-real function wet_bulb (q, t, den)
-
+subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg)
+
implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, sink, fac_l2r
+
+ fac_l2r = 1. - exp (- dts / tau_l2r)
+
+ do k = ks, ke
+
+ tc = tz (k) - t_wfr
+
+ if (tc .gt. 0 .and. ql (k) .gt. ql0_max) then
+
+ sink = fac_l2r * (ql (k) - ql0_max)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., - sink, sink, 0., 0., 0.)
+
+ endif
+
+ enddo
- real, intent (in) :: t, q, den
+end subroutine praut_simp
+
+! =======================================================================
+! cloud ice to snow autoconversion, simple version
+! =======================================================================
- real :: qs, tp, dqdt
+subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in) :: dts
+
+ real, intent (in), dimension (ks:ke) :: den
+
+ real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (inout), dimension (ks:ke) :: tz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: tc, sink, fac_i2s, qim
+
+ fac_i2s = 1. - exp (- dts / tau_i2s)
+
+ do k = ks, ke
+
+ tc = tz (k) - tice
+
+ qim = qi0_max / den (k)
+
+ if (tc .lt. 0. .and. qi (k) .gt. qim) then
+
+ sink = fac_i2s * (qi (k) - qim)
+
+ call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), &
+ 0., 0., 0., - sink, sink, 0.)
+
+ endif
+
+ enddo
+
+end subroutine psaut_simp
- wet_bulb = t
- qs = wqs2 (wet_bulb, den, dqdt)
- tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp
- wet_bulb = wet_bulb - tp
+! =======================================================================
+! cloud radii diagnosis built for gfdl cloud microphysics
+! =======================================================================
- ! 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
+subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, &
+ qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, cld, cloud, snowd, &
+ cnvw, cnvi, cnvc)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: is, ie, ks, ke
+
+ real, intent (in), dimension (is:ie) :: lsm, snowd
+
+ real, intent (in), dimension (is:ie, ks:ke) :: delp, t, p, cloud
+ real, intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa
+
+ real, intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi, cnvc
+
+ real, intent (inout), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg
+ real, intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg
+ real, intent (inout), dimension (is:ie, ks:ke) :: cld
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, k, ind
+
+ real, dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg
+
+ real :: dpg, rho, ccnw, mask, cor, tc, bw
+ real :: lambdaw, lambdar, lambdai, lambdas, lambdag, rei_fac
+
+ real :: retab (138) = (/ &
+ 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, &
+ 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, &
+ 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, &
+ 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, &
+ 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, &
+ 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, &
+ 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, &
+ 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
+ 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
+ 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
+ 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
+ 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
+ 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
+ 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
+ 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
+ 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
+ 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
+ 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
+ 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
+ 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
+ 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
+ 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
+ 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /)
+
+ qmw = qw
+ qmi = qi
+ qmr = qr
+ qms = qs
+ qmg = qg
+ cld = cloud
+
+ ! -----------------------------------------------------------------------
+ ! merge convective cloud to total cloud
+ ! -----------------------------------------------------------------------
+
+ if (present (cnvw)) then
+ qmw = qmw + cnvw
+ endif
+ if (present (cnvi)) then
+ qmi = qmi + cnvi
endif
+ if (present (cnvc)) then
+ cld = cnvc + (1 - cnvc) * cld
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! combine liquid and solid phases
+ ! -----------------------------------------------------------------------
+
+ if (liq_ice_combine) then
+ do i = is, ie
+ do k = ks, ke
+ 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
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! combine snow and graupel
+ ! -----------------------------------------------------------------------
+
+ if (snow_grauple_combine) then
+ do i = is, ie
+ do k = ks, ke
+ qms (i, k) = qms (i, k) + qmg (i, k)
+ qmg (i, k) = 0.0
+ enddo
+ enddo
+ endif
+
+
+ do i = is, ie
-end function wet_bulb
+ do k = ks, ke
+
+ qmw (i, k) = max (qmw (i, k), qcmin)
+ qmi (i, k) = max (qmi (i, k), qcmin)
+ qmr (i, k) = max (qmr (i, k), qcmin)
+ qms (i, k) = max (qms (i, k), qcmin)
+ qmg (i, k) = max (qmg (i, k), qcmin)
+
+ cld (i, k) = min (max (cld (i, k), 0.0), 1.0)
+
+ mask = min (max (lsm (i), 0.0), 2.0)
+
+ dpg = abs (delp (i, k)) / grav
+ rho = p (i, k) / (rdgas * t (i, k) * (1. + zvir * qv (i, k)))
+
+ tc = t (i, k) - tice
+
+ if (rewflag .eq. 1) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud water (Martin et al. 1994)
+ ! -----------------------------------------------------------------------
+
+ if (prog_ccn) then
+ ! boucher and lohmann (1995)
+ ccnw = (1.0 - abs (mask - 1.0)) * &
+ (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + &
+ abs (mask - 1.0) * &
+ (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48)
+ else
+ ccnw = ccn_o * abs (mask - 1.0) + ccn_l * (1.0 - abs (mask - 1.0))
+ endif
+
+ if (qmw (i, k) .gt. qcmin) then
+ qcw (i, k) = dpg * qmw (i, k) * 1.0e3
+ 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
+ rew (i, k) = rewmin
+ endif
+
+ endif
+
+ if (rewflag .eq. 2) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud water (Martin et al. 1994, gfdl revision)
+ ! -----------------------------------------------------------------------
+
+ if (prog_ccn) then
+ ! boucher and lohmann (1995)
+ ccnw = (1.0 - abs (mask - 1.0)) * &
+ (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + &
+ abs (mask - 1.0) * &
+ (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48)
+ else
+ ccnw = 1.077 * ccn_o * abs (mask - 1.0) + 1.143 * ccn_l * (1.0 - abs (mask - 1.0))
+ endif
+
+ if (qmw (i, k) .gt. qcmin) then
+ qcw (i, k) = dpg * qmw (i, k) * 1.0e3
+ 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
+ rew (i, k) = rewmin
+ endif
+
+ endif
+
+ if (rewflag .eq. 3) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud water (Kiehl et al. 1994)
+ ! -----------------------------------------------------------------------
+
+ if (qmw (i, k) .gt. qcmin) then
+ qcw (i, k) = dpg * qmw (i, k) * 1.0e3
+ rew (i, k) = 14.0 * abs (mask - 1.0) + &
+ (8.0 + (14.0 - 8.0) * min (1.0, max (0.0, - tc / 30.0))) * &
+ (1.0 - abs (mask - 1.0))
+ rew (i, k) = rew (i, k) + (14.0 - rew (i, k)) * &
+ min (1.0, max (0.0, snowd (i) / 1000.0))
+ rew (i, k) = max (rewmin, min (rewmax, rew (i, k)))
+ else
+ qcw (i, k) = 0.0
+ rew (i, k) = rewmin
+ endif
+
+ endif
+
+ if (rewflag .eq. 4) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud water derived from PSD
+ ! -----------------------------------------------------------------------
+
+ if (qmw (i, k) .gt. qcmin) then
+ qcw (i, k) = dpg * qmw (i, k) * 1.0e3
+ call cal_pc_ed_oe_rr_tv (qmw (i, k), rho, blinw, muw, &
+ eda = edaw, edb = edbw, ed = rew (i, k))
+ rew (i, k) = rewfac * 0.5 * rew (i, k) * 1.0e6
+ rew (i, k) = max (rewmin, min (rewmax, rew (i, k)))
+ else
+ qcw (i, k) = 0.0
+ rew (i, k) = rewmin
+ endif
+
+ endif
+
+ if (reiflag .eq. 1) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice (Heymsfield and Mcfarquhar 1996)
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ rei_fac = log (1.0e3 * qmi (i, k) * rho)
+ if (tc .lt. - 50) then
+ rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3
+ elseif (tc .lt. - 40) then
+ rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3
+ elseif (tc .lt. - 30) then
+ rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3
+ else
+ rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3
+ endif
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (reiflag .eq. 2) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice (Donner et al. 1997)
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ if (tc .le. - 55) then
+ rei (i, k) = 15.41627
+ elseif (tc .le. - 50) then
+ rei (i, k) = 16.60895
+ elseif (tc .le. - 45) then
+ rei (i, k) = 32.89967
+ elseif (tc .le. - 40) then
+ rei (i, k) = 35.29989
+ elseif (tc .le. - 35) then
+ rei (i, k) = 55.65818
+ elseif (tc .le. - 30) then
+ rei (i, k) = 85.19071
+ elseif (tc .le. - 25) then
+ rei (i, k) = 72.35392
+ else
+ rei (i, k) = 92.46298
+ endif
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (reiflag .eq. 3) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice (Fu 2007)
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ rei (i, k) = 47.05 + tc * (0.6624 + 0.001741 * tc)
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (reiflag .eq. 4) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice (Kristjansson et al. 2000)
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ ind = min (max (int (t (i, k) - 136.0), 44), 138 - 1)
+ cor = t (i, k) - int (t (i, k))
+ rei (i, k) = retab (ind) * (1. - cor) + retab (ind + 1) * cor
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (reiflag .eq. 5) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice (Wyser 1998)
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / 50.e-3) * &
+ exp (1.5 * log (max (1.e-10, - tc)))
+ rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw))
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (reiflag .eq. 6) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice (Sun and Rikus 1999, Sun 2001)
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ rei_fac = log (1.0e3 * qmi (i, k) * rho)
+ rei (i, k) = 45.8966 * exp (0.2214 * rei_fac) + &
+ 0.7957 * exp (0.2535 * rei_fac) * (tc + 190.0)
+ rei (i, k) = (1.2351 + 0.0105 * tc) * rei (i, k)
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (reiflag .eq. 7) then
+
+ ! -----------------------------------------------------------------------
+ ! cloud ice derived from PSD
+ ! -----------------------------------------------------------------------
+
+ if (qmi (i, k) .gt. qcmin) then
+ qci (i, k) = dpg * qmi (i, k) * 1.0e3
+ call cal_pc_ed_oe_rr_tv (qmi (i, k), rho, blini, mui, &
+ eda = edai, edb = edbi, ed = rei (i, k))
+ rei (i, k) = reifac * 0.5 * rei (i, k) * 1.0e6
+ rei (i, k) = max (reimin, min (reimax, rei (i, k)))
+ else
+ qci (i, k) = 0.0
+ rei (i, k) = reimin
+ endif
+
+ endif
+
+ if (rerflag .eq. 1) then
+
+ ! -----------------------------------------------------------------------
+ ! rain derived from PSD
+ ! -----------------------------------------------------------------------
+
+ if (qmr (i, k) .gt. qcmin) then
+ qcr (i, k) = dpg * qmr (i, k) * 1.0e3
+ call cal_pc_ed_oe_rr_tv (qmr (i, k), rho, blinr, mur, &
+ eda = edar, edb = edbr, ed = rer (i, k))
+ rer (i, k) = 0.5 * rer (i, k) * 1.0e6
+ rer (i, k) = max (rermin, min (rermax, rer (i, k)))
+ else
+ qcr (i, k) = 0.0
+ rer (i, k) = rermin
+ endif
+
+ endif
+
+ if (resflag .eq. 1) then
+
+ ! -----------------------------------------------------------------------
+ ! snow derived from PSD
+ ! -----------------------------------------------------------------------
+
+ if (qms (i, k) .gt. qcmin) then
+ qcs (i, k) = dpg * qms (i, k) * 1.0e3
+ call cal_pc_ed_oe_rr_tv (qms (i, k), rho, blins, mus, &
+ eda = edas, edb = edbs, ed = res (i, k))
+ res (i, k) = 0.5 * res (i, k) * 1.0e6
+ res (i, k) = max (resmin, min (resmax, res (i, k)))
+ else
+ qcs (i, k) = 0.0
+ res (i, k) = resmin
+ endif
+
+ endif
+
+ if (regflag .eq. 1) then
+
+ ! -----------------------------------------------------------------------
+ ! graupel derived from PSD
+ ! -----------------------------------------------------------------------
+
+ if (qmg (i, k) .gt. qcmin) then
+ qcg (i, k) = dpg * qmg (i, k) * 1.0e3
+ if (do_hail) then
+ call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, blinh, muh, &
+ eda = edah, edb = edbh, ed = reg (i, k))
+ else
+ call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, bling, mug, &
+ eda = edag, edb = edbg, ed = reg (i, k))
+ endif
+ reg (i, k) = 0.5 * reg (i, k) * 1.0e6
+ reg (i, k) = max (regmin, min (regmax, reg (i, k)))
+ else
+ qcg (i, k) = 0.0
+ reg (i, k) = regmin
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+end subroutine cld_eff_rad
! =======================================================================
-! compute the saturated specific humidity for table iii
+! radar reflectivity
! =======================================================================
-real function iqs1 (ta, den)
-
+subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, &
+ delz, dbz, maxdbz, allmax, npz, ncnst, hydrostatic, zvir, &
+ do_inline_mp, sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top)
+
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
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ logical, intent (in) :: hydrostatic, do_inline_mp
+
+ integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed
+ integer, intent (in) :: npz, ncnst, mp_top
+ integer, intent (in) :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel
+
+ real, intent (in) :: zvir
+
+ real, intent (in), dimension (is:, js:, 1:) :: delz
+
+ real, intent (in), dimension (isd:ied, jsd:jed, npz) :: pt, delp
+
+ real, intent (in), dimension (isd:ied, jsd:jed, npz, ncnst) :: q
+
+ real, intent (in), dimension (is:ie, npz + 1, js:je) :: peln
+
+ real, intent (out) :: allmax
+
+ real, intent (out), dimension (is:ie, js:je) :: maxdbz
+
+ real, intent (out), dimension (is:ie, js:je, npz) :: dbz
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, j, k
+
+ real, parameter :: alpha = 0.224, mp_const = 200 * exp (1.6 * log (3.6e6))
+
+ real (kind = r8) :: qden, z_e
+ real :: fac_r, fac_s, fac_g
+
+ real, dimension (npz) :: den, denfac, qmr, qms, qmg, vtr, vts, vtg
+
+ ! -----------------------------------------------------------------------
+ ! return if the microphysics scheme doesn't include rain
+ ! -----------------------------------------------------------------------
+
+ if (rainwat .lt. 1) return
+
+ ! -----------------------------------------------------------------------
+ ! initialization
+ ! -----------------------------------------------------------------------
+
+ dbz = - 20.
+ maxdbz = - 20.
+ allmax = - 20.
+
+ ! -----------------------------------------------------------------------
+ ! calculate radar reflectivity
+ ! -----------------------------------------------------------------------
+
+ do j = js, je
+ do i = is, ie
+
+ ! -----------------------------------------------------------------------
+ ! air density
+ ! -----------------------------------------------------------------------
+
+ do k = 1, npz
+ if (hydrostatic) then
+ den (k) = 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)))
+ else
+ den (k) = - delp (i, j, k) / (grav * delz (i, j, k))
+ endif
+ qmr (k) = max (qcmin, q (i, j, k, rainwat))
+ qms (k) = max (qcmin, q (i, j, k, snowwat))
+ qmg (k) = max (qcmin, q (i, j, k, graupel))
+ enddo
+
+ do k = 1, npz
+ denfac (k) = sqrt (den (npz) / den (k))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! fall speed
+ ! -----------------------------------------------------------------------
+
+ if (radr_flag .eq. 3) then
+ call term_rsg (1, npz, qmr, den, denfac, vr_fac, blinr, &
+ mur, tvar, tvbr, vr_max, const_vr, vtr)
+ vtr = vtr / rhor
+ endif
+
+ if (rads_flag .eq. 3) then
+ call term_rsg (1, npz, qms, den, denfac, vs_fac, blins, &
+ mus, tvas, tvbs, vs_max, const_vs, vts)
+ vts = vts / rhos
+ endif
+
+ if (radg_flag .eq. 3) then
+ if (do_hail .and. .not. do_inline_mp) then
+ call term_rsg (1, npz, qmg, den, denfac, vg_fac, blinh, &
+ muh, tvah, tvbh, vg_max, const_vg, vtg)
+ vtg = vtg / rhoh
+ else
+ call term_rsg (1, npz, qmg, den, denfac, vg_fac, bling, &
+ mug, tvag, tvbg, vg_max, const_vg, vtg)
+ vtg = vtg / rhog
+ endif
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! radar reflectivity
+ ! -----------------------------------------------------------------------
+
+ do k = mp_top + 1, npz
+ z_e = 0.
+
+ if (rainwat .gt. 0) then
+ qden = den (k) * qmr (k)
+ if (qmr (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qmr (k), den (k), blinr, mur, &
+ rra = rrar, rrb = rrbr, rr = fac_r)
+ else
+ fac_r = 0.0
+ endif
+ if (radr_flag .eq. 1 .or. radr_flag .eq. 2) then
+ z_e = z_e + fac_r * 1.e18
+ endif
+ if (radr_flag .eq. 3) then
+ z_e = z_e + mp_const * exp (1.6 * log (qden * vtr (k)))
+ endif
+ endif
+
+ if (snowwat .gt. 0) then
+ qden = den (k) * qms (k)
+ if (qms (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qms (k), den (k), blins, mus, &
+ rra = rras, rrb = rrbs, rr = fac_s)
+ else
+ fac_s = 0.0
+ endif
+ if (rads_flag .eq. 1) then
+ if (pt (i, j, k) .lt. tice) then
+ z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2
+ else
+ z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2 / alpha
+ endif
+ endif
+ if (rads_flag .eq. 2) then
+ if (pt (i, j, k) .lt. tice) then
+ z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2
+ else
+ z_e = z_e + fac_s * 1.e18
+ endif
+ endif
+ if (rads_flag .eq. 3) then
+ z_e = z_e + mp_const * exp (1.6 * log (qden * vts (k)))
+ endif
+ endif
+
+ if (graupel .gt. 0) then
+ qden = den (k) * qmg (k)
+ if (do_hail .and. .not. do_inline_mp) then
+ if (qmg (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qmg (k), den (k), blinh, muh, &
+ rra = rrah, rrb = rrbh, rr = fac_g)
+ else
+ fac_g = 0.0
+ endif
+ if (radg_flag .eq. 1) then
+ if (pt (i, j, k) .lt. tice) then
+ z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2
+ else
+ z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2 / alpha
+ endif
+ endif
+ if (radg_flag .eq. 2) then
+ z_e = z_e + fac_g * 1.e18
+ endif
+ else
+ if (qmg (k) .gt. qcmin) then
+ call cal_pc_ed_oe_rr_tv (qmg (k), den (k), bling, mug, &
+ rra = rrag, rrb = rrbg, rr = fac_g)
+ else
+ fac_g = 0.0
+ endif
+ if (radg_flag .eq. 1) then
+ if (pt (i, j, k) .lt. tice) then
+ z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2
+ else
+ z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2 / alpha
+ endif
+ endif
+ if (radg_flag .eq. 2) then
+ z_e = z_e + fac_g * 1.e18
+ endif
+ endif
+ if (radg_flag .eq. 3) then
+ z_e = z_e + mp_const * exp (1.6 * log (qden * vtg (k)))
+ endif
+ endif
+
+ dbz (i, j, k) = 10. * log10 (max (0.01, z_e))
+ enddo
+
+ do k = mp_top + 1, npz
+ maxdbz (i, j) = max (dbz (i, j, k), maxdbz (i, j))
+ enddo
+
+ allmax = max (maxdbz (i, j), allmax)
+
+ enddo
+ enddo
+
+end subroutine rad_ref
! =======================================================================
-! compute the gradient of saturated specific humidity for table iii
+! moist heat capacity, 3 input variables
! =======================================================================
-real function iqs2 (ta, den, dqdt)
-
+function mhc3 (qv, q_liq, q_sol)
+
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
+
+ real (kind = r8) :: mhc3
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: qv, q_liq, q_sol
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ mhc3 = one_r8 + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice
+
+end function mhc3
! =======================================================================
-! compute the gradient of saturated specific humidity for table iii
+! moist heat capacity, 4 input variables
! =======================================================================
-real function qs1d_moist (ta, qv, pa, dqdt)
-
+function mhc4 (qd, qv, q_liq, q_sol)
+
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
+
+ real (kind = r8) :: mhc4
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: qv, q_liq, q_sol
+
+ real (kind = r8), intent (in) :: qd
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ mhc4 = qd + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice
+
+end function mhc4
! =======================================================================
-! compute the gradient of saturated specific humidity for table ii
+! moist heat capacity, 6 input variables
! =======================================================================
-real function wqsat2_moist (ta, qv, pa, dqdt)
-
+function mhc6 (qv, ql, qr, qi, qs, qg)
+
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 = 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 wqsat2_moist
+
+ real (kind = r8) :: mhc6
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: qv, ql, qr, qi, qs, qg
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: q_liq, q_sol
+
+ q_liq = ql + qr
+ q_sol = qi + qs + qg
+ mhc6 = mhc (qv, q_liq, q_sol)
+
+end function mhc6
! =======================================================================
-! compute the saturated specific humidity for table ii
+! moist total energy
! =======================================================================
-real function wqsat_moist (ta, qv, pa)
-
+function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q)
+
implicit none
-
- real, intent (in) :: ta, pa, qv
-
- 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)
- wqsat_moist = eps * es * (1. + zvir * qv) / pa
-
-end function wqsat_moist
+
+ real (kind = r8) :: mte
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ logical, intent (in) :: moist_q
+
+ real, intent (in) :: qv, ql, qr, qi, qs, qg, dp
+
+ real (kind = r8), intent (in) :: tk
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: q_liq, q_sol, q_cond
+
+ real (kind = r8) :: cvm, con_r8
+
+ q_liq = ql + qr
+ q_sol = qi + qs + qg
+ q_cond = q_liq + q_sol
+ con_r8 = one_r8 - (qv + q_cond)
+ if (moist_q) then
+ cvm = mhc (con_r8, qv, q_liq, q_sol)
+ else
+ cvm = mhc (qv, q_liq, q_sol)
+ endif
+ mte = rgrav * cvm * c_air * tk * dp
+
+end function mte
! =======================================================================
-! compute the saturated specific humidity for table iii
+! moist total energy and total water
! =======================================================================
-real function qs1d_m (ta, qv, pa)
-
+subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, &
+ gsize, dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, &
+ te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss)
+
implicit none
-
- real, intent (in) :: ta, pa, qv
-
- 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)
- qs1d_m = eps * es * (1. + zvir * qv) / pa
-
-end function qs1d_m
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ logical, intent (in) :: moist_q, hydrostatic
+
+ real, intent (in) :: gsize, vapor, water, rain, ice, snow, graupel, dts, sen, stress
+
+ real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp
+
+ real (kind = r8), intent (in) :: dte
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: tz
+
+ real (kind = r8), intent (out) :: te_b, tw_b
+
+ real (kind = r8), intent (out), optional :: te_loss
+
+ real (kind = r8), intent (out), dimension (ks:ke) :: te, tw
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ real :: q_cond
+
+ real (kind = r8) :: con_r8
+
+ real, dimension (ks:ke) :: q_liq, q_sol
+
+ real (kind = r8), dimension (ks:ke) :: cvm
+
+ do k = ks, ke
+ q_liq (k) = ql (k) + qr (k)
+ q_sol (k) = qi (k) + qs (k) + qg (k)
+ q_cond = q_liq (k) + q_sol (k)
+ con_r8 = one_r8 - (qv (k) + q_cond)
+ if (moist_q) then
+ cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k))
+ else
+ cvm (k) = mhc (qv (k), q_liq (k), q_sol (k))
+ endif
+ te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air
+ if (hydrostatic) then
+ te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2)
+ else
+ te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2)
+ endif
+ te (k) = rgrav * te (k) * delp (k) * gsize ** 2.0
+ tw (k) = rgrav * (qv (k) + q_cond) * delp (k) * gsize ** 2.0
+ enddo
+ te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) * gsize ** 2.0
+ tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 * gsize ** 2.0
+
+ if (present (te_loss)) then
+ ! total energy change due to sedimentation and its heating
+ te_loss = dte * gsize ** 2.0
+ endif
+
+end subroutine mtetw
+
! =======================================================================
-! computes the difference in saturation vapor * density * between water and ice
+! calculate heat capacities and latent heat coefficients
! =======================================================================
-real function d_sat (ta, den)
-
+subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, &
+ cvm, te8, tz, lcpk, icpk, tcpk, tcp3)
+
implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: ks, ke
+
+ real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
+
+ real (kind = r8), intent (in), dimension (ks:ke) :: tz
+
+ real, intent (out), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (out), dimension (ks:ke) :: cvm, te8
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: k
+
+ do k = ks, ke
+ q_liq (k) = ql (k) + qr (k)
+ q_sol (k) = qi (k) + qs (k) + qg (k)
+ cvm (k) = mhc (qv (k), q_liq (k), q_sol (k))
+ te8 (k) = cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)
+ lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k)
+ icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k)
+ tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k)
+ tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr))
+ enddo
- real, intent (in) :: ta, den
-
- real :: es_w, es_i, ap1, tmin
-
- integer :: it
-
- 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
-
+end subroutine cal_mhc_lhc
+
! =======================================================================
-! compute the saturated water vapor pressure for table ii
+! update hydrometeors
! =======================================================================
-real function esw_table (ta)
-
+subroutine update_qq (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg)
+
implicit none
-
- real, intent (in) :: ta
-
- real :: ap1, tmin
-
- integer :: it
-
- tmin = table_ice - 160.
- ap1 = 10. * dim (ta, tmin) + 1.
- ap1 = min (2621., ap1)
- it = ap1
- esw_table = tablew (it) + (ap1 - it) * desw (it)
-
-end function esw_table
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg
+
+ real, intent (inout) :: qv, ql, qr, qi, qs, qg
+
+ qv = qv + dqv
+ ql = ql + dql
+ qr = qr + dqr
+ qi = qi + dqi
+ qs = qs + dqs
+ qg = qg + dqg
+
+end subroutine update_qq
! =======================================================================
-! compute the saturated water vapor pressure for table iii
+! update hydrometeors and temperature
! =======================================================================
-real function es2_table (ta)
-
+subroutine update_qt (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg, te8, &
+ cvm, tk, lcpk, icpk, tcpk, tcp3)
+
implicit none
-
- real, intent (in) :: ta
-
- real :: ap1, tmin
-
- integer :: it
-
- tmin = table_ice - 160.
- ap1 = 10. * dim (ta, tmin) + 1.
- ap1 = min (2621., ap1)
- it = ap1
- es2_table = table2 (it) + (ap1 - it) * des2 (it)
-
-end function es2_table
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg
+
+ real (kind = r8), intent (in) :: te8
+
+ real, intent (inout) :: qv, ql, qr, qi, qs, qg
+
+ real, intent (out) :: lcpk, icpk, tcpk, tcp3
+
+ real (kind = r8), intent (out) :: cvm, tk
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ qv = qv + dqv
+ ql = ql + dql
+ qr = qr + dqr
+ qi = qi + dqi
+ qs = qs + dqs
+ qg = qg + dqg
+
+ cvm = mhc (qv, ql, qr, qi, qs, qg)
+ tk = (te8 - lv00 * qv + li00 * (qi + qs + qg)) / cvm
+
+ lcpk = (lv00 + d1_vap * tk) / cvm
+ icpk = (li00 + d1_ice * tk) / cvm
+ tcpk = (li20 + (d1_vap + d1_ice) * tk) / cvm
+ tcp3 = lcpk + icpk * min (1., dim (tice, tk) / (tice - t_wfr))
+
+end subroutine update_qt
! =======================================================================
-! compute the saturated water vapor pressure for table ii
+! calculation of particle concentration (pc), effective diameter (ed),
+! optical extinction (oe), radar reflectivity factor (rr), and
+! mass-weighted terminal velocity (tv)
! =======================================================================
-subroutine esw_table1d (ta, es, n)
+subroutine cal_pc_ed_oe_rr_tv (q, den, blin, mu, pca, pcb, pc, eda, edb, ed, &
+ oea, oeb, oe, rra, rrb, rr, tva, tvb, tv)
implicit none
- integer, intent (in) :: n
-
- real, intent (in) :: ta (n)
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
- real, intent (out) :: es (n)
+ real, intent (in) :: blin, mu
- real :: ap1, tmin
+ real, intent (in) :: q, den
- integer :: i, it
+ real (kind = r8), intent (in), optional :: pca, pcb, eda, edb, oea, oeb, rra, rrb, tva, tvb
- tmin = table_ice - 160.
+ real, intent (out), optional :: pc, ed, oe, rr, tv
- 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
+ if (present (pca) .and. present (pcb) .and. present (pc)) then
+ pc = pca / pcb * exp (mu / (mu + 3) * log (6 * den * q))
+ endif
+ if (present (eda) .and. present (edb) .and. present (ed)) then
+ ed = eda / edb * exp (1. / (mu + 3) * log (6 * den * q))
+ endif
+ if (present (oea) .and. present (oeb) .and. present (oe)) then
+ oe = oea / oeb * exp ((mu + 2) / (mu + 3) * log (6 * den * q))
+ endif
+ if (present (rra) .and. present (rrb) .and. present (rr)) then
+ rr = rra / rrb * exp ((mu + 6) / (mu + 3) * log (6 * den * q))
+ endif
+ if (present (tva) .and. present (tvb) .and. present (tv)) then
+ tv = tva / tvb * exp (blin / (mu + 3) * log (6 * den * q))
+ endif
-end subroutine esw_table1d
+end subroutine cal_pc_ed_oe_rr_tv
! =======================================================================
-! compute the saturated water vapor pressure for table iii
+! prepare saturation water vapor pressure tables
! =======================================================================
-subroutine es2_table1d (ta, es, n)
-
+subroutine qs_init
+
implicit none
+
+ integer :: i
+
+ if (.not. tables_are_initialized) then
+
+ allocate (table0 (length))
+ allocate (table1 (length))
+ allocate (table2 (length))
+ allocate (table3 (length))
+ allocate (table4 (length))
+
+ allocate (des0 (length))
+ allocate (des1 (length))
+ allocate (des2 (length))
+ allocate (des3 (length))
+ allocate (des4 (length))
+
+ call qs_table0 (length)
+ call qs_table1 (length)
+ call qs_table2 (length)
+ call qs_table3 (length)
+ call qs_table4 (length)
+
+ do i = 1, length - 1
+ des0 (i) = max (0., table0 (i + 1) - table0 (i))
+ des1 (i) = max (0., table1 (i + 1) - table1 (i))
+ des2 (i) = max (0., table2 (i + 1) - table2 (i))
+ des3 (i) = max (0., table3 (i + 1) - table3 (i))
+ des4 (i) = max (0., table4 (i + 1) - table4 (i))
+ enddo
+ des0 (length) = des0 (length - 1)
+ des1 (length) = des1 (length - 1)
+ des2 (length) = des2 (length - 1)
+ des3 (length) = des3 (length - 1)
+ des4 (length) = des4 (length - 1)
+
+ tables_are_initialized = .true.
- integer, intent (in) :: n
-
- real, intent (in) :: ta (n)
-
- real, intent (out) :: es (n)
-
- real :: ap1, tmin
-
- 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) = table2 (it) + (ap1 - it) * des2 (it)
- enddo
-
-end subroutine es2_table1d
+ endif
+
+end subroutine qs_init
! =======================================================================
-! compute the saturated water vapor pressure for table iv
+! saturation water vapor pressure table, core function
! =======================================================================
-subroutine es3_table1d (ta, es, n)
-
+subroutine qs_table_core (n, n_blend, do_smith_table, table)
+
implicit none
-
- integer, intent (in) :: n
-
- real, intent (in) :: ta (n)
-
- real, intent (out) :: es (n)
-
- real :: ap1, tmin
-
- 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) = table3 (it) + (ap1 - it) * des3 (it)
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: n, n_blend
+
+ logical, intent (in) :: do_smith_table
+
+ real, intent (out), dimension (n) :: table
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i
+ integer, parameter :: n_min = 1600
+
+ real (kind = r8) :: delt = 0.1
+ real (kind = r8) :: tmin, tem, esh
+ real (kind = r8) :: wice, wh2o, fac0, fac1, fac2
+ real (kind = r8) :: esbasw, tbasw, esbasi, a, b, c, d, e
+ real (kind = r8) :: esupc (n_blend)
+
+ esbasw = 1013246.0
+ tbasw = tice + 100.
+ esbasi = 6107.1
+ tmin = tice - n_min * delt
+
+ ! -----------------------------------------------------------------------
+ ! compute es over ice between - (n_min * delt) deg C and 0 deg C
+ ! -----------------------------------------------------------------------
+
+ if (do_smith_table) then
+ do i = 1, n_min
+ tem = tmin + delt * real (i - 1)
+ a = - 9.09718 * (tice / tem - 1.)
+ b = - 3.56654 * log10 (tice / tem)
+ c = 0.876793 * (1. - tem / tice)
+ e = log10 (esbasi)
+ table (i) = 0.1 * exp ((a + b + c + e) * log (10.))
+ enddo
+ else
+ do i = 1, n_min
+ tem = tmin + delt * real (i - 1)
+ fac0 = (tem - tice) / (tem * tice)
+ fac1 = fac0 * li2
+ fac2 = (d2_ice * log (tem / tice) + fac1) / rvgas
+ table (i) = e00 * exp (fac2)
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute es over water between - (n_blend * delt) deg C and [ (n - n_min - 1) * delt] deg C
+ ! -----------------------------------------------------------------------
+
+ if (do_smith_table) then
+ do i = 1, n - n_min + n_blend
+ tem = tice + delt * (real (i - 1) - n_blend)
+ a = - 7.90298 * (tbasw / tem - 1.)
+ b = 5.02808 * log10 (tbasw / tem)
+ c = - 1.3816e-7 * (exp ((1. - tem / tbasw) * 11.344 * log (10.)) - 1.)
+ d = 8.1328e-3 * (exp ((tbasw / tem - 1.) * (- 3.49149) * log (10.)) - 1.)
+ e = log10 (esbasw)
+ esh = 0.1 * exp ((a + b + c + d + e) * log (10.))
+ if (i .le. n_blend) then
+ esupc (i) = esh
+ else
+ table (i + n_min - n_blend) = esh
+ endif
+ enddo
+ else
+ do i = 1, n - n_min + n_blend
+ tem = tice + delt * (real (i - 1) - n_blend)
+ fac0 = (tem - tice) / (tem * tice)
+ fac1 = fac0 * lv0
+ fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas
+ esh = e00 * exp (fac2)
+ if (i .le. n_blend) then
+ esupc (i) = esh
+ else
+ table (i + n_min - n_blend) = esh
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! derive blended es over ice and supercooled water between - (n_blend * delt) deg C and 0 deg C
+ ! -----------------------------------------------------------------------
+
+ do i = 1, n_blend
+ tem = tice + delt * (real (i - 1) - n_blend)
+ wice = 1.0 / (delt * n_blend) * (tice - tem)
+ wh2o = 1.0 / (delt * n_blend) * (tem - tice + delt * n_blend)
+ table (i + n_min - n_blend) = wice * table (i + n_min - n_blend) + wh2o * esupc (i)
enddo
-
-end subroutine es3_table1d
+
+end subroutine qs_table_core
! =======================================================================
-! saturation water vapor pressure table ii
-! 1 - phase table
+! saturation water vapor pressure table 0, water only
+! useful for idealized experiments
+! it can also be used in warm rain microphyscis only
! =======================================================================
-subroutine qs_tablew (n)
-
+subroutine qs_table0 (n)
+
implicit none
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
integer, intent (in) :: n
-
- real (kind = r_grid) :: delt = 0.1
- real (kind = r_grid) :: tmin, tem, fac0, fac1, fac2
-
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: i
-
- tmin = table_ice - 160.
-
+
+ real (kind = r8) :: delt = 0.1
+ real (kind = r8) :: tmin, tem, fac0, fac1, fac2
+
+ tmin = tice - 160.
+
! -----------------------------------------------------------------------
- ! compute es over water
+ ! compute es over water only
! -----------------------------------------------------------------------
-
+
do i = 1, n
tem = tmin + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
+ fac0 = (tem - tice) / (tem * tice)
fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
- tablew (i) = e00 * exp (fac2)
+ fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas
+ table0 (i) = e00 * exp (fac2)
enddo
-
-end subroutine qs_tablew
+
+end subroutine qs_table0
! =======================================================================
-! saturation water vapor pressure table iii
-! 2 - phase table
+! saturation water vapor pressure table 1, water and ice
+! blended between -20 deg C and 0 deg C
+! the most realistic saturation water vapor pressure for the full temperature range
! =======================================================================
-subroutine qs_table2 (n)
-
+subroutine qs_table1 (n)
+
implicit none
-
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
integer, intent (in) :: n
+
+ call qs_table_core (n, 200, .false., table1)
+
+end subroutine qs_table1
- real (kind = r_grid) :: delt = 0.1
- real (kind = r_grid) :: tmin, tem0, tem1, fac0, fac1, fac2
-
- integer :: i, i0, i1
-
- tmin = table_ice - 160.
-
- do i = 1, n
- tem0 = tmin + delt * real (i - 1)
- 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 / 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 / t_ice) + fac1) / rvgas
- endif
- table2 (i) = e00 * exp (fac2)
- enddo
+! =======================================================================
+! saturation water vapor pressure table 2, water and ice
+! same as table 1, but the blending is replaced with smoothing around 0 deg C
+! it is not designed for mixed-phase cloud microphysics
+! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
+! =======================================================================
+subroutine qs_table2 (n)
+
+ implicit none
+
! -----------------------------------------------------------------------
- ! smoother around 0 deg c
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- i0 = 1600
- i1 = 1601
- tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1))
- tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1))
- table2 (i0) = tem0
- table2 (i1) = tem1
-
+
+ integer, intent (in) :: n
+
+ call qs_table_core (n, 0, .false., table2)
+
end subroutine qs_table2
! =======================================================================
-! saturation water vapor pressure table iv
-! 2 - phase table with " - 2 c" as the transition point
+! saturation water vapor pressure table 3, water and ice
+! blended between -20 deg C and 0 deg C
+! the same as table 1, but from smithsonian meteorological tables page 350
! =======================================================================
subroutine qs_table3 (n)
-
+
implicit none
-
- integer, intent (in) :: n
-
- 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
-
- esbasw = 1013246.0
- tbasw = table_ice + 100.
- esbasi = 6107.1
- tmin = table_ice - 160.
-
- do i = 1, n
- tem = tmin + delt * real (i - 1)
- ! if (i <= 1600) then
- if (i <= 1580) then ! change to - 2 c
- ! -----------------------------------------------------------------------
- ! compute es over ice between - 160 deg c and 0 deg c.
- ! see smithsonian meteorological tables page 350.
- ! -----------------------------------------------------------------------
- aa = - 9.09718 * (table_ice / tem - 1.)
- b = - 3.56654 * log10 (table_ice / tem)
- c = 0.876793 * (1. - tem / table_ice)
- e = log10 (esbasi)
- table3 (i) = 0.1 * 10 ** (aa + b + c + e)
- else
- ! -----------------------------------------------------------------------
- ! compute es over water between - 2 deg c and 102 deg c.
- ! see smithsonian meteorological tables page 350.
- ! -----------------------------------------------------------------------
- aa = - 7.90298 * (tbasw / tem - 1.)
- 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 = log10 (esbasw)
- table3 (i) = 0.1 * 10 ** (aa + b + c + d + e)
- endif
- enddo
-
+
! -----------------------------------------------------------------------
- ! smoother around - 2 deg c
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- i0 = 1580
- i1 = 1581
- tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1))
- tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1))
- table3 (i0) = tem0
- table3 (i1) = tem1
-
+
+ integer, intent (in) :: n
+
+ call qs_table_core (n, 200, .true., table3)
+
end subroutine qs_table3
! =======================================================================
-! compute the saturated specific humidity for table
-! note: this routine is based on "moist" mixing ratio
+! saturation water vapor pressure table 4, water and ice
+! same as table 3, but the blending is replaced with smoothing around 0 deg C
+! the same as table 2, but from smithsonian meteorological tables page 350
! =======================================================================
-real function qs_blend (t, p, q)
-
+subroutine qs_table4 (n)
+
implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: n
+
+ call qs_table_core (n, 0, .true., table4)
+
+end subroutine qs_table4
- real, intent (in) :: t, p, q
+! =======================================================================
+! compute the saturated water pressure, core function
+! =======================================================================
- real :: es, ap1, tmin
+function es_core (length, tk, table, des)
+
+ implicit none
+
+ real :: es_core
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+ integer, intent (in) :: length
+
+ real, intent (in) :: tk
+
+ real, intent (in), dimension (length) :: table, des
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
integer :: it
-
- tmin = table_ice - 160.
- ap1 = 10. * dim (t, tmin) + 1.
+
+ real :: ap1, tmin
+
+ if (.not. tables_are_initialized) call qs_init
+
+ tmin = tice - 160.
+ ap1 = 10. * dim (tk, 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
+ es_core = table (it) + (ap1 - it) * des (it)
+
+end function es_core
! =======================================================================
-! saturation water vapor pressure table i
-! 3 - phase table
+! compute the saturated specific humidity, core function
! =======================================================================
-subroutine qs_table (n)
-
+function qs_core (length, tk, den, dqdt, table, des)
+
implicit none
+
+ real :: qs_core
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
- integer, intent (in) :: n
-
- 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
+ integer, intent (in) :: length
+
+ real, intent (in) :: tk, den
+
+ real, intent (in), dimension (length) :: table, des
+
+ real, intent (out) :: dqdt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: it
+
+ real :: ap1, tmin
+
+ tmin = tice - 160.
+ ap1 = 10. * dim (tk, tmin) + 1.
+ ap1 = min (2621., ap1)
+ qs_core = es_core (length, tk, table, des) / (rvgas * tk * den)
+ it = ap1 - 0.5
+ dqdt = 10. * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) / (rvgas * tk * den)
+
+end function qs_core
- tmin = table_ice - 160.
+! =======================================================================
+! compute the saturated water pressure based on table 0, water only
+! useful for idealized experiments
+! it can also be used in warm rain microphyscis only
+! =======================================================================
+function wes_t (tk)
+
+ implicit none
+
+ real :: wes_t
+
! -----------------------------------------------------------------------
- ! compute es over ice between - 160 deg c and 0 deg c.
+ ! input / output arguments
! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk
+
+ wes_t = es_core (length, tk, table0, des0)
+
+end function wes_t
- do i = 1, 1600
- tem = tmin + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * li2
- fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas
- table (i) = e00 * exp (fac2)
- enddo
+! =======================================================================
+! compute the saturated water pressure based on table 1, water and ice
+! the most realistic saturation water vapor pressure for the full temperature range
+! =======================================================================
+function mes_t (tk)
+
+ implicit none
+
+ real :: mes_t
+
! -----------------------------------------------------------------------
- ! compute es over water between - 20 deg c and 102 deg c.
+ ! input / output arguments
! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk
+
+ mes_t = es_core (length, tk, table1, des1)
+
+end function mes_t
- do i = 1, 1221
- tem = 253.16 + delt * real (i - 1)
- fac0 = (tem - t_ice) / (tem * t_ice)
- fac1 = fac0 * lv0
- fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas
- esh20 = e00 * exp (fac2)
- if (i <= 200) then
- esupc (i) = esh20
- else
- table (i + 1400) = esh20
- endif
- enddo
+! =======================================================================
+! compute the saturated water pressure based on table 2, water and ice
+! it is not designed for mixed-phase cloud microphysics
+! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
+! =======================================================================
+function ies_t (tk)
+
+ implicit none
+
+ real :: ies_t
+
! -----------------------------------------------------------------------
- ! derive blended es over ice and supercooled water between - 20 deg c and 0 deg c
+ ! input / output arguments
! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk
+
+ ies_t = es_core (length, tk, table2, des2)
+
+end function ies_t
- do i = 1, 200
- tem = 253.16 + delt * real (i - 1)
- wice = 0.05 * (table_ice - tem)
- wh2o = 0.05 * (tem - 253.16)
- table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i)
- enddo
+! =======================================================================
+! compute the saturated specific humidity based on table 0, water only
+! useful for idealized experiments
+! it can also be used in warm rain microphyscis only
+! =======================================================================
-end subroutine qs_table
+function wqs_trho (tk, den, dqdt)
+
+ implicit none
+
+ real :: wqs_trho
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk, den
+
+ real, intent (out) :: dqdt
+
+ wqs_trho = qs_core (length, tk, den, dqdt, table0, des0)
+
+end function wqs_trho
! =======================================================================
-! 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
+! compute the saturated specific humidity based on table 1, water and ice
+! the most realistic saturation water vapor pressure for the full temperature range
! =======================================================================
-subroutine qsmith (im, km, ks, t, p, q, qs, dqdt)
-
+function mqs_trho (tk, den, dqdt)
+
implicit none
+
+ real :: mqs_trho
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk, den
+
+ real, intent (out) :: dqdt
+
+ mqs_trho = qs_core (length, tk, den, dqdt, table1, des1)
+
+end function mqs_trho
- integer, intent (in) :: im, km, ks
-
- real, intent (in), dimension (im, km) :: t, p, q
+! =======================================================================
+! compute the saturated specific humidity based on table 2, water and ice
+! it is not designed for mixed-phase cloud microphysics
+! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
+! =======================================================================
- real, intent (out), dimension (im, km) :: qs
+function iqs_trho (tk, den, dqdt)
+
+ implicit none
+
+ real :: iqs_trho
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk, den
+
+ real, intent (out) :: dqdt
+
+ iqs_trho = qs_core (length, tk, den, dqdt, table2, des2)
+
+end function iqs_trho
- real, intent (out), dimension (im, km), optional :: dqdt
+! =======================================================================
+! compute the saturated specific humidity based on table 0, water only
+! useful for idealized experiments
+! it can also be used in warm rain microphyscis only
+! =======================================================================
- real :: eps10, ap1, tmin
+function wqs_ptqv (tk, pa, qv, dqdt)
+
+ implicit none
+
+ real :: wqs_ptqv
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk, pa, qv
+
+ real, intent (out) :: dqdt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: den
+
+ den = pa / (rdgas * tk * (1. + zvir * qv))
+
+ wqs_ptqv = wqs (tk, den, dqdt)
+
+end function wqs_ptqv
- real, dimension (im, km) :: es
+! =======================================================================
+! compute the saturated specific humidity based on table 1, water and ice
+! the most realistic saturation water vapor pressure for the full temperature range
+! =======================================================================
- integer :: i, k, it
+function mqs_ptqv (tk, pa, qv, dqdt)
+
+ implicit none
+
+ real :: mqs_ptqv
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk, pa, qv
+
+ real, intent (out) :: dqdt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: den
+
+ den = pa / (rdgas * tk * (1. + zvir * qv))
+
+ mqs_ptqv = mqs (tk, den, dqdt)
+
+end function mqs_ptqv
- tmin = table_ice - 160.
- eps10 = 10. * eps
+! =======================================================================
+! compute the saturated specific humidity based on table 2, water and ice
+! it is not designed for mixed-phase cloud microphysics
+! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
+! =======================================================================
- if (.not. tables_are_initialized) then
- call qsmith_init
- endif
+function iqs_ptqv (tk, pa, qv, dqdt)
+
+ implicit none
+
+ real :: iqs_ptqv
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: tk, pa, qv
+
+ real, intent (out) :: dqdt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: den
+
+ den = pa / (rdgas * tk * (1. + zvir * qv))
+
+ iqs_ptqv = iqs (tk, den, dqdt)
+
+end function iqs_ptqv
- 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
+! =======================================================================
+! compute the saturated specific humidity based on table 1, water and ice
+! the most realistic saturation water vapor pressure for the full temperature range
+! it is the 3d version of "mqs"
+! =======================================================================
+subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, ks
+
+ real, intent (in), dimension (im, ks:km) :: tk, pa, qv
+
+ real, intent (out), dimension (im, ks:km) :: qs
+
+ real, intent (out), dimension (im, ks:km), optional :: dqdt
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, k
+
+ real :: dqdt0
+
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)
+ qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt (i, k))
+ enddo
+ enddo
+ else
+ do k = ks, km
+ do i = 1, im
+ qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt0)
enddo
enddo
endif
-
-end subroutine qsmith
+
+end subroutine mqs3d
! =======================================================================
-! fix negative water species
-! this is designed for 6 - class micro - physics schemes
+! compute wet buld temperature, core function
+! Knox et al. (2017)
! =======================================================================
-subroutine neg_adj (ks, ke, pt, dp, qv, ql, qr, qi, qs, qg, cond)
-
+function wet_bulb_core (qv, tk, den, lcp)
+
implicit none
-
- 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, dimension (ks:ke) :: lcpk, icpk
-
- real :: dq, cvm
-
- integer :: k
-
+
+ real :: wet_bulb_core
+
! -----------------------------------------------------------------------
- ! define heat capacity and latent heat coefficient
+ ! input / output arguments
! -----------------------------------------------------------------------
-
- 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
-
- cond = 0
-
- do k = ks, ke
-
- ! -----------------------------------------------------------------------
- ! ice phase:
- ! -----------------------------------------------------------------------
-
- ! if cloud ice < 0, borrow from snow
- if (qi (k) < 0.) then
- qs (k) = qs (k) + qi (k)
- qi (k) = 0.
- endif
- ! if snow < 0, borrow from graupel
- if (qs (k) < 0.) then
- qg (k) = qg (k) + qs (k)
- qs (k) = 0.
- endif
- ! if graupel < 0, borrow from rain
- if (qg (k) < 0.) then
- qr (k) = qr (k) + qg (k)
- pt (k) = pt (k) - qg (k) * icpk (k) ! heating
- qg (k) = 0.
- endif
-
- ! -----------------------------------------------------------------------
- ! liquid phase:
- ! -----------------------------------------------------------------------
-
- ! if rain < 0, borrow from cloud water
- if (qr (k) < 0.) then
- 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
-
+
+ real, intent (in) :: qv, tk, den, lcp
+
! -----------------------------------------------------------------------
- ! fix water vapor; borrow from below
+ ! local variables
! -----------------------------------------------------------------------
+
+ logical :: do_adjust = .false.
+
+ real :: factor = 1. / 3.
+ real :: qsat, tp, dqdt
+
+ wet_bulb_core = tk
+ qsat = wqs (wet_bulb_core, den, dqdt)
+ tp = factor * (qsat - qv) / (1. + lcp * dqdt) * lcp
+ wet_bulb_core = wet_bulb_core - tp
+
+ if (do_adjust .and. tp .gt. 0.0) then
+ qsat = wqs (wet_bulb_core, den, dqdt)
+ tp = (qsat - qv) / (1. + lcp * dqdt) * lcp
+ wet_bulb_core = wet_bulb_core - tp
+ endif
+
+end function wet_bulb_core
- 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
+! =======================================================================
+! compute wet buld temperature, dry air case
+! =======================================================================
+function wet_bulb_dry (qv, tk, den)
+
+ implicit none
+
+ real :: wet_bulb_dry
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
! -----------------------------------------------------------------------
- ! bottom layer; borrow from above
+
+ real, intent (in) :: qv, tk, den
+
! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: lcp
+
+ lcp = hlv / cp_air
+
+ wet_bulb_dry = wet_bulb_core (qv, tk, den, lcp)
+
+end function wet_bulb_dry
- 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
+! =======================================================================
+! compute wet buld temperature, moist air case
+! =======================================================================
-end subroutine neg_adj
+function wet_bulb_moist (qv, ql, qi, qr, qs, qg, tk, den)
+
+ implicit none
+
+ real :: wet_bulb_moist
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ real, intent (in) :: qv, ql, qi, qr, qs, qg, tk, den
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ real :: lcp, q_liq, q_sol
+
+ real (kind = r8) :: cvm
+
+ q_liq = ql + qr
+ q_sol = qi + qs + qg
+ cvm = mhc (qv, q_liq, q_sol)
+ lcp = (lv00 + d1_vap * tk) / cvm
+
+ wet_bulb_moist = wet_bulb_core (qv, tk, den, lcp)
+
+end function wet_bulb_moist
end module gfdl_mp_mod
diff --git a/model/intermediate_phys.F90 b/model/intermediate_phys.F90
new file mode 100644
index 000000000..ce8de9bda
--- /dev/null
+++ b/model/intermediate_phys.F90
@@ -0,0 +1,778 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! Intermediate Physics Interface
+! Developer: Linjiong Zhou
+! Last Update: 5/19/2022
+! =======================================================================
+
+module intermediate_phys_mod
+
+ use constants_mod, only: rdgas, grav
+ use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys
+ use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, inline_mp_type
+ use mpp_domains_mod, only: domain2d, mpp_update_domains
+ use fv_timing_mod, only: timing_on, timing_off
+ use tracer_manager_mod, only: get_tracer_index, get_tracer_names
+ use field_manager_mod, only: model_atmos
+ use gfdl_mp_mod, only: gfdl_mp_driver, fast_sat_adj, mtetw
+
+ implicit none
+
+ private
+
+ real, parameter :: consv_min = 0.001
+
+ public :: intermediate_phys
+
+ ! -----------------------------------------------------------------------
+ ! precision definition
+ ! -----------------------------------------------------------------------
+
+ integer, parameter :: r8 = 8 ! double precision
+
+contains
+
+subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, &
+ c2l_ord, mdt, consv, akap, ptop, pfull, hs, te0_2d, u, v, w, pt, &
+ delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, inline_mp, &
+ gridstruct, domain, bd, hydrostatic, do_adiabatic_init, &
+ do_inline_mp, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, c2l_ord, nwat
+
+ logical, intent (in) :: hydrostatic, do_adiabatic_init, do_inline_mp, consv_checker
+ logical, intent (in) :: do_sat_adj, last_step, do_fast_phys, adj_mass_vmr
+
+ real, intent (in) :: consv, mdt, akap, r_vir, ptop, te_err, tw_err
+
+ real, intent (in), dimension (km) :: pfull
+
+ real, intent (in), dimension (isd:ied, jsd:jed) :: hs
+
+ real, intent (inout), dimension (is:, js:, 1:) :: delz
+
+ real, intent (inout), dimension (isd:, jsd:, 1:) :: q_con, cappa, w
+
+ real, intent (inout), dimension (is:ie, js:je) :: te0_2d
+
+ real, intent (inout), dimension (isd:ied, jsd:jed, km) :: pt, delp
+
+ real, intent (inout), dimension (isd:ied, jsd:jed, km, *) :: q
+
+ real, intent (inout), dimension (isd:ied, jsd:jed+1, km) :: u
+
+ real, intent (inout), dimension (isd:ied+1, jsd:jed, km) :: v
+
+ real, intent (out), dimension (is:ie, js:je, km) :: pkz
+
+ type (fv_grid_type), intent (in), target :: gridstruct
+
+ type (fv_grid_bounds_type), intent (in) :: bd
+
+ type (domain2d), intent (inout) :: domain
+
+ type (inline_mp_type), intent (inout) :: inline_mp
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ logical, allocatable, dimension (:) :: conv_vmr_mmr
+
+ integer :: i, j, k, m, kmp, sphum, liq_wat, ice_wat
+ integer :: rainwat, snowwat, graupel, cld_amt, ccn_cm3, cin_cm3, aerosol
+
+ real :: rrg
+
+ real, dimension (is:ie) :: gsize
+
+ real, dimension (is:ie, km) :: q2, q3, qliq, qsol, adj_vmr
+
+ real, dimension (is:ie, km+1) :: phis, pe, peln
+
+ real, dimension (isd:ied, jsd:jed, km) :: te, ua, va
+
+ real, allocatable, dimension (:) :: wz
+
+ real, allocatable, dimension (:,:) :: dz, wa
+
+ real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0
+
+ real (kind = r8), allocatable, dimension (:) :: tz
+
+ real (kind = r8), dimension (is:ie) :: te_b_beg, te_b_end, tw_b_beg, tw_b_end, dte, te_loss
+
+ real (kind = r8), dimension (is:ie, 1:km) :: te_beg, te_end, tw_beg, tw_end
+
+ character (len = 32) :: tracer_units, tracer_name
+
+ sphum = get_tracer_index (model_atmos, 'sphum')
+ 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')
+ aerosol = get_tracer_index (model_atmos, 'aerosol')
+
+ rrg = - rdgas / grav
+
+ ! time saving trick
+ if (last_step) then
+ kmp = 1
+ else
+ do k = 1, km
+ kmp = k
+ if (pfull (k) .gt. 50.E2) exit
+ enddo
+ endif
+
+ ! decide which tracer needs adjustment
+ if (.not. allocated (conv_vmr_mmr)) allocate (conv_vmr_mmr (nq))
+ conv_vmr_mmr (:) = .false.
+ if (adj_mass_vmr) then
+ do m = 1, nq
+ call get_tracer_names (model_atmos, m, name = tracer_name, units = tracer_units)
+ if (trim (tracer_units) .eq. 'vmr') then
+ conv_vmr_mmr (m) = .true.
+ else
+ conv_vmr_mmr (m) = .false.
+ endif
+ enddo
+ endif
+
+ !-----------------------------------------------------------------------
+ ! Fast Saturation Adjustment >>>
+ !-----------------------------------------------------------------------
+
+ ! Note: pt at this stage is T_v
+ if ((do_adiabatic_init .or. (.not. do_inline_mp) .or. do_sat_adj) .and. nwat .eq. 6) then
+
+ call timing_on ('fast_sat_adj')
+
+ allocate (dz (is:ie, kmp:km))
+
+ allocate (tz (kmp:km))
+ allocate (wz (kmp:km))
+
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, kmp, km, te, ptop, w, &
+!$OMP delp, hydrostatic, hs, pt, delz, rainwat, ua, va, &
+!$OMP liq_wat, ice_wat, snowwat, graupel, q_con, r_vir, &
+!$OMP sphum, pkz, last_step, consv, te0_2d, gridstruct, &
+!$OMP q, mdt, cld_amt, cappa, rrg, akap, ccn_cm3, &
+!$OMP cin_cm3, aerosol, inline_mp, do_sat_adj, &
+!$OMP adj_mass_vmr, conv_vmr_mmr, nq, consv_checker, &
+!$OMP te_err, tw_err) &
+!$OMP private (q2, q3, gsize, dz, pe, peln, adj_vmr, qliq, qsol, &
+!$OMP tz, wz, dte, te_beg, tw_beg, te_b_beg, tw_b_beg, &
+!$OMP te_end, tw_end, te_b_end, tw_b_end, te_loss)
+
+ do j = js, je
+
+ ! grid size
+ gsize (is:ie) = sqrt (gridstruct%area_64 (is:ie, j))
+
+ ! aerosol
+ if (aerosol .gt. 0) then
+ q2 (is:ie, kmp:km) = q (is:ie, j, kmp:km, aerosol)
+ elseif (ccn_cm3 .gt. 0) then
+ q2 (is:ie, kmp:km) = q (is:ie, j, kmp:km, ccn_cm3)
+ else
+ q2 (is:ie, kmp:km) = 0.0
+ endif
+ if (cin_cm3 .gt. 0) then
+ q3 (is:ie, kmp:km) = q (is:ie, j, kmp:km, cin_cm3)
+ else
+ q3 (is:ie, kmp:km) = 0.0
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat)
+ qsol (is:ie, kmp:km) = q (is:ie, j, kmp:km, ice_wat) + q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel)
+ te_beg (is:ie, kmp:km) = 0.0
+ tw_beg (is:ie, kmp:km) = 0.0
+ te_b_beg (is:ie) = 0.0
+ tw_b_beg (is:ie) = 0.0
+ do i = is, ie
+ tz (kmp:km) = pt (i, j, kmp:km) / ((1. + r_vir * q (i, j, kmp:km, sphum)) * (1. - (qliq (i, kmp:km) + qsol (i, kmp:km))))
+ dte (i) = 0.0
+ wz (kmp:km) = 0.0
+ ua (i, j, kmp:km) = 0.0
+ va (i, j, kmp:km) = 0.0
+ call mtetw (kmp, km, q (i, j, kmp:km, sphum), q (i, j, kmp:km, liq_wat), &
+ q (i, j, kmp:km, rainwat), q (i, j, kmp:km, ice_wat), q (i, j, kmp:km, snowwat), &
+ q (i, j, kmp:km, graupel), tz (kmp:km), ua (i, j, kmp:km), va (i, j, kmp:km), wz (kmp:km), &
+ delp (i, j, kmp:km), gsize (i), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_beg (i, kmp:km), tw_beg (i, kmp:km), &
+ te_b_beg (i), tw_b_beg (i), .true., hydrostatic)
+ enddo
+ endif
+
+ ! calculate pe, peln
+ pe (is:ie, 1) = ptop
+ peln (is:ie, 1) = log (ptop)
+ do k = 2, km + 1
+ pe (is:ie, k) = pe (is:ie, k-1) + delp (is:ie, j, k-1)
+ peln (is:ie, k) = log (pe (is:ie, k))
+ enddo
+
+ ! layer thickness
+ if (.not. hydrostatic) then
+ dz (is:ie, kmp:km) = delz (is:ie, j, kmp:km)
+ else
+ dz (is:ie, kmp:km) = (peln (is:ie, kmp+1:km+1) - peln (is:ie, kmp:km)) * &
+ rrg * pt (is:ie, j, kmp:km)
+ endif
+
+ ! fast saturation adjustment
+ call fast_sat_adj (abs (mdt), is, ie, kmp, km, hydrostatic, consv .gt. consv_min, &
+ adj_vmr (is:ie, kmp:km), te (is:ie, j, kmp:km), dte (is:ie), q (is:ie, j, kmp:km, sphum), &
+ q (is:ie, j, kmp:km, liq_wat), q (is:ie, j, kmp:km, rainwat), &
+ q (is:ie, j, kmp:km, ice_wat), q (is:ie, j, kmp:km, snowwat), &
+ q (is:ie, j, kmp:km, graupel), q (is:ie, j, kmp:km, cld_amt), &
+ q2 (is:ie, kmp:km), q3 (is:ie, kmp:km), hs (is:ie, j), &
+ dz (is:ie, kmp:km), pt (is:ie, j, kmp:km), delp (is:ie, j, kmp:km), &
+#ifdef USE_COND
+ q_con (is:ie, j, kmp:km), &
+#else
+ q_con (isd:, jsd, 1:), &
+#endif
+#ifdef MOIST_CAPPA
+ cappa (is:ie, j, kmp:km), &
+#else
+ cappa (isd:, jsd, 1:), &
+#endif
+ gsize, last_step, inline_mp%cond (is:ie, j), inline_mp%reevap (is:ie, j), &
+ inline_mp%dep (is:ie, j), inline_mp%sub (is:ie, j), do_sat_adj)
+
+ ! update non-microphyiscs tracers due to mass change
+ if (adj_mass_vmr) then
+ do m = 1, nq
+ if (conv_vmr_mmr (m)) then
+ q (is:ie, j, kmp:km, m) = q (is:ie, j, kmp:km, m) * adj_vmr (is:ie, kmp:km)
+ endif
+ enddo
+ endif
+
+ ! update pkz
+ if (.not. hydrostatic) then
+#ifdef MOIST_CAPPA
+ pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * &
+ log (rrg * delp (is:ie, j, kmp:km) / &
+ delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
+#else
+ pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / &
+ delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
+#endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat)
+ qsol (is:ie, kmp:km) = q (is:ie, j, kmp:km, ice_wat) + q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel)
+ te_end (is:ie, kmp:km) = 0.0
+ tw_end (is:ie, kmp:km) = 0.0
+ te_b_end (is:ie) = 0.0
+ tw_b_end (is:ie) = 0.0
+ do i = is, ie
+ tz (kmp:km) = pt (i, j, kmp:km) / ((1. + r_vir * q (i, j, kmp:km, sphum)) * (1. - (qliq (i, kmp:km) + qsol (i, kmp:km))))
+ wz (kmp:km) = 0.0
+ ua (i, j, kmp:km) = 0.0
+ va (i, j, kmp:km) = 0.0
+ call mtetw (kmp, km, q (i, j, kmp:km, sphum), q (i, j, kmp:km, liq_wat), &
+ q (i, j, kmp:km, rainwat), q (i, j, kmp:km, ice_wat), q (i, j, kmp:km, snowwat), &
+ q (i, j, kmp:km, graupel), tz (kmp:km), ua (i, j, kmp:km), va (i, j, kmp:km), wz (kmp:km), &
+ delp (i, j, kmp:km), gsize (i), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_end (i, kmp:km), tw_end (i, kmp:km), &
+ te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
+ enddo
+ endif
+
+ ! add total energy change to te0_2d
+ if (consv .gt. consv_min) then
+ do i = is, ie
+ do k = kmp, km
+ te0_2d (i, j) = te0_2d (i, j) + te (i, j, k)
+ enddo
+ enddo
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ do i = is, ie
+ if (abs (sum (te_end (i, kmp:km)) + te_b_end (i) - sum (te_beg (i, kmp:km)) - te_b_beg (i)) / &
+ (sum (te_beg (i, kmp:km)) + te_b_beg (i)) .gt. te_err) then
+ print*, "FAST_SAT_ADJ TE: ", &
+ !(sum (te_beg (i, kmp:km)) + te_b_beg (i)) / (gsize (i) ** 2), &
+ !(sum (te_end (i, kmp:km)) + te_b_end (i)) / (gsize (i) ** 2), &
+ (sum (te_end (i, kmp:km)) + te_b_end (i) - sum (te_beg (i, kmp:km)) - te_b_beg (i)) / &
+ (sum (te_beg (i, kmp:km)) + te_b_beg (i))
+ endif
+ if (abs (sum (tw_end (i, kmp:km)) + tw_b_end (i) - sum (tw_beg (i, kmp:km)) - tw_b_beg (i)) / &
+ (sum (tw_beg (i, kmp:km)) + tw_b_beg (i)) .gt. tw_err) then
+ print*, "FAST_SAT_ADJ TW: ", &
+ !(sum (tw_beg (i, kmp:km)) + tw_b_beg (i)) / (gsize (i) ** 2), &
+ !(sum (tw_end (i, kmp:km)) + tw_b_end (i)) / (gsize (i) ** 2), &
+ (sum (tw_end (i, kmp:km)) + tw_b_end (i) - sum (tw_beg (i, kmp:km)) - tw_b_beg (i)) / &
+ (sum (tw_beg (i, kmp:km)) + tw_b_beg (i))
+ endif
+ !print*, "FAST_SAT_ADJ LOSS (%) : ", te_loss (i) / (sum (te_beg (i, kmp:km)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ deallocate (dz)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ call timing_off ('fast_sat_adj')
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Fast Saturation Adjustment
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Inline GFDL MP >>>
+ !-----------------------------------------------------------------------
+
+ if ((.not. do_adiabatic_init) .and. do_inline_mp .and. nwat .eq. 6) then
+
+ call timing_on ('gfdl_mp')
+
+ allocate (u_dt (isd:ied, jsd:jed, km))
+ allocate (v_dt (isd:ied, jsd:jed, km))
+
+ allocate (tz (kmp:km))
+ allocate (wz (kmp:km))
+
+ ! initialize wind tendencies
+ do k = 1, km
+ do j = jsd, jed
+ do i = isd, ied
+ u_dt (i, j, k) = 0.
+ v_dt (i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ ! save D grid u and v
+ if (consv .gt. consv_min) then
+ allocate (u0 (isd:ied, jsd:jed+1, km))
+ allocate (v0 (isd:ied+1, jsd:jed, km))
+ u0 = u
+ v0 = v
+ endif
+
+ ! D grid wind to A grid wind remap
+ call cubed_to_latlon (u, v, ua, va, gridstruct, npx, npy, km, 1, gridstruct%grid_type, &
+ domain, gridstruct%bounded_domain, c2l_ord, bd)
+
+ ! save delp
+ if (consv .gt. consv_min) then
+ allocate (dp0 (isd:ied, jsd:jed, km))
+ dp0 = delp
+ endif
+
+ allocate (dz (is:ie, kmp:km))
+ allocate (wa (is:ie, kmp:km))
+
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, kmp, km, ua, va, &
+!$OMP te, delp, hydrostatic, hs, pt, delz, ptop, &
+!$OMP rainwat, liq_wat, ice_wat, snowwat, graupel, q_con, &
+!$OMP sphum, w, pkz, last_step, consv, te0_2d, r_vir, &
+!$OMP gridstruct, q, mdt, cld_amt, cappa, rrg, akap, &
+!$OMP ccn_cm3, cin_cm3, inline_mp, do_inline_mp, consv_checker, &
+!$OMP u_dt, v_dt, aerosol, adj_mass_vmr, conv_vmr_mmr, nq, &
+!$OMP te_err, tw_err) &
+!$OMP private (q2, q3, gsize, dz, wa, pe, peln, adj_vmr, qliq, qsol, &
+!$OMP tz, wz, dte, te_beg, tw_beg, te_b_beg, tw_b_beg, &
+!$OMP te_end, tw_end, te_b_end, tw_b_end, te_loss)
+
+ do j = js, je
+
+ ! grid size
+ gsize (is:ie) = sqrt (gridstruct%area_64 (is:ie, j))
+
+ ! aerosol
+ if (aerosol .gt. 0) then
+ q2 (is:ie, kmp:km) = q (is:ie, j, kmp:km, aerosol)
+ elseif (ccn_cm3 .gt. 0) then
+ q2 (is:ie, kmp:km) = q (is:ie, j, kmp:km, ccn_cm3)
+ else
+ q2 (is:ie, kmp:km) = 0.0
+ endif
+ if (cin_cm3 .gt. 0) then
+ q3 (is:ie, kmp:km) = q (is:ie, j, kmp:km, cin_cm3)
+ else
+ q3 (is:ie, kmp:km) = 0.0
+ endif
+
+ ! note: ua and va are A-grid variables
+ ! note: pt is virtual temperature at this point
+ ! note: w is vertical velocity (m/s)
+ ! 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 or q3 is #/cm^3
+ ! note: the unit of area is m^2
+ ! note: the unit of prew, prer, prei, pres, preg is mm/day
+ ! note: the unit of prefluxw, prefluxr, prefluxi, prefluxs, prefluxg 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, kmp:km) = ua (is:ie, j, kmp:km)
+ v_dt (is:ie, j, kmp:km) = va (is:ie, j, kmp:km)
+
+ ! initialize tendencies diagnostic
+ if (allocated (inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt (is:ie, j, kmp:km) = &
+ inline_mp%liq_wat_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, liq_wat)
+ if (allocated (inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt (is:ie, j, kmp:km) = &
+ inline_mp%ice_wat_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, ice_wat)
+ if (allocated (inline_mp%qv_dt)) inline_mp%qv_dt (is:ie, j, kmp:km) = &
+ inline_mp%qv_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, sphum)
+ if (allocated (inline_mp%ql_dt)) inline_mp%ql_dt (is:ie, j, kmp:km) = &
+ inline_mp%ql_dt (is:ie, j, kmp:km) - (q (is:ie, j, kmp:km, liq_wat) + &
+ q (is:ie, j, kmp:km, rainwat))
+ if (allocated (inline_mp%qi_dt)) inline_mp%qi_dt (is:ie, j, kmp:km) = &
+ inline_mp%qi_dt (is:ie, j, kmp:km) - (q (is:ie, j, kmp:km, ice_wat) + &
+ q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel))
+ if (allocated (inline_mp%qr_dt)) inline_mp%qr_dt (is:ie, j, kmp:km) = &
+ inline_mp%qr_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, rainwat)
+ if (allocated (inline_mp%qs_dt)) inline_mp%qs_dt (is:ie, j, kmp:km) = &
+ inline_mp%qs_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, snowwat)
+ if (allocated (inline_mp%qg_dt)) inline_mp%qg_dt (is:ie, j, kmp:km) = &
+ inline_mp%qg_dt (is:ie, j, kmp:km) - q (is:ie, j, kmp:km, graupel)
+ if (allocated (inline_mp%t_dt)) inline_mp%t_dt (is:ie, j, kmp:km) = &
+ inline_mp%t_dt (is:ie, j, kmp:km) - pt (is:ie, j, kmp:km)
+ if (allocated (inline_mp%u_dt)) inline_mp%u_dt (is:ie, j, kmp:km) = &
+ inline_mp%u_dt (is:ie, j, kmp:km) - ua (is:ie, j, kmp:km)
+ if (allocated (inline_mp%v_dt)) inline_mp%v_dt (is:ie, j, kmp:km) = &
+ inline_mp%v_dt (is:ie, j, kmp:km) - va (is:ie, j, kmp:km)
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat)
+ qsol (is:ie, kmp:km) = q (is:ie, j, kmp:km, ice_wat) + q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel)
+ te_beg (is:ie, kmp:km) = 0.0
+ tw_beg (is:ie, kmp:km) = 0.0
+ te_b_beg (is:ie) = 0.0
+ tw_b_beg (is:ie) = 0.0
+ do i = is, ie
+ tz (kmp:km) = pt (i, j, kmp:km) / ((1. + r_vir * q (i, j, kmp:km, sphum)) * (1. - (qliq (i, kmp:km) + qsol (i, kmp:km))))
+ if (hydrostatic) then
+ wz (kmp:km) = 0.0
+ else
+ wz (kmp:km) = w (i, j, kmp:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (kmp, km, q (i, j, kmp:km, sphum), q (i, j, kmp:km, liq_wat), &
+ q (i, j, kmp:km, rainwat), q (i, j, kmp:km, ice_wat), q (i, j, kmp:km, snowwat), &
+ q (i, j, kmp:km, graupel), tz (kmp:km), ua (i, j, kmp:km), va (i, j, kmp:km), wz (kmp:km), &
+ delp (i, j, kmp:km), gsize (i), dte (i), 0.0, inline_mp%prew (i, j), &
+ inline_mp%prer (i, j), inline_mp%prei (i, j), inline_mp%pres (i, j), &
+ inline_mp%preg (i, j), 0.0, 0.0, abs (mdt), te_beg (i, kmp:km), tw_beg (i, kmp:km), &
+ te_b_beg (i), tw_b_beg (i), .true., hydrostatic)
+ enddo
+ endif
+
+ ! calculate pe, peln
+ pe (is:ie, 1) = ptop
+ peln (is:ie, 1) = log (ptop)
+ do k = 2, km + 1
+ pe (is:ie, k) = pe (is:ie, k-1) + delp (is:ie, j, k-1)
+ peln (is:ie, k) = log (pe (is:ie, k))
+ enddo
+
+ ! vertical velocity and layer thickness
+ if (.not. hydrostatic) then
+ wa (is:ie, kmp:km) = w (is:ie, j, kmp:km)
+ dz (is:ie, kmp:km) = delz (is:ie, j, kmp:km)
+ else
+ dz (is:ie, kmp:km) = (peln (is:ie, kmp+1:km+1) - peln (is:ie, kmp:km)) * &
+ rrg * pt (is:ie, j, kmp:km)
+ endif
+
+ ! GFDL cloud microphysics main program
+ call gfdl_mp_driver (q (is:ie, j, kmp:km, sphum), q (is:ie, j, kmp:km, liq_wat), &
+ q (is:ie, j, kmp:km, rainwat), q (is:ie, j, kmp:km, ice_wat), &
+ q (is:ie, j, kmp:km, snowwat), q (is:ie, j, kmp:km, graupel), &
+ q (is:ie, j, kmp:km, cld_amt), q2 (is:ie, kmp:km), &
+ q3 (is:ie, kmp:km), pt (is:ie, j, kmp:km), wa (is:ie, kmp:km), &
+ ua (is:ie, j, kmp:km), va (is:ie, j, kmp:km), dz (is:ie, kmp:km), &
+ delp (is:ie, j, kmp:km), gsize, abs (mdt), hs (is:ie, j), &
+ inline_mp%prew (is:ie, j), inline_mp%prer (is:ie, j), &
+ inline_mp%prei (is:ie, j), inline_mp%pres (is:ie, j), &
+ inline_mp%preg (is:ie, j), hydrostatic, is, ie, kmp, km, &
+#ifdef USE_COND
+ q_con (is:ie, j, kmp:km), &
+#else
+ q_con (isd:, jsd, 1:), &
+#endif
+#ifdef MOIST_CAPPA
+ cappa (is:ie, j, kmp:km), &
+#else
+ cappa (isd:, jsd, 1:), &
+#endif
+ consv .gt. consv_min, adj_vmr (is:ie, kmp:km), te (is:ie, j, kmp:km), dte (is:ie), &
+ inline_mp%pcw (is:ie, j, kmp:km), inline_mp%edw (is:ie, j, kmp:km), &
+ inline_mp%oew (is:ie, j, kmp:km), &
+ inline_mp%rrw (is:ie, j, kmp:km), inline_mp%tvw (is:ie, j, kmp:km), &
+ inline_mp%pci (is:ie, j, kmp:km), inline_mp%edi (is:ie, j, kmp:km), &
+ inline_mp%oei (is:ie, j, kmp:km), &
+ inline_mp%rri (is:ie, j, kmp:km), inline_mp%tvi (is:ie, j, kmp:km), &
+ inline_mp%pcr (is:ie, j, kmp:km), inline_mp%edr (is:ie, j, kmp:km), &
+ inline_mp%oer (is:ie, j, kmp:km), &
+ inline_mp%rrr (is:ie, j, kmp:km), inline_mp%tvr (is:ie, j, kmp:km), &
+ inline_mp%pcs (is:ie, j, kmp:km), inline_mp%eds (is:ie, j, kmp:km), &
+ inline_mp%oes (is:ie, j, kmp:km), &
+ inline_mp%rrs (is:ie, j, kmp:km), inline_mp%tvs (is:ie, j, kmp:km), &
+ inline_mp%pcg (is:ie, j, kmp:km), inline_mp%edg (is:ie, j, kmp:km), &
+ inline_mp%oeg (is:ie, j, kmp:km), &
+ inline_mp%rrg (is:ie, j, kmp:km), inline_mp%tvg (is:ie, j, kmp:km), &
+ inline_mp%prefluxw(is:ie, j, kmp:km), &
+ inline_mp%prefluxr(is:ie, j, kmp:km), inline_mp%prefluxi(is:ie, j, kmp:km), &
+ inline_mp%prefluxs(is:ie, j, kmp:km), inline_mp%prefluxg(is:ie, j, kmp:km), &
+ 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)
+
+ ! update non-microphyiscs tracers due to mass change
+ if (adj_mass_vmr) then
+ do m = 1, nq
+ if (conv_vmr_mmr (m)) then
+ q (is:ie, j, kmp:km, m) = q (is:ie, j, kmp:km, m) * adj_vmr (is:ie, kmp:km)
+ endif
+ enddo
+ endif
+
+ ! update vertical velocity
+ if (.not. hydrostatic) then
+ w (is:ie, j, kmp:km) = wa (is:ie, kmp:km)
+ endif
+
+ ! compute wind tendency at A grid fori D grid wind update
+ u_dt (is:ie, j, kmp:km) = (ua (is:ie, j, kmp:km) - u_dt (is:ie, j, kmp:km)) / abs (mdt)
+ v_dt (is:ie, j, kmp:km) = (va (is:ie, j, kmp:km) - v_dt (is:ie, j, kmp:km)) / abs (mdt)
+
+ ! update layer thickness
+ if (.not. hydrostatic) then
+ delz (is:ie, j, kmp:km) = dz (is:ie, kmp:km)
+ endif
+
+ ! tendencies diagnostic
+ if (allocated (inline_mp%liq_wat_dt)) inline_mp%liq_wat_dt (is:ie, j, kmp:km) = &
+ inline_mp%liq_wat_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, liq_wat)
+ if (allocated (inline_mp%ice_wat_dt)) inline_mp%ice_wat_dt (is:ie, j, kmp:km) = &
+ inline_mp%ice_wat_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, ice_wat)
+ if (allocated (inline_mp%qv_dt)) inline_mp%qv_dt (is:ie, j, kmp:km) = &
+ inline_mp%qv_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, sphum)
+ if (allocated (inline_mp%ql_dt)) inline_mp%ql_dt (is:ie, j, kmp:km) = &
+ inline_mp%ql_dt (is:ie, j, kmp:km) + (q (is:ie, j, kmp:km, liq_wat) + &
+ q (is:ie, j, kmp:km, rainwat))
+ if (allocated (inline_mp%qi_dt)) inline_mp%qi_dt (is:ie, j, kmp:km) = &
+ inline_mp%qi_dt (is:ie, j, kmp:km) + (q (is:ie, j, kmp:km, ice_wat) + &
+ q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel))
+ if (allocated (inline_mp%qr_dt)) inline_mp%qr_dt (is:ie, j, kmp:km) = &
+ inline_mp%qr_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, rainwat)
+ if (allocated (inline_mp%qs_dt)) inline_mp%qs_dt (is:ie, j, kmp:km) = &
+ inline_mp%qs_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, snowwat)
+ if (allocated (inline_mp%qg_dt)) inline_mp%qg_dt (is:ie, j, kmp:km) = &
+ inline_mp%qg_dt (is:ie, j, kmp:km) + q (is:ie, j, kmp:km, graupel)
+ if (allocated (inline_mp%t_dt)) inline_mp%t_dt (is:ie, j, kmp:km) = &
+ inline_mp%t_dt (is:ie, j, kmp:km) + pt (is:ie, j, kmp:km)
+ if (allocated (inline_mp%u_dt)) inline_mp%u_dt (is:ie, j, kmp:km) = &
+ inline_mp%u_dt (is:ie, j, kmp:km) + ua (is:ie, j, kmp:km)
+ if (allocated (inline_mp%v_dt)) inline_mp%v_dt (is:ie, j, kmp:km) = &
+ inline_mp%v_dt (is:ie, j, kmp:km) + va (is:ie, j, kmp:km)
+
+ ! update pkz
+ if (.not. hydrostatic) then
+#ifdef MOIST_CAPPA
+ pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * &
+ log (rrg * delp (is:ie, j, kmp:km) / &
+ delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
+#else
+ pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / &
+ delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
+#endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat)
+ qsol (is:ie, kmp:km) = q (is:ie, j, kmp:km, ice_wat) + q (is:ie, j, kmp:km, snowwat) + q (is:ie, j, kmp:km, graupel)
+ te_end (is:ie, kmp:km) = 0.0
+ tw_end (is:ie, kmp:km) = 0.0
+ te_b_end (is:ie) = 0.0
+ tw_b_end (is:ie) = 0.0
+ do i = is, ie
+ tz (kmp:km) = pt (i, j, kmp:km) / ((1. + r_vir * q (i, j, kmp:km, sphum)) * (1. - (qliq (i, kmp:km) + qsol (i, kmp:km))))
+ if (hydrostatic) then
+ wz (kmp:km) = 0.0
+ else
+ wz (kmp:km) = w (i, j, kmp:km)
+ endif
+ call mtetw (kmp, km, q (i, j, kmp:km, sphum), q (i, j, kmp:km, liq_wat), &
+ q (i, j, kmp:km, rainwat), q (i, j, kmp:km, ice_wat), q (i, j, kmp:km, snowwat), &
+ q (i, j, kmp:km, graupel), tz (kmp:km), ua (i, j, kmp:km), va (i, j, kmp:km), wz (kmp:km), &
+ delp (i, j, kmp:km), gsize (i), dte (i), 0.0, inline_mp%prew (i, j), &
+ inline_mp%prer (i, j), inline_mp%prei (i, j), inline_mp%pres (i, j), &
+ inline_mp%preg (i, j), 0.0, 0.0, abs (mdt), te_end (i, kmp:km), tw_end (i, kmp:km), &
+ te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
+ enddo
+ endif
+
+ ! add total energy change to te0_2d
+ if (consv .gt. consv_min) then
+ do i = is, ie
+ do k = kmp, km
+ te0_2d (i, j) = te0_2d (i, j) + te (i, j, k)
+ enddo
+ enddo
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ do i = is, ie
+ if (abs (sum (te_end (i, kmp:km)) + te_b_end (i) - sum (te_beg (i, kmp:km)) - te_b_beg (i)) / &
+ (sum (te_beg (i, kmp:km)) + te_b_beg (i)) .gt. te_err) then
+ print*, "GFDL-MP-INTM TE: ", &
+ !(sum (te_beg (i, kmp:km)) + te_b_beg (i)) / (gsize (i) ** 2), &
+ !(sum (te_end (i, kmp:km)) + te_b_end (i)) / (gsize (i) ** 2), &
+ (sum (te_end (i, kmp:km)) + te_b_end (i) - sum (te_beg (i, kmp:km)) - te_b_beg (i)) / &
+ (sum (te_beg (i, kmp:km)) + te_b_beg (i))
+ endif
+ if (abs (sum (tw_end (i, kmp:km)) + tw_b_end (i) - sum (tw_beg (i, kmp:km)) - tw_b_beg (i)) / &
+ (sum (tw_beg (i, kmp:km)) + tw_b_beg (i)) .gt. tw_err) then
+ print*, "GFDL-MP-INTM TW: ", &
+ !(sum (tw_beg (i, kmp:km)) + tw_b_beg (i)) / (gsize (i) ** 2), &
+ !(sum (tw_end (i, kmp:km)) + tw_b_end (i)) / (gsize (i) ** 2), &
+ (sum (tw_end (i, kmp:km)) + tw_b_end (i) - sum (tw_beg (i, kmp:km)) - tw_b_beg (i)) / &
+ (sum (tw_beg (i, kmp:km)) + tw_b_beg (i))
+ endif
+ !print*, "GFDL-MP-INTM LOSS (%) : ", te_loss (i) / (sum (te_beg (i, kmp:km)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ deallocate (dz)
+ deallocate (wa)
+
+ ! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ if ( gridstruct%square_domain ) then
+ call mpp_update_domains (u_dt, domain, whalo=1, ehalo=1, shalo=1, nhalo=1, complete=.false.)
+ call mpp_update_domains (v_dt, domain, whalo=1, ehalo=1, shalo=1, nhalo=1, complete=.true.)
+ else
+ call mpp_update_domains (u_dt, domain, complete=.false.)
+ call mpp_update_domains (v_dt, domain, complete=.true.)
+ endif
+ ! update u_dt and v_dt in halo
+ call mpp_update_domains (u_dt, v_dt, domain)
+
+ ! update D grid wind
+ call update_dwinds_phys (is, ie, js, je, isd, ied, jsd, jed, abs (mdt), u_dt, v_dt, u, v, &
+ gridstruct, npx, npy, km, domain)
+
+ deallocate (u_dt)
+ deallocate (v_dt)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ ! 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, &
+!$OMP 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) + 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))) - dp0 (i, j, k) * &
+ (0.25 * gridstruct%rsin2 (i, j) * (u0 (i, j, k) ** 2 + &
+ u0 (i, j+1, k) ** 2 + v0 (i, j, k) ** 2 + v0 (i+1, j, k) ** 2 - &
+ (u0 (i, j, k) + u0 (i, j+1, k)) * (v0 (i, j, k) + v0 (i+1, j, k)) * &
+ gridstruct%cosa_s (i, j)))
+ enddo
+ enddo
+ else
+ do i = is, ie
+ 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
+ do i = is, ie
+ 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)))) - dp0 (i, j, k) * &
+ (0.5 * (phis (i, k) + phis (i, k+1) + w (i, j, k) ** 2 + &
+ 0.5 * gridstruct%rsin2 (i, j) * (u0 (i, j, k) ** 2 + &
+ u0 (i, j+1, k) ** 2 + v0 (i, j, k) ** 2 + v0 (i+1, j, k) ** 2 - &
+ (u0 (i, j, k) + u0 (i, j+1, k)) * (v0 (i, j, k) + v0 (i+1, j, k)) * &
+ gridstruct%cosa_s (i, j))))
+ enddo
+ enddo
+ endif
+ enddo
+ end if
+
+ if (consv .gt. consv_min) then
+ deallocate (u0)
+ deallocate (v0)
+ deallocate (dp0)
+ endif
+
+ call timing_off ('gfdl_mp')
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Inline GFDL MP
+ !-----------------------------------------------------------------------
+
+end subroutine intermediate_phys
+
+end module intermediate_phys_mod
diff --git a/tools/coarse_grained_diagnostics.F90 b/tools/coarse_grained_diagnostics.F90
index 55e4393b6..432fd79e1 100644
--- a/tools/coarse_grained_diagnostics.F90
+++ b/tools/coarse_grained_diagnostics.F90
@@ -31,7 +31,7 @@ module coarse_grained_diagnostics_mod
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, &
+ vertical_remapping_requirements, mask_area_weights, &
block_edge_sum_x, block_edge_sum_y,&
eddy_covariance_2d_weights, eddy_covariance_3d_weights
@@ -1206,15 +1206,10 @@ subroutine fv_coarse_diag(Atm, Time, zvir)
call get_need_nd_work_array(2, need_2d_work_array)
call get_need_nd_work_array(3, need_3d_work_array)
- call get_need_mass_array(need_mass_array)
+ call get_need_mass_array(Atm(tile_count)%coarse_graining%strategy, need_mass_array)
call get_need_height_array(need_height_array)
call get_need_vorticity_array(need_vorticity_array)
-
- if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL) then
- call get_need_masked_area_array(need_masked_area_array)
- else
- need_masked_area_array = .false.
- endif
+ call get_need_masked_area_array(Atm(tile_count)%coarse_graining%strategy, need_masked_area_array)
call get_fine_array_bounds(is, ie, js, je)
call get_coarse_array_bounds(is_coarse, ie_coarse, js_coarse, je_coarse)
@@ -1245,16 +1240,7 @@ subroutine fv_coarse_diag(Atm, Time, zvir)
if (need_mass_array) then
allocate(mass(is:ie,js:je,1:npz))
- if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. MODEL_LEVEL) then
- call compute_mass(Atm(tile_count), is, ie, js, je, npz, mass)
- else if (trim(Atm(tile_count)%coarse_graining%strategy) .eq. PRESSURE_LEVEL) then
- call mask_mass_weights( &
- Atm(tile_count)%gridstruct%area(is:ie,js:je), &
- Atm(tile_count)%delp(is:ie,js:je,1:npz), &
- phalf, &
- upsampled_coarse_phalf, &
- mass)
- endif
+ call compute_mass(Atm(tile_count), is, ie, js, je, npz, mass)
endif
if (need_masked_area_array) then
@@ -1306,7 +1292,7 @@ subroutine fv_coarse_diag(Atm, Time, zvir)
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, &
+ coarse_diagnostics(index), masked_area, phalf, &
upsampled_coarse_phalf, Atm(tile_count)%ptop, &
Atm(tile_count)%omga(is:ie,js:je,1:npz),&
work_3d_coarse)
@@ -1359,11 +1345,11 @@ 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, &
+ npz, coarse_diag, masked_area, 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) :: 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)
@@ -1389,18 +1375,13 @@ subroutine coarse_grain_3D_field_on_pressure_levels(is, ie, js, je, is_coarse, i
remapped_omega)
endif
- if (trim(coarse_diag%reduction_method) .eq. AREA_WEIGHTED) then
+ if ((trim(coarse_diag%reduction_method) .eq. AREA_WEIGHTED) .or. (trim(coarse_diag%reduction_method) .eq. MASS_WEIGHTED)) then
+ ! area-weighted and mass-weighted are equivalent when pressure-level coarse-graining
call weighted_block_average( &
masked_area(is:ie,js:je,1:npz), &
remapped_field(is:ie,js:je,1:npz), &
result &
)
- elseif (trim(coarse_diag%reduction_method) .eq. MASS_WEIGHTED) then
- call weighted_block_average( &
- masked_mass(is:ie,js:je,1:npz), &
- 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), &
@@ -1604,19 +1585,22 @@ subroutine get_need_nd_work_array(dimension, need_nd_work_array)
enddo
end subroutine get_need_nd_work_array
- subroutine get_need_mass_array(need_mass_array)
+ subroutine get_need_mass_array(coarsening_strategy, need_mass_array)
+ character(len=64), intent(in) :: coarsening_strategy
logical, intent(out) :: need_mass_array
+ logical :: valid_strategy, valid_axes, valid_id, valid_reduction_method
integer :: index
need_mass_array = .false.
+ valid_strategy = trim(coarsening_strategy) .eq. MODEL_LEVEL
+ if (.not. valid_strategy) return
do index = 1, DIAG_SIZE
- if ((coarse_diagnostics(index)%axes == 3) .and. &
- (trim(coarse_diagnostics(index)%reduction_method) .eq. MASS_WEIGHTED) .and. &
- (coarse_diagnostics(index)%id > 0)) then
- need_mass_array = .true.
- exit
- endif
+ valid_axes = coarse_diagnostics(index)%axes .eq. 3
+ valid_id = coarse_diagnostics(index)%id .gt. 0
+ valid_reduction_method = trim(coarse_diagnostics(index)%reduction_method) .eq. MASS_WEIGHTED
+ need_mass_array = valid_axes .and. valid_id .and. valid_reduction_method
+ if (need_mass_array) exit
enddo
end subroutine get_need_mass_array
@@ -1653,20 +1637,20 @@ subroutine get_need_vorticity_array(need_vorticity_array)
enddo
end subroutine get_need_vorticity_array
- subroutine get_need_masked_area_array(need_masked_area_array)
+ subroutine get_need_masked_area_array(coarsening_strategy, need_masked_area_array)
+ character(len=64), intent(in) :: coarsening_strategy
logical, intent(out) :: need_masked_area_array
- logical :: valid_axes, valid_reduction_method, valid_id
+ logical :: valid_strategy, valid_axes, valid_id
integer :: index
need_masked_area_array = .false.
+ valid_strategy = trim(coarsening_strategy) .eq. PRESSURE_LEVEL
+ if (.not. valid_strategy) return
do index = 1, DIAG_SIZE
- 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
+ need_masked_area_array = valid_axes .and. valid_id
if (need_masked_area_array) exit
enddo
end subroutine get_need_masked_area_array
diff --git a/tools/coarse_grained_restart_files.F90 b/tools/coarse_grained_restart_files.F90
index 15d3ed51b..b3aaf9e6a 100644
--- a/tools/coarse_grained_restart_files.F90
+++ b/tools/coarse_grained_restart_files.F90
@@ -24,7 +24,7 @@ module coarse_grained_restart_files_mod
use coarse_graining_mod, only: compute_mass_weights, get_coarse_array_bounds,&
get_fine_array_bounds, MODEL_LEVEL, PRESSURE_LEVEL, weighted_block_average, &
weighted_block_edge_average_x, weighted_block_edge_average_y, &
- mask_area_weights, mask_mass_weights, block_upsample, remap_edges_along_x, &
+ mask_area_weights, block_upsample, remap_edges_along_x, &
remap_edges_along_y, vertically_remap_field
use constants_mod, only: GRAV, RDGAS, RVGAS
use field_manager_mod, only: MODEL_ATMOS
@@ -501,23 +501,22 @@ subroutine coarse_grain_restart_data_on_pressure_levels(Atm)
type(fv_atmos_type), intent(inout) :: Atm
real, allocatable, dimension(:,:,:):: phalf, coarse_phalf, coarse_phalf_on_fine
- real, allocatable, dimension(:,:,:) :: masked_mass_weights, masked_area_weights
+ real, allocatable, dimension(:,:,:) :: masked_area_weights
allocate(phalf(is-1:ie+1,js-1:je+1,1:npz+1)) ! Require the halo here for the winds
allocate(coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1))
allocate(coarse_phalf_on_fine(is:ie,js:je,1:npz+1))
- allocate(masked_mass_weights(is:ie,js:je,1:npz))
allocate(masked_area_weights(is:ie,js:je,1:npz))
! delp and delz are coarse-grained on model levels; u, v, W, T, and all the tracers
! are all remapped to surfaces of constant pressure within coarse grid cells before
! coarse graining. At the end, delz and phis are corrected to impose hydrostatic balance.
call compute_pressure_level_coarse_graining_requirements( &
- Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_mass_weights, masked_area_weights)
+ Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights)
call coarse_grain_fv_core_restart_data_on_pressure_levels( &
- Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_mass_weights, masked_area_weights)
+ Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights)
call coarse_grain_fv_tracer_restart_data_on_pressure_levels( &
- Atm, phalf, coarse_phalf_on_fine, masked_mass_weights, masked_area_weights)
+ Atm, phalf, coarse_phalf_on_fine, masked_area_weights)
call coarse_grain_fv_srf_wnd_restart_data(Atm)
if (Atm%flagstruct%fv_land) then
call coarse_grain_mg_drag_restart_data(Atm)
@@ -614,12 +613,12 @@ subroutine coarse_grain_fv_land_restart_data(Atm)
end subroutine coarse_grain_fv_land_restart_data
subroutine coarse_grain_fv_core_restart_data_on_pressure_levels(&
- Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_mass_weights, masked_area_weights)
+ Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights)
type(fv_atmos_type), intent(inout) :: Atm
real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1)
real, intent(in) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1)
real, intent(in) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1)
- real, intent(in), dimension(is:ie,js:je,1:npz) :: masked_mass_weights, masked_area_weights
+ real, intent(in), dimension(is:ie,js:je,1:npz) :: masked_area_weights
real, allocatable :: remapped(:,:,:) ! Will re-use this to save memory
@@ -639,11 +638,11 @@ subroutine coarse_grain_fv_core_restart_data_on_pressure_levels(&
endif
call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), Atm%pt(is:ie,js:je,1:npz), coarse_phalf_on_fine, Atm%ptop, remapped)
- call weighted_block_average(masked_mass_weights, remapped, Atm%coarse_graining%restart%pt)
+ call weighted_block_average(masked_area_weights, remapped, Atm%coarse_graining%restart%pt)
if (.not. Atm%flagstruct%hydrostatic) then
call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), Atm%w(is:ie,js:je,1:npz), coarse_phalf_on_fine, Atm%ptop, remapped)
- call weighted_block_average(masked_mass_weights, remapped, Atm%coarse_graining%restart%w)
+ call weighted_block_average(masked_area_weights, remapped, Atm%coarse_graining%restart%w)
call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%delz(is:ie,js:je,1:npz), Atm%coarse_graining%restart%delz)
if (Atm%flagstruct%hybrid_z) then
call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%ze0(is:ie,js:je,1:npz), Atm%coarse_graining%restart%ze0)
@@ -654,44 +653,36 @@ subroutine coarse_grain_fv_core_restart_data_on_pressure_levels(&
if (Atm%coarse_graining%write_coarse_agrid_vel_rst) then
call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), Atm%ua(is:ie,js:je,1:npz), coarse_phalf_on_fine, Atm%ptop, remapped)
- call weighted_block_average(masked_mass_weights, remapped, Atm%coarse_graining%restart%ua)
+ call weighted_block_average(masked_area_weights, remapped, Atm%coarse_graining%restart%ua)
call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), Atm%va(is:ie,js:je,1:npz), coarse_phalf_on_fine, Atm%ptop, remapped)
- call weighted_block_average(masked_mass_weights, remapped, Atm%coarse_graining%restart%va)
+ call weighted_block_average(masked_area_weights, remapped, Atm%coarse_graining%restart%va)
endif
end subroutine coarse_grain_fv_core_restart_data_on_pressure_levels
subroutine coarse_grain_fv_tracer_restart_data_on_pressure_levels( &
- Atm, phalf, coarse_phalf_on_fine, masked_mass_weights, masked_area_weights)
+ Atm, phalf, coarse_phalf_on_fine, masked_area_weights)
type(fv_atmos_type), intent(inout) :: Atm
real, intent(in) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1)
real, intent(in) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1)
- real, intent(in), dimension(is:ie,js:je,1:npz) :: masked_mass_weights, masked_area_weights
+ real, intent(in), dimension(is:ie,js:je,1:npz) :: masked_area_weights
real, allocatable :: remapped(:,:,:)
- character(len=64) :: tracer_name
integer :: n_tracer
allocate(remapped(is:ie,js:je,1:npz))
do n_tracer = 1, n_prognostic_tracers
- call get_tracer_names(MODEL_ATMOS, n_tracer, tracer_name)
call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), &
Atm%q(is:ie,js:je,1:npz,n_tracer), coarse_phalf_on_fine, Atm%ptop, remapped)
- if (trim(tracer_name) .eq. 'cld_amt') then
- call weighted_block_average(masked_area_weights, &
- remapped, &
- Atm%coarse_graining%restart%q(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer))
- else
- call weighted_block_average(masked_mass_weights, &
- remapped, &
- Atm%coarse_graining%restart%q(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer))
- endif
+ call weighted_block_average(masked_area_weights, &
+ remapped, &
+ Atm%coarse_graining%restart%q(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer))
enddo
do n_tracer = n_prognostic_tracers + 1, n_tracers
call vertically_remap_field(phalf(is:ie,js:je,1:npz+1), &
Atm%qdiag(is:ie,js:je,1:npz,n_tracer), coarse_phalf_on_fine, Atm%ptop, remapped)
- call weighted_block_average(masked_mass_weights, &
+ call weighted_block_average(masked_area_weights, &
remapped, &
Atm%coarse_graining%restart%qdiag(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz,n_tracer))
enddo
@@ -748,12 +739,12 @@ subroutine impose_hydrostatic_balance(Atm, coarse_phalf)
end subroutine impose_hydrostatic_balance
subroutine compute_pressure_level_coarse_graining_requirements( &
- Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_mass_weights, masked_area_weights)
+ Atm, phalf, coarse_phalf, coarse_phalf_on_fine, masked_area_weights)
type(fv_atmos_type), intent(inout) :: Atm
real, intent(out) :: phalf(is-1:ie+1,js-1:je+1,1:npz+1)
real, intent(out) :: coarse_phalf(is_coarse:ie_coarse,js_coarse:je_coarse,1:npz+1)
real, intent(out) :: coarse_phalf_on_fine(is:ie,js:je,1:npz+1)
- real, intent(out), dimension(is:ie,js:je,1:npz) :: masked_mass_weights, masked_area_weights
+ real, intent(out), dimension(is:ie,js:je,1:npz) :: masked_area_weights
! Do a halo update on delp before proceeding here, because the remapping procedure
! for the winds requires interpolating across tile edges.
@@ -762,7 +753,6 @@ subroutine compute_pressure_level_coarse_graining_requirements( &
call weighted_block_average(Atm%gridstruct%area(is:ie,js:je), Atm%delp(is:ie,js:je,1:npz), Atm%coarse_graining%restart%delp)
call compute_phalf(is_coarse, ie_coarse, js_coarse, je_coarse, Atm%coarse_graining%restart%delp, Atm%ptop, coarse_phalf)
call block_upsample(coarse_phalf, coarse_phalf_on_fine, npz+1)
- call mask_mass_weights(Atm%gridstruct%area(is:ie,js:je), Atm%delp(is:ie,js:je,1:npz), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine, masked_mass_weights)
call mask_area_weights(Atm%gridstruct%area(is:ie,js:je), phalf(is:ie,js:je,1:npz+1), coarse_phalf_on_fine, masked_area_weights)
end subroutine compute_pressure_level_coarse_graining_requirements
diff --git a/tools/coarse_graining.F90 b/tools/coarse_graining.F90
index 97bb2f6b4..f7e2c3f41 100644
--- a/tools/coarse_graining.F90
+++ b/tools/coarse_graining.F90
@@ -33,7 +33,7 @@ module coarse_graining_mod
get_coarse_array_bounds, coarse_graining_init, weighted_block_average, &
weighted_block_edge_average_x, weighted_block_edge_average_y, MODEL_LEVEL, &
block_upsample, mask_area_weights, PRESSURE_LEVEL, vertical_remapping_requirements, &
- vertically_remap_field, mask_mass_weights, remap_edges_along_x, remap_edges_along_y, &
+ vertically_remap_field, remap_edges_along_x, remap_edges_along_y, &
block_edge_sum_x, block_edge_sum_y, block_mode, block_min, block_max, &
eddy_covariance, eddy_covariance_2d_weights, eddy_covariance_3d_weights
@@ -1028,25 +1028,6 @@ subroutine mask_area_weights_real8(area, phalf, upsampled_coarse_phalf, masked_a
enddo
end subroutine mask_area_weights_real8
- subroutine mask_mass_weights(area, delp, phalf, upsampled_coarse_phalf, &
- masked_mass_weights)
- real, intent(in) :: area(is:ie,js:je)
- real, intent(in) :: delp(is:ie,js:je,1:npz)
- 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_mass_weights(is:ie,js:je,1:npz)
-
- integer :: k
-
- do k = 1, npz
- where (upsampled_coarse_phalf(:,:,k+1) .lt. phalf(is:ie,js:je,npz+1))
- masked_mass_weights(:,:,k) = delp(:,:,k) * area(:,:)
- elsewhere
- masked_mass_weights(:,:,k) = 0.0
- endwhere
- enddo
- end subroutine mask_mass_weights
-
! A naive routine for interpolating a field from the A-grid to the y-boundary
! of the D-grid; this is a specialized function that automatically
! downsamples to the coarse-grid on the downsampling dimension.
diff --git a/tools/external_aero.F90 b/tools/external_aero.F90
new file mode 100644
index 000000000..9bf2f5400
--- /dev/null
+++ b/tools/external_aero.F90
@@ -0,0 +1,376 @@
+!***********************************************************************
+!* 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 ANYWARRANTY; 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 .
+!***********************************************************************
+
+! =======================================================================
+! this module is designed to read 12 months climatology aerosol and
+! interpolate to daily aerosol
+! developer: linjiong zhou
+! =======================================================================
+
+module external_aero_mod
+
+ use fms_mod, only: file_exist, mpp_error, FATAL
+ use mpp_mod, only: mpp_pe, mpp_root_pe
+ use time_manager_mod, only: time_type
+ use fv_mapz_mod, only: map1_q2
+ use fv_fill_mod, only: fillz
+
+ public :: load_aero, read_aero, clean_aero
+
+ ! MERRA2 aerosol: # month = 12, # vertical layer = 72
+ integer :: nmon = 12, nlev = 72
+ integer :: id_aero, id_aero_now
+
+ ! share arrays for time and level interpolation
+ real, allocatable, dimension(:,:,:) :: aero_ps
+ real, allocatable, dimension(:,:,:,:) :: aero_p
+ real, allocatable, dimension(:,:,:,:) :: aero_pe
+ real, allocatable, dimension(:,:,:,:) :: aero_dp
+ real, allocatable, dimension(:,:,:,:) :: aerosol
+
+contains
+
+! =======================================================================
+! load aerosol 12 months climatological dataset
+
+subroutine load_aero(Atm, Time)
+
+ use fms_io_mod, only: restart_file_type, register_restart_field
+ use fms_io_mod, only: restore_state
+ use fv_arrays_mod, only: fv_atmos_type
+ use diag_manager_mod, only: register_static_field, register_diag_field
+
+ implicit none
+
+ type(time_type), intent(in) :: Time
+ type(fv_atmos_type), intent(in), target :: Atm
+ type(restart_file_type) :: aero_restart
+
+ integer :: k
+ integer :: is, ie, js, je
+ integer :: id_res
+
+ real, allocatable, dimension(:,:,:,:) :: aero_lndp
+
+ character(len=64) :: file_name = "MERRA2_400.inst3_3d_aer_Nv.climatology.nc"
+
+ is = Atm%bd%is
+ ie = Atm%bd%ie
+ js = Atm%bd%js
+ je = Atm%bd%je
+
+ if (mpp_pe() .eq. mpp_root_pe()) then
+ write(*,*) "aerosol 12 months climatological dataset is used for forecast."
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! load aerosol data
+
+ if (file_exist('INPUT/'//trim(file_name),domain=Atm%domain)) then
+
+ ! allocate share arrays
+ if (.not. allocated(aero_ps)) allocate(aero_ps(is:ie,js:je,nmon))
+ if (.not. allocated(aero_p)) allocate(aero_p(is:ie,js:je,nlev,nmon))
+ if (.not. allocated(aero_pe)) allocate(aero_pe(is:ie,js:je,nlev+1,nmon))
+ if (.not. allocated(aero_dp)) allocate(aero_dp(is:ie,js:je,nlev,nmon))
+ if (.not. allocated(aerosol)) allocate(aerosol(is:ie,js:je,nlev,nmon))
+
+ ! read in restart files
+ id_res = register_restart_field(aero_restart,trim(file_name),"PS",&
+ aero_ps,domain=Atm%domain)
+ id_res = register_restart_field(aero_restart,trim(file_name),"DELP",&
+ aero_dp,domain=Atm%domain)
+ id_res = register_restart_field(aero_restart,trim(file_name),"SO4",&
+ aerosol,domain=Atm%domain)
+ call restore_state(aero_restart)
+
+ else
+
+ ! stop when aerosol does not exist
+ call mpp_error("external_aero_mod",&
+ "file: "//trim(file_name)//" does not exist.",FATAL)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! calculate layer mean pressure
+
+ ! allocate local array
+ if (.not. allocated(aero_lndp)) allocate(aero_lndp(is:ie,js:je,nlev,nmon))
+
+ ! calcuate edge pressure
+ aero_p = -999.9
+ aero_pe(:,:,nlev+1,:) = aero_ps
+ do k = nlev, 1, -1
+ aero_pe(:,:,k,:) = aero_pe(:,:,k+1,:) - aero_dp(:,:,k,:)
+ enddo
+
+ ! stop when minimum value is less and equal to zero
+ if (minval(aero_pe) .le. 0.0) then
+ call mpp_error("external_aero_mod","aero_pe has value <= 0.",FATAL)
+ endif
+
+ ! calcuate layer mean pressure
+ do k = 1, nlev
+ aero_lndp(:,:,k,:) = log(aero_pe(:,:,k+1,:)) - log(aero_pe(:,:,k,:))
+ enddo
+ aero_p = aero_dp / aero_lndp
+
+ ! stop when minimum value is less and equal to zero
+ if (minval(aero_p) .le. 0.0) then
+ call mpp_error("external_aero_mod","aero_p has value <= 0.",FATAL)
+ endif
+
+ ! deallocate local array
+ if (allocated(aero_lndp)) deallocate(aero_lndp)
+
+ ! -----------------------------------------------------------------------
+ ! register for diagnostic output
+
+ id_aero = register_static_field('dynamics','aero_ann',&
+ Atm%atmos_axes(1:2),'none','none')
+ id_aero_now= register_diag_field('dynamics','aero_now',&
+ Atm%atmos_axes(1:2),Time,'none','none')
+
+end subroutine load_aero
+
+! =======================================================================
+! read aerosol climatological dataset
+
+subroutine read_aero(is, ie, js, je, npz, nq, Time, pe, peln, qa, kord_tr, fill)
+
+ use constants_mod, only: grav
+ use diag_manager_mod, only: send_data
+ use time_manager_mod, only: get_date, set_date, get_time, operator(-)
+ use tracer_manager_mod, only: get_tracer_index
+ use field_manager_mod, only: MODEL_ATMOS
+
+ implicit none
+
+ type(time_type), intent(in) :: Time
+ type(time_type) :: Time_before
+ type(time_type) :: Time_after
+
+ integer :: i, j, k, n
+ integer, intent(in) :: is, ie, js, je, npz, nq, kord_tr
+ integer :: year, month, day, hour, minute, second
+ integer :: seconds, days01, days21, month1, month2
+ integer :: aero_id
+
+ real, dimension(is:ie,js:je,npz,nq), intent(inout) :: qa
+ real, dimension(is:ie,npz+1,js:je), intent(in) :: pe, peln
+
+ real, allocatable, dimension(:,:) :: vi_aero
+ real, allocatable, dimension(:,:) :: vi_aero_now
+ real, allocatable, dimension(:,:,:) :: aero_now_a
+ real, allocatable, dimension(:,:,:) :: aero_now_p
+ real, allocatable, dimension(:,:,:) :: aero_now_pe
+ real, allocatable, dimension(:,:,:) :: aero_now_dp
+ real, allocatable, dimension(:,:,:) :: pm
+
+ logical :: used, use_fv3_interp = .true.
+ logical, intent (in) :: fill
+
+ ! -----------------------------------------------------------------------
+ ! diagnostic output of annual mean vertical integral aerosol
+
+ if (id_aero > 0) then
+
+ ! allocate local array
+ if (.not. allocated(vi_aero)) allocate(vi_aero(is:ie,js:je))
+
+ ! calcualte annual mean vertical intergral aerosol
+ vi_aero = 0.0
+ do n = 1, nmon
+ do k = 1, nlev
+ vi_aero = vi_aero + aerosol(:,:,k,n) * aero_dp(:,:,k,n)
+ enddo
+ enddo
+ vi_aero = vi_aero / nmon / grav * 1.e6
+
+ ! diagnostic output
+ used = send_data(id_aero,vi_aero,Time)
+
+ ! deallocate local array
+ if (allocated(vi_aero)) deallocate(vi_aero)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! linearly interpolate monthly aerosol to today
+
+ ! allocate local array
+ if (.not. allocated(aero_now_a)) allocate(aero_now_a(is:ie,js:je,nlev))
+ if (.not. allocated(aero_now_p)) allocate(aero_now_p(is:ie,js:je,nlev))
+ if (.not. allocated(aero_now_pe)) allocate(aero_now_pe(is:ie,js:je,nlev+1))
+
+ ! get current date information
+ call get_date(Time, year, month, day, hour, minute, second)
+
+ ! get previous day 15 and next day 15 time
+ if (day .ge. 15) then
+ Time_before = set_date(year, month, 15, 0, 0, 0)
+ if (month .eq. 12) then
+ Time_after = set_date(year+1, 1, 15, 0, 0, 0)
+ else
+ Time_after = set_date(year, month+1, 15, 0, 0, 0)
+ endif
+ else
+ if (month .eq. 1) then
+ Time_before = set_date(year-1, 12, 15, 0, 0, 0)
+ else
+ Time_before = set_date(year, month-1, 15, 0, 0, 0)
+ endif
+ Time_after = set_date(year, month, 15, 0, 0, 0)
+ endif
+
+ ! get day difference between current day and previous day 15,
+ ! and between next day 15 and previous day 15
+ call get_time(Time - Time_before, seconds, days01)
+ call get_time(Time_after - Time_before, seconds, days21)
+ call get_date(Time_before, year, month1, day, hour, minute, second)
+ call get_date(Time_after, year, month2, day, hour, minute, second)
+
+ ! get aerosol for current date
+ aero_now_a = aerosol(:,:,:,month2) - aerosol(:,:,:,month1)
+ aero_now_a = 1.0 * days01 / days21 * aero_now_a + aerosol(:,:,:,month1)
+ aero_now_p = aero_p(:,:,:,month2) - aero_p(:,:,:,month1)
+ aero_now_p = 1.0 * days01 / days21 * aero_now_p + aero_p(:,:,:,month1)
+ aero_now_pe = aero_pe(:,:,:,month2) - aero_pe(:,:,:,month1)
+ aero_now_pe = 1.0 * days01 / days21 * aero_now_pe + aero_pe(:,:,:,month1)
+
+ ! -----------------------------------------------------------------------
+ ! diagnostic output of current vertical integral aerosol
+
+ if (id_aero_now > 0) then
+
+ ! allocate local array
+ if (.not. allocated(vi_aero_now)) allocate(vi_aero_now(is:ie,js:je))
+ if (.not. allocated(aero_now_dp)) allocate(aero_now_dp(is:ie,js:je,nlev))
+
+ ! get pressure thickness for current date
+ aero_now_dp = aero_dp(:,:,:,month2) - aero_dp(:,:,:,month1)
+ aero_now_dp = 1.0 * days01 / days21 * aero_now_dp + aero_dp(:,:,:,month1)
+
+ ! calcualte annual mean vertical intergral aerosol
+ vi_aero_now = 0.0
+ do k = 1, nlev
+ vi_aero_now = vi_aero_now + aero_now_a(:,:,k) * aero_now_dp(:,:,k)
+ enddo
+ vi_aero_now = vi_aero_now / grav * 1.e6
+
+ ! diagnostic output
+ used = send_data(id_aero_now,vi_aero_now,Time)
+
+ ! deallocate local array
+ if (allocated(vi_aero_now)) deallocate(vi_aero_now)
+ if (allocated(aero_now_dp)) deallocate(aero_now_dp)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! vertically interpolate aeorosol
+
+ ! allocate local array
+ if (.not. allocated(pm)) allocate(pm(is:ie,js:je,npz))
+
+ ! calculate layer mean pressure
+ do k = 1, npz
+ pm(:,:,k) = (pe(:,k+1,:) - pe(:,k,:)) / (peln(:,k+1,:) - peln(:,k,:))
+ enddo
+
+ ! stop when minimum value is less and equal to zero
+ if (minval(pm) .le. 0.0) then
+ call mpp_error("external_aero_mod","pm has value <= 0.",FATAL)
+ endif
+
+ ! get aerosol tracer id
+ aero_id = get_tracer_index(MODEL_ATMOS, 'aerosol')
+
+ ! vertically interpolation
+ if (use_fv3_interp) then
+ do j = js, je
+ call map1_q2 (nlev, aero_now_pe (is:ie, j, :), aero_now_a (is:ie, js:je, :), &
+ npz, pe (is:ie, :, j), qa (is:ie, j, :, aero_id), &
+ pe (is:ie, 2:npz+1, j) - pe (is:ie, 1:npz, j), &
+ is, ie, 0, kord_tr, j, is, ie, js, je, 0., .false.)
+ if (fill) call fillz (ie-is+1, npz, 1, qa (is:ie, j, :, aero_id), &
+ pe (is:ie, 2:npz+1, j) - pe (is:ie, 1:npz, j))
+ enddo
+ else
+ do j = js, je
+ do i = is, ie
+ do k = 1, npz
+ if (pm(i,j,k) .lt. aero_now_p(i,j,1)) then
+ qa(i,j,k,aero_id) = aero_now_a(i,j,1)
+ !qa(i,j,k,aero_id) = aero_now_a(i,j,1) + &
+ ! (log(pm(i,j,k)) - log(aero_now_p(i,j,1))) / &
+ ! (log(aero_now_p(i,j,2)) - log(aero_now_p(i,j,1))) * &
+ ! (aero_now_a(i,j,2) - aero_now_a(i,j,1))
+ else if (pm(i,j,k) .ge. aero_now_p(i,j,nlev)) then
+ qa(i,j,k,aero_id) = aero_now_a(i,j,nlev)
+ !qa(i,j,k,aero_id) = aero_now_a(i,j,nlev-1) + &
+ ! (log(pm(i,j,k)) - log(aero_now_p(i,j,nlev-1))) / &
+ ! (log(aero_now_p(i,j,nlev)) - log(aero_now_p(i,j,nlev-1))) * &
+ ! (aero_now_a(i,j,nlev) - aero_now_a(i,j,nlev-1))
+ else
+ do n = 1, nlev-1
+ if (pm(i,j,k) .ge. aero_now_p(i,j,n) .and. &
+ pm(i,j,k) .lt. aero_now_p(i,j,n+1)) then
+ qa(i,j,k,aero_id) = aero_now_a(i,j,n) + &
+ (log(pm(i,j,k)) - log(aero_now_p(i,j,n))) / &
+ (log(aero_now_p(i,j,n+1)) - log(aero_now_p(i,j,n))) * &
+ (aero_now_a(i,j,n+1) - aero_now_a(i,j,n))
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! deallocate local array
+ if (allocated(pm)) deallocate(pm)
+
+ ! -----------------------------------------------------------------------
+ ! deallocate local array
+
+ if (allocated(aero_now_a)) deallocate(aero_now_a)
+ if (allocated(aero_now_p)) deallocate(aero_now_p)
+
+end subroutine read_aero
+
+! =======================================================================
+! clean aerosol climatological dataset
+
+subroutine clean_aero()
+
+ implicit none
+
+ if (allocated(aero_ps)) deallocate(aero_ps)
+ if (allocated(aero_p)) deallocate(aero_p)
+ if (allocated(aero_pe)) deallocate(aero_pe)
+ if (allocated(aero_dp)) deallocate(aero_dp)
+ if (allocated(aerosol)) deallocate(aerosol)
+
+end subroutine clean_aero
+
+end module external_aero_mod
diff --git a/tools/external_ic.F90 b/tools/external_ic.F90
index 328e6f1cd..b69a6d9ad 100644
--- a/tools/external_ic.F90
+++ b/tools/external_ic.F90
@@ -45,7 +45,7 @@ module external_ic_mod
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_diagnostics_mod,only: prt_maxmin, prt_mxm, prt_gb_nh_sh, prt_height
use fv_grid_utils_mod, only: ptop_min, g_sum,mid_pt_sphere,get_unit_vect2,get_latlon_vector,inner_prod
use fv_io_mod, only: fv_io_read_tracers
use fv_mapz_mod, only: mappm
@@ -69,7 +69,8 @@ module external_ic_mod
use boundary_mod, only: nested_grid_BC, extrapolation_BC
use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_global_domain, mpp_get_compute_domain
-
+ use fv_grid_utils_mod, only: cubed_a2d
+
implicit none
private
@@ -182,10 +183,10 @@ subroutine get_external_ic( Atm, cold_start, icdir )
call get_fv_ic( Atm, nq )
endif
- call prt_maxmin('PS', Atm%ps, is, ie, js, je, ng, 1, 0.01)
- 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.)
+ call prt_mxm('PS', Atm%ps, is, ie, js, je, ng, 1, 0.01, Atm%gridstruct%area_64, Atm%domain)
+ call prt_mxm('T', Atm%pt, is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
+ if (.not.Atm%flagstruct%hydrostatic) call prt_mxm('W', Atm%w, is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
+ call prt_mxm('SPHUM', Atm%q(:,:,:,1), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
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')
@@ -197,21 +198,21 @@ subroutine get_external_ic( Atm, cold_start, icdir )
sgs_tke = get_tracer_index(MODEL_ATMOS, 'sgs_tke')
cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt')
if ( liq_wat > 0 ) &
- call prt_maxmin('liq_wat', Atm%q(:,:,:,liq_wat), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('liq_wat', Atm%q(:,:,:,liq_wat), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( ice_wat > 0 ) &
- call prt_maxmin('ice_wat', Atm%q(:,:,:,ice_wat), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('ice_wat', Atm%q(:,:,:,ice_wat), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( rainwat > 0 ) &
- call prt_maxmin('rainwat', Atm%q(:,:,:,rainwat), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('rainwat', Atm%q(:,:,:,rainwat), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( snowwat > 0 ) &
- call prt_maxmin('snowwat', Atm%q(:,:,:,snowwat), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('snowwat', Atm%q(:,:,:,snowwat), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( graupel > 0 ) &
- call prt_maxmin('graupel', Atm%q(:,:,:,graupel), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('graupel', Atm%q(:,:,:,graupel), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( o3mr > 0 ) &
- call prt_maxmin('O3MR', Atm%q(:,:,:,o3mr), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('O3MR', Atm%q(:,:,:,o3mr), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( sgs_tke > 0 ) &
- call prt_maxmin('sgs_tke', Atm%q(:,:,:,sgs_tke), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('sgs_tke', Atm%q(:,:,:,sgs_tke), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
if ( cld_amt > 0 ) &
- call prt_maxmin('cld_amt', Atm%q(:,:,:,cld_amt), is, ie, js, je, ng, Atm%npz, 1.)
+ call prt_mxm('cld_amt', Atm%q(:,:,:,cld_amt), is, ie, js, je, ng, Atm%npz, 1., Atm%gridstruct%area_64, Atm%domain)
endif
end subroutine get_external_ic
@@ -268,7 +269,7 @@ subroutine get_cubed_sphere_terrain( Atm )
call mpp_update_domains( Atm%phis, Atm%domain )
ftop = g_sum(Atm%domain, Atm%phis(is:ie,js:je), is, ie, js, je, ng, Atm%gridstruct%area_64, 1)
- call prt_maxmin('ZS', Atm%phis, is, ie, js, je, ng, 1, 1./grav)
+ call prt_mxm('ZS', Atm%phis, is, ie, js, je, ng, 1, 1./grav, Atm%gridstruct%area_64, Atm%domain)
if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav
end subroutine get_cubed_sphere_terrain
@@ -1477,7 +1478,7 @@ subroutine get_ncep_ic( Atm, nq )
s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1)
enddo
enddo
- call prt_maxmin('SST_model', Atm%ts, is, ie, js, je, 0, 1, 1.)
+ call prt_mxm('SST_model', Atm%ts, is, ie, js, je, 0, 1, 1., Atm%gridstruct%area_64, Atm%domain)
! Perform interp to FMS SST format/grid
#ifndef DYCORE_SOLO
@@ -1807,7 +1808,7 @@ subroutine get_ecmwf_ic( Atm )
jsd = Atm%bd%jsd
jed = Atm%bd%jed
- call open_ncfile( trim(inputdir)//'/'//trim(fn_gfs_ctl), ncid )
+ call open_ncfile( trim(fn_gfs_ctl), ncid )
call get_ncdim1( ncid, 'levsp', levsp )
call close_ncfile( ncid )
levp_gfs = levsp-1
@@ -1892,7 +1893,7 @@ subroutine get_ecmwf_ic( Atm )
call register_axis(GFS_restart, "levp", size(zh_gfs,3))
call register_restart_field(GFS_restart, 'o3mr', o3mr_gfs, dim_names_3d3, is_optional=.true.)
call register_restart_field(GFS_restart, 'ps', ps_gfs, dim_names_2d)
- call register_restart_field(GFS_restart, 'ZH', zh_gfs, dim_names_3d4)
+ call register_restart_field(GFS_restart, 'zh', zh_gfs, dim_names_3d4)
call read_restart(GFS_restart)
call close_file(GFS_restart)
endif
@@ -3360,9 +3361,9 @@ subroutine remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm)
5000 continue
- call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1.)
- call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1.)
- call prt_maxmin('UA_top',ut(:,:,1), is, ie, js, je, ng, 1, 1.)
+ call prt_mxm('UT', ut, is, ie, js, je, ng, npz, 1., Atm%gridstruct%area_64, Atm%domain)
+ call prt_mxm('VT', vt, is, ie, js, je, ng, npz, 1., Atm%gridstruct%area_64, Atm%domain)
+ call prt_mxm('UA_top',ut(:,:,1), is, ie, js, je, ng, 1, 1., Atm%gridstruct%area_64, Atm%domain)
!----------------------------------------------
! winds: lat-lon ON A to Cubed-D transformation:
@@ -3621,9 +3622,9 @@ subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0
5000 continue
- call prt_maxmin('PS_model', Atm%ps, is, ie, js, je, ng, 1, 0.01)
- call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1.)
- call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1.)
+ call prt_mxm('PS_model', Atm%ps, is, ie, js, je, ng, 1, 0.01, Atm%gridstruct%area_64, Atm%domain)
+ call prt_mxm('UT', ut, is, ie, js, je, ng, npz, 1., Atm%gridstruct%area_64, Atm%domain)
+ call prt_mxm('VT', vt, is, ie, js, je, ng, npz, 1., Atm%gridstruct%area_64, Atm%domain)
!----------------------------------------------
! winds: lat-lon ON A to Cubed-D transformation:
@@ -3634,195 +3635,6 @@ subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0
end subroutine remap_xyz
-
- subroutine cubed_a2d( npx, npy, npz, ua, va, u, v, gridstruct, fv_domain, bd )
-
-! Purpose; Transform wind on A grid to D grid
-
- use mpp_domains_mod, only: mpp_update_domains
-
- type(fv_grid_bounds_type), intent(IN) :: bd
- integer, intent(in):: npx, npy, npz
- real, intent(inout), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: ua, va
- real, intent(out):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1,npz)
- real, intent(out):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
- type(fv_grid_type), intent(IN), target :: gridstruct
- type(domain2d), intent(INOUT) :: fv_domain
-! local:
- real v3(3,bd%is-1:bd%ie+1,bd%js-1:bd%je+1)
- real ue(3,bd%is-1:bd%ie+1,bd%js:bd%je+1) ! 3D winds at edges
- real ve(3,bd%is:bd%ie+1,bd%js-1:bd%je+1) ! 3D winds at edges
- real, dimension(bd%is:bd%ie):: ut1, ut2, ut3
- real, dimension(bd%js:bd%je):: vt1, vt2, vt3
- integer i, j, k, im2, jm2
-
- real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat
- real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n
- real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
-
- integer :: is, ie, js, je
- integer :: isd, ied, jsd, jed
-
- is = bd%is
- ie = bd%ie
- js = bd%js
- je = bd%je
- isd = bd%isd
- ied = bd%ied
- jsd = bd%jsd
- jed = bd%jed
-
- vlon => gridstruct%vlon
- vlat => gridstruct%vlat
-
- edge_vect_w => gridstruct%edge_vect_w
- edge_vect_e => gridstruct%edge_vect_e
- edge_vect_s => gridstruct%edge_vect_s
- edge_vect_n => gridstruct%edge_vect_n
-
- ew => gridstruct%ew
- es => gridstruct%es
-
- call mpp_update_domains(ua, fv_domain, complete=.false.)
- call mpp_update_domains(va, fv_domain, complete=.true.)
-
- im2 = (npx-1)/2
- jm2 = (npy-1)/2
-
- do k=1, npz
-! Compute 3D wind on A grid
- do j=js-1,je+1
- do i=is-1,ie+1
- v3(1,i,j) = ua(i,j,k)*vlon(i,j,1) + va(i,j,k)*vlat(i,j,1)
- v3(2,i,j) = ua(i,j,k)*vlon(i,j,2) + va(i,j,k)*vlat(i,j,2)
- v3(3,i,j) = ua(i,j,k)*vlon(i,j,3) + va(i,j,k)*vlat(i,j,3)
- enddo
- enddo
-
-! A --> D
-! Interpolate to cell edges
- do j=js,je+1
- do i=is-1,ie+1
- ue(1,i,j) = 0.5*(v3(1,i,j-1) + v3(1,i,j))
- ue(2,i,j) = 0.5*(v3(2,i,j-1) + v3(2,i,j))
- ue(3,i,j) = 0.5*(v3(3,i,j-1) + v3(3,i,j))
- enddo
- enddo
-
- do j=js-1,je+1
- do i=is,ie+1
- ve(1,i,j) = 0.5*(v3(1,i-1,j) + v3(1,i,j))
- ve(2,i,j) = 0.5*(v3(2,i-1,j) + v3(2,i,j))
- ve(3,i,j) = 0.5*(v3(3,i-1,j) + v3(3,i,j))
- enddo
- enddo
-
-! --- E_W edges (for v-wind):
- if (.not. gridstruct%bounded_domain) then
- if ( is==1) then
- i = 1
- do j=js,je
- if ( j>jm2 ) then
- vt1(j) = edge_vect_w(j)*ve(1,i,j-1)+(1.-edge_vect_w(j))*ve(1,i,j)
- vt2(j) = edge_vect_w(j)*ve(2,i,j-1)+(1.-edge_vect_w(j))*ve(2,i,j)
- vt3(j) = edge_vect_w(j)*ve(3,i,j-1)+(1.-edge_vect_w(j))*ve(3,i,j)
- else
- vt1(j) = edge_vect_w(j)*ve(1,i,j+1)+(1.-edge_vect_w(j))*ve(1,i,j)
- vt2(j) = edge_vect_w(j)*ve(2,i,j+1)+(1.-edge_vect_w(j))*ve(2,i,j)
- vt3(j) = edge_vect_w(j)*ve(3,i,j+1)+(1.-edge_vect_w(j))*ve(3,i,j)
- endif
- enddo
- do j=js,je
- ve(1,i,j) = vt1(j)
- ve(2,i,j) = vt2(j)
- ve(3,i,j) = vt3(j)
- enddo
- endif
-
- if ( (ie+1)==npx ) then
- i = npx
- do j=js,je
- if ( j>jm2 ) then
- vt1(j) = edge_vect_e(j)*ve(1,i,j-1)+(1.-edge_vect_e(j))*ve(1,i,j)
- vt2(j) = edge_vect_e(j)*ve(2,i,j-1)+(1.-edge_vect_e(j))*ve(2,i,j)
- vt3(j) = edge_vect_e(j)*ve(3,i,j-1)+(1.-edge_vect_e(j))*ve(3,i,j)
- else
- vt1(j) = edge_vect_e(j)*ve(1,i,j+1)+(1.-edge_vect_e(j))*ve(1,i,j)
- vt2(j) = edge_vect_e(j)*ve(2,i,j+1)+(1.-edge_vect_e(j))*ve(2,i,j)
- vt3(j) = edge_vect_e(j)*ve(3,i,j+1)+(1.-edge_vect_e(j))*ve(3,i,j)
- endif
- enddo
- do j=js,je
- ve(1,i,j) = vt1(j)
- ve(2,i,j) = vt2(j)
- ve(3,i,j) = vt3(j)
- enddo
- endif
-
-! N-S edges (for u-wind):
- if ( js==1 ) then
- j = 1
- do i=is,ie
- if ( i>im2 ) then
- ut1(i) = edge_vect_s(i)*ue(1,i-1,j)+(1.-edge_vect_s(i))*ue(1,i,j)
- ut2(i) = edge_vect_s(i)*ue(2,i-1,j)+(1.-edge_vect_s(i))*ue(2,i,j)
- ut3(i) = edge_vect_s(i)*ue(3,i-1,j)+(1.-edge_vect_s(i))*ue(3,i,j)
- else
- ut1(i) = edge_vect_s(i)*ue(1,i+1,j)+(1.-edge_vect_s(i))*ue(1,i,j)
- ut2(i) = edge_vect_s(i)*ue(2,i+1,j)+(1.-edge_vect_s(i))*ue(2,i,j)
- ut3(i) = edge_vect_s(i)*ue(3,i+1,j)+(1.-edge_vect_s(i))*ue(3,i,j)
- endif
- enddo
- do i=is,ie
- ue(1,i,j) = ut1(i)
- ue(2,i,j) = ut2(i)
- ue(3,i,j) = ut3(i)
- enddo
- endif
-
- if ( (je+1)==npy ) then
- j = npy
- do i=is,ie
- if ( i>im2 ) then
- ut1(i) = edge_vect_n(i)*ue(1,i-1,j)+(1.-edge_vect_n(i))*ue(1,i,j)
- ut2(i) = edge_vect_n(i)*ue(2,i-1,j)+(1.-edge_vect_n(i))*ue(2,i,j)
- ut3(i) = edge_vect_n(i)*ue(3,i-1,j)+(1.-edge_vect_n(i))*ue(3,i,j)
- else
- ut1(i) = edge_vect_n(i)*ue(1,i+1,j)+(1.-edge_vect_n(i))*ue(1,i,j)
- ut2(i) = edge_vect_n(i)*ue(2,i+1,j)+(1.-edge_vect_n(i))*ue(2,i,j)
- ut3(i) = edge_vect_n(i)*ue(3,i+1,j)+(1.-edge_vect_n(i))*ue(3,i,j)
- endif
- enddo
- do i=is,ie
- ue(1,i,j) = ut1(i)
- ue(2,i,j) = ut2(i)
- ue(3,i,j) = ut3(i)
- enddo
- endif
-
- endif ! .not. bounded_domain
-
- do j=js,je+1
- do i=is,ie
- u(i,j,k) = ue(1,i,j)*es(1,i,j,1) + &
- ue(2,i,j)*es(2,i,j,1) + &
- ue(3,i,j)*es(3,i,j,1)
- enddo
- enddo
- do j=js,je
- do i=is,ie+1
- v(i,j,k) = ve(1,i,j)*ew(1,i,j,2) + &
- ve(2,i,j)*ew(2,i,j,2) + &
- ve(3,i,j)*ew(3,i,j,2)
- enddo
- enddo
-
- enddo ! k-loop
-
- end subroutine cubed_a2d
-
-
-
subroutine d2a3d(u, v, ua, va, im, jm, km, lon)
integer, intent(in):: im, jm, km ! Dimensions
real, intent(in ) :: lon(im)
diff --git a/tools/fv_diag_column.F90 b/tools/fv_diag_column.F90
index 0ece9fd6f..8c021a1e0 100644
--- a/tools/fv_diag_column.F90
+++ b/tools/fv_diag_column.F90
@@ -29,7 +29,7 @@ module fv_diag_column_mod
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
+ use gfdl_mp_mod, only: mqs3d
implicit none
private
@@ -584,7 +584,7 @@ subroutine sounding_column( pt, delp, delz, u, v, q, peln, pkz, thetae, phis, &
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), &
+ call mqs3d(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
diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90
index 1d59c63c9..93f3ae588 100644
--- a/tools/fv_diagnostics.F90
+++ b/tools/fv_diagnostics.F90
@@ -41,17 +41,15 @@ module fv_diagnostics_mod
use fv_grid_utils_mod, only: g_sum
use a2b_edge_mod, only: a2b_ord2, a2b_ord4
use fv_surf_map_mod, only: zs_g
- use fv_sg_mod, only: qsmith
use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
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: wqs, mqs3d, qs_init, c_liq, rad_ref
- use rad_ref_mod, only: rad_ref
use fv_diag_column_mod, only: fv_diag_column_init, sounding_column, debug_column
implicit none
@@ -557,12 +555,24 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
allocate(id_t(nplev))
allocate(id_h(nplev))
allocate(id_q(nplev))
+ allocate(id_ql(nplev))
+ allocate(id_qi(nplev))
+ allocate(id_qr(nplev))
+ allocate(id_qs(nplev))
+ allocate(id_qg(nplev))
+ allocate(id_cf(nplev))
allocate(id_omg(nplev))
id_u(:) = 0
id_v(:) = 0
id_t(:) = 0
id_h(:) = 0
id_q(:) = 0
+ id_ql(:) = 0
+ id_qi(:) = 0
+ id_qr(:) = 0
+ id_qs(:) = 0
+ id_qg(:) = 0
+ id_cf(:) = 0
id_omg(:) = 0
! do n = 1, ntileMe
@@ -595,8 +605,10 @@ 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, &
+ id_pret = register_diag_field ( trim(field), 'pret', axes(1:2), Time, &
'total precipitation', 'mm/day', missing_value=missing_value )
+ id_prew = register_diag_field ( trim(field), 'prew', axes(1:2), Time, &
+ 'water 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, &
@@ -605,6 +617,16 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'snow precipitation', 'mm/day', missing_value=missing_value )
id_preg = register_diag_field ( trim(field), 'preg', axes(1:2), Time, &
'graupel precipitation', 'mm/day', missing_value=missing_value )
+ id_prefluxw = register_diag_field ( trim(field), 'prefluxw', axes(1:3), Time, &
+ 'water precipitation flux', 'mm/day', missing_value=missing_value )
+ id_prefluxr = register_diag_field ( trim(field), 'prefluxr', axes(1:3), Time, &
+ 'rain precipitation flux', 'mm/day', missing_value=missing_value )
+ id_prefluxi = register_diag_field ( trim(field), 'prefluxi', axes(1:3), Time, &
+ 'ice precipitation flux', 'mm/day', missing_value=missing_value )
+ id_prefluxs = register_diag_field ( trim(field), 'prefluxs', axes(1:3), Time, &
+ 'snow precipitation flux', 'mm/day', missing_value=missing_value )
+ id_prefluxg = register_diag_field ( trim(field), 'prefluxg', axes(1:3), Time, &
+ 'graupel precipitation flux', 'mm/day', missing_value=missing_value )
id_cond = register_diag_field ( trim(field), 'cond', axes(1:2), Time, &
'condensation', 'mm/day', missing_value=missing_value )
id_dep = register_diag_field ( trim(field), 'dep', axes(1:2), Time, &
@@ -613,6 +635,56 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'evaporation', 'mm/day', missing_value=missing_value )
id_sub = register_diag_field ( trim(field), 'sub', axes(1:2), Time, &
'sublimation', 'mm/day', missing_value=missing_value )
+ id_pcw = register_diag_field ( trim(field), 'pcw', axes(1:3), Time, &
+ 'water particle concentration', '1/m^3', missing_value=missing_value )
+ id_edw = register_diag_field ( trim(field), 'edw', axes(1:3), Time, &
+ 'water effective diameter', 'm', missing_value=missing_value )
+ id_oew = register_diag_field ( trim(field), 'oew', axes(1:3), Time, &
+ 'water optical extinction', '1/m', missing_value=missing_value )
+ id_rrw = register_diag_field ( trim(field), 'rrw', axes(1:3), Time, &
+ 'water radar reflectivity factor', 'm^3', missing_value=missing_value )
+ id_tvw = register_diag_field ( trim(field), 'tvw', axes(1:3), Time, &
+ 'water terminal velocity', 'm/s', missing_value=missing_value )
+ id_pci = register_diag_field ( trim(field), 'pci', axes(1:3), Time, &
+ 'ice particle concentration', '1/m^3', missing_value=missing_value )
+ id_edi = register_diag_field ( trim(field), 'edi', axes(1:3), Time, &
+ 'ice effective diameter', 'm', missing_value=missing_value )
+ id_oei = register_diag_field ( trim(field), 'oei', axes(1:3), Time, &
+ 'ice optical extinction', '1/m', missing_value=missing_value )
+ id_rri = register_diag_field ( trim(field), 'rri', axes(1:3), Time, &
+ 'ice radar reflectivity factor', 'm^3', missing_value=missing_value )
+ id_tvi = register_diag_field ( trim(field), 'tvi', axes(1:3), Time, &
+ 'ice terminal velocity', 'm/s', missing_value=missing_value )
+ id_pcr = register_diag_field ( trim(field), 'pcr', axes(1:3), Time, &
+ 'rain particle concentration', '1/m^3', missing_value=missing_value )
+ id_edr = register_diag_field ( trim(field), 'edr', axes(1:3), Time, &
+ 'rain effective diameter', 'm', missing_value=missing_value )
+ id_oer = register_diag_field ( trim(field), 'oer', axes(1:3), Time, &
+ 'rain optical extinction', '1/m', missing_value=missing_value )
+ id_rrr = register_diag_field ( trim(field), 'rrr', axes(1:3), Time, &
+ 'rain radar reflectivity factor', 'm^3', missing_value=missing_value )
+ id_tvr = register_diag_field ( trim(field), 'tvr', axes(1:3), Time, &
+ 'rain terminal velocity', 'm/s', missing_value=missing_value )
+ id_pcs = register_diag_field ( trim(field), 'pcs', axes(1:3), Time, &
+ 'snow particle concentration', '1/m^3', missing_value=missing_value )
+ id_eds = register_diag_field ( trim(field), 'eds', axes(1:3), Time, &
+ 'snow effective diameter', 'm', missing_value=missing_value )
+ id_oes = register_diag_field ( trim(field), 'oes', axes(1:3), Time, &
+ 'snow optical extinction', '1/m', missing_value=missing_value )
+ id_rrs = register_diag_field ( trim(field), 'rrs', axes(1:3), Time, &
+ 'snow radar reflectivity factor', 'm^3', missing_value=missing_value )
+ id_tvs = register_diag_field ( trim(field), 'tvs', axes(1:3), Time, &
+ 'snow terminal velocity', 'm/s', missing_value=missing_value )
+ id_pcg = register_diag_field ( trim(field), 'pcg', axes(1:3), Time, &
+ 'graupel particle concentration', '1/m^3', missing_value=missing_value )
+ id_edg = register_diag_field ( trim(field), 'edg', axes(1:3), Time, &
+ 'graupel effective diameter', 'm', missing_value=missing_value )
+ id_oeg = register_diag_field ( trim(field), 'oeg', axes(1:3), Time, &
+ 'graupel optical extinction', '1/m', missing_value=missing_value )
+ id_rrg = register_diag_field ( trim(field), 'rrg', axes(1:3), Time, &
+ 'graupel radar reflectivity factor', 'm^3', missing_value=missing_value )
+ id_tvg = register_diag_field ( trim(field), 'tvg', axes(1:3), Time, &
+ 'graupel terminal velocity', 'm/s', missing_value=missing_value )
!-------------------
!! 3D Tendency terms from GFDL MP and physics
!-------------------
@@ -780,7 +852,25 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
! specific humidity:
id_q(i) = register_diag_field(trim(field), 'q'//trim(adjustl(plev)), axes(1:2), Time, &
trim(adjustl(plev))//'-mb specific humidity', 'kg/kg', missing_value=missing_value)
-! Omega (Pa/sec)
+! cloud water mass mixing ratio:
+ id_ql(i) = register_diag_field(trim(field), 'ql'//trim(adjustl(plev)), axes(1:2), Time, &
+ trim(adjustl(plev))//'-mb cloud water mass mixing ratio', 'kg/kg', missing_value=missing_value)
+! cloud ice mass mixing ratio:
+ id_qi(i) = register_diag_field(trim(field), 'qi'//trim(adjustl(plev)), axes(1:2), Time, &
+ trim(adjustl(plev))//'-mb cloud ice mass mixing ratio', 'kg/kg', missing_value=missing_value)
+! rain mass mixing ratio:
+ id_qr(i) = register_diag_field(trim(field), 'qr'//trim(adjustl(plev)), axes(1:2), Time, &
+ trim(adjustl(plev))//'-mb rain mass mixing ratio', 'kg/kg', missing_value=missing_value)
+! snow mass mixing ratio:
+ id_qs(i) = register_diag_field(trim(field), 'qs'//trim(adjustl(plev)), axes(1:2), Time, &
+ trim(adjustl(plev))//'-mb snow mass mixing ratio', 'kg/kg', missing_value=missing_value)
+! graupel mass mixing ratio:
+ id_qg(i) = register_diag_field(trim(field), 'qg'//trim(adjustl(plev)), axes(1:2), Time, &
+ trim(adjustl(plev))//'-mb graupel mass mixing ratio', 'kg/kg', missing_value=missing_value)
+! cloud fraction:
+ id_cf(i) = register_diag_field(trim(field), 'cf'//trim(adjustl(plev)), axes(1:2), Time, &
+ trim(adjustl(plev))//'-mb cloud fraction', '1', missing_value=missing_value)
+! Omega (Pa/sec):
id_omg(i) = register_diag_field(trim(field), 'omg'//trim(adjustl(plev)), axes(1:2), Time, &
trim(adjustl(plev))//'-mb omega', 'Pa/s', missing_value=missing_value)
enddo
@@ -801,6 +891,18 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
'height', 'm', missing_value=missing_value )
id_q_plev = register_diag_field ( trim(field), 'q_plev', axe2(1:3), Time, &
'specific humidity', 'kg/kg', missing_value=missing_value )
+ id_ql_plev = register_diag_field ( trim(field), 'ql_plev', axe2(1:3), Time, &
+ 'cloud water mass mixing ratio', 'kg/kg', missing_value=missing_value )
+ id_qi_plev = register_diag_field ( trim(field), 'qi_plev', axe2(1:3), Time, &
+ 'cloud ice mass mixing ratio', 'kg/kg', missing_value=missing_value )
+ id_qr_plev = register_diag_field ( trim(field), 'qr_plev', axe2(1:3), Time, &
+ 'rain mass mixing ratio', 'kg/kg', missing_value=missing_value )
+ id_qs_plev = register_diag_field ( trim(field), 'qs_plev', axe2(1:3), Time, &
+ 'snow mass mixing ratio', 'kg/kg', missing_value=missing_value )
+ id_qg_plev = register_diag_field ( trim(field), 'qg_plev', axe2(1:3), Time, &
+ 'graupel mass mixing ratio', 'kg/kg', missing_value=missing_value )
+ id_cf_plev = register_diag_field ( trim(field), 'cf_plev', axe2(1:3), Time, &
+ 'cloud fraction', '1', missing_value=missing_value )
id_omg_plev = register_diag_field ( trim(field), 'omg_plev', axe2(1:3), Time, &
'omega', 'Pa/s', missing_value=missing_value )
endif
@@ -932,8 +1034,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
id_qp = register_diag_field ( trim(field), 'qp', axes(1:3), Time, &
'precip condensate', 'kg/m/s^2', missing_value=missing_value )
! fast moist phys tendencies:
- idiag%id_mdt = register_diag_field ( trim(field), 'mdt', axes(1:3), Time, &
- 'DT/Dt: fast moist phys', 'deg/sec', missing_value=missing_value )
id_qdt = register_diag_field ( trim(field), 'qdt', axes(1:3), Time, &
'Dqv/Dt: fast moist phys', 'kg/kg/sec', missing_value=missing_value )
id_dbz = register_diag_field ( trim(field), 'reflectivity', axes(1:3), time, &
@@ -1336,7 +1436,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
module_is_initialized=.true.
istep = 0
#ifndef GFS_PHYS
- if(id_theta_e >0 ) call qsmith_init
+ if(id_theta_e >0 ) call qs_init
#endif
call fv_diag_column_init(Atm(n), yr_init, mo_init, dy_init, hr_init, do_diag_debug, do_diag_sonde, sound_freq, m_calendar)
@@ -1535,8 +1635,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if( prt_minmax ) then
- call prt_mxm('ZS', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain)
- call prt_maxmin('PS', Atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01)
+ call prt_mxm('ZS (m): ', zsurf, isc, iec, jsc, jec, 0, 1, 1.0, Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('PS (Pa): ', Atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain)
#ifdef HIWPP
if (.not. Atm(n)%gridstruct%bounded_domain ) then
@@ -1554,8 +1654,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('NH PS', a2, isc, iec, jsc, jec, 0, 1, 0.01)
- call prt_maxmin('SH PS', var2, isc, iec, jsc, jec, 0, 1, 0.01)
+ call prt_mxm('NH PS', a2, isc, iec, jsc, jec, 0, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('SH PS', var2, isc, iec, jsc, jec, 0, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain)
deallocate(var2)
endif
@@ -1570,7 +1670,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
idiag%efx_sum = idiag%efx_sum + E_Flux
if ( idiag%steps <= max_step ) idiag%efx(idiag%steps) = E_Flux
if (master) then
- write(*,*) 'ENG Deficit (W/m**2)', trim(gn), '=', E_Flux
+ write(*,*) 'Energy_Deficit (W/m**2)', trim(gn), ' = ', E_Flux
endif
@@ -1582,36 +1682,43 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, Atm(n)%flagstruct%nwat, &
Atm(n)%ua, Atm(n)%va, Atm(n)%flagstruct%moist_phys, a2)
#endif
- call prt_maxmin('UA_top', Atm(n)%ua(isc:iec,jsc:jec,1), &
- isc, iec, jsc, jec, 0, 1, 1.)
- call prt_maxmin('UA', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, 1.)
- call prt_maxmin('VA', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, 1.)
+ call prt_mxm('UA_Top (m/s): ', Atm(n)%ua(isc:iec,jsc:jec,1), &
+ isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('UA_Bottom (m/s): ', Atm(n)%ua(isc:iec,jsc:jec,npz), &
+ isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('UA (m/s): ', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('VA_Top (m/s): ', Atm(n)%va(isc:iec,jsc:jec,1), &
+ isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('VA_Bottom (m/s): ', Atm(n)%va(isc:iec,jsc:jec,npz), &
+ isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('VA (m/s): ', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
if ( .not. Atm(n)%flagstruct%hydrostatic ) then
- call prt_maxmin('W ', Atm(n)%w , isc, iec, jsc, jec, ngc, npz, 1.)
- call prt_maxmin('Bottom w', Atm(n)%w(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('W_Top (m/s): ', Atm(n)%w(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('W_Bottom (m/s): ', Atm(n)%w(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('W (m/s): ', Atm(n)%w , isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
do j=jsc,jec
do i=isc,iec
a2(i,j) = -Atm(n)%w(i,j,npz)/Atm(n)%delz(i,j,npz)
enddo
enddo
- call prt_maxmin('Bottom: w/dz', a2, isc, iec, jsc, jec, 0, 1, 1.)
-
- if ( Atm(n)%flagstruct%hybrid_z ) call prt_maxmin('Hybrid_ZTOP (km)', Atm(n)%ze0(isc:iec,jsc:jec,1), &
- isc, iec, jsc, jec, 0, 1, 1.E-3)
- call prt_maxmin('DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,1:npz), &
- isc, iec, jsc, jec, 0, npz, 1.)
- call prt_maxmin('Bottom DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,npz), &
- isc, iec, jsc, jec, 0, 1, 1.)
-! call prt_maxmin('Top DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,1), &
-! isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('W/dz_Bottom (1/s): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+
+ if ( Atm(n)%flagstruct%hybrid_z ) call prt_mxm('Hybrid_ZTOP (km)', Atm(n)%ze0(isc:iec,jsc:jec,1), &
+ isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('DZ_Top (m): ', Atm(n)%delz(isc:iec,jsc:jec,1), &
+ isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('DZ_Bottom (m): ', Atm(n)%delz(isc:iec,jsc:jec,npz), &
+ isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('DZ (m): ', Atm(n)%delz(isc:iec,jsc:jec,1:npz), &
+ isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
#ifndef SW_DYNAMICS
- call prt_maxmin('TA', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, 1.)
-! call prt_maxmin('Top: TA', Atm(n)%pt(isc:iec,jsc:jec, 1), isc, iec, jsc, jec, 0, 1, 1.)
-! call prt_maxmin('Bot: TA', Atm(n)%pt(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1.)
- call prt_maxmin('OM', Atm(n)%omga, isc, iec, jsc, jec, ngc, npz, 1.)
+ call prt_mxm('TA_Top (K): ', Atm(n)%pt(isc:iec,jsc:jec, 1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('TA_Bottom (K): ', Atm(n)%pt(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('TA (K): ', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('OM (pa/s): ', Atm(n)%omga, isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
#endif
elseif ( Atm(n)%flagstruct%range_warn ) then
@@ -1666,17 +1773,51 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
#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_pret > 0) used=send_data(id_pret, &
+ Atm(n)%inline_mp%prew(isc:iec,jsc:jec)+&
+ 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_prew > 0) used=send_data(id_prew, Atm(n)%inline_mp%prew(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_prefluxw > 0) used=send_data(id_prefluxw, Atm(n)%inline_mp%prefluxw(isc:iec,jsc:jec,1:npz), Time)
+ if(id_prefluxr > 0) used=send_data(id_prefluxr, Atm(n)%inline_mp%prefluxr(isc:iec,jsc:jec,1:npz), Time)
+ if(id_prefluxi > 0) used=send_data(id_prefluxi, Atm(n)%inline_mp%prefluxi(isc:iec,jsc:jec,1:npz), Time)
+ if(id_prefluxs > 0) used=send_data(id_prefluxs, Atm(n)%inline_mp%prefluxs(isc:iec,jsc:jec,1:npz), Time)
+ if(id_prefluxg > 0) used=send_data(id_prefluxg, Atm(n)%inline_mp%prefluxg(isc:iec,jsc:jec,1:npz), 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_pcw > 0) used=send_data(id_pcw, Atm(n)%inline_mp%pcw(isc:iec,jsc:jec,1:npz), Time)
+ if(id_edw > 0) used=send_data(id_edw, Atm(n)%inline_mp%edw(isc:iec,jsc:jec,1:npz), Time)
+ if(id_oew > 0) used=send_data(id_oew, Atm(n)%inline_mp%oew(isc:iec,jsc:jec,1:npz), Time)
+ if(id_rrw > 0) used=send_data(id_rrw, Atm(n)%inline_mp%rrw(isc:iec,jsc:jec,1:npz), Time)
+ if(id_tvw > 0) used=send_data(id_tvw, Atm(n)%inline_mp%tvw(isc:iec,jsc:jec,1:npz), Time)
+ if(id_pci > 0) used=send_data(id_pci, Atm(n)%inline_mp%pci(isc:iec,jsc:jec,1:npz), Time)
+ if(id_edi > 0) used=send_data(id_edi, Atm(n)%inline_mp%edi(isc:iec,jsc:jec,1:npz), Time)
+ if(id_oei > 0) used=send_data(id_oei, Atm(n)%inline_mp%oei(isc:iec,jsc:jec,1:npz), Time)
+ if(id_rri > 0) used=send_data(id_rri, Atm(n)%inline_mp%rri(isc:iec,jsc:jec,1:npz), Time)
+ if(id_tvi > 0) used=send_data(id_tvi, Atm(n)%inline_mp%tvi(isc:iec,jsc:jec,1:npz), Time)
+ if(id_pcr > 0) used=send_data(id_pcr, Atm(n)%inline_mp%pcr(isc:iec,jsc:jec,1:npz), Time)
+ if(id_edr > 0) used=send_data(id_edr, Atm(n)%inline_mp%edr(isc:iec,jsc:jec,1:npz), Time)
+ if(id_oer > 0) used=send_data(id_oer, Atm(n)%inline_mp%oer(isc:iec,jsc:jec,1:npz), Time)
+ if(id_rrr > 0) used=send_data(id_rrr, Atm(n)%inline_mp%rrr(isc:iec,jsc:jec,1:npz), Time)
+ if(id_tvr > 0) used=send_data(id_tvr, Atm(n)%inline_mp%tvr(isc:iec,jsc:jec,1:npz), Time)
+ if(id_pcs > 0) used=send_data(id_pcs, Atm(n)%inline_mp%pcs(isc:iec,jsc:jec,1:npz), Time)
+ if(id_eds > 0) used=send_data(id_eds, Atm(n)%inline_mp%eds(isc:iec,jsc:jec,1:npz), Time)
+ if(id_oes > 0) used=send_data(id_oes, Atm(n)%inline_mp%oes(isc:iec,jsc:jec,1:npz), Time)
+ if(id_rrs > 0) used=send_data(id_rrs, Atm(n)%inline_mp%rrs(isc:iec,jsc:jec,1:npz), Time)
+ if(id_tvs > 0) used=send_data(id_tvs, Atm(n)%inline_mp%tvs(isc:iec,jsc:jec,1:npz), Time)
+ if(id_pcg > 0) used=send_data(id_pcg, Atm(n)%inline_mp%pcg(isc:iec,jsc:jec,1:npz), Time)
+ if(id_edg > 0) used=send_data(id_edg, Atm(n)%inline_mp%edg(isc:iec,jsc:jec,1:npz), Time)
+ if(id_oeg > 0) used=send_data(id_oeg, Atm(n)%inline_mp%oeg(isc:iec,jsc:jec,1:npz), Time)
+ if(id_rrg > 0) used=send_data(id_rrg, Atm(n)%inline_mp%rrg(isc:iec,jsc:jec,1:npz), Time)
+ if(id_tvg > 0) used=send_data(id_tvg, Atm(n)%inline_mp%tvg(isc:iec,jsc:jec,1:npz), Time)
if (id_qv_dt_gfdlmp > 0) used=send_data(id_qv_dt_gfdlmp, Atm(n)%inline_mp%qv_dt(isc:iec,jsc:jec,1:npz), Time)
if (id_ql_dt_gfdlmp > 0) used=send_data(id_ql_dt_gfdlmp, Atm(n)%inline_mp%ql_dt(isc:iec,jsc:jec,1:npz), Time)
@@ -1794,7 +1935,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('UH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('UH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
if ( id_uh25 > 0 ) then
@@ -1836,7 +1977,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('SRH (0-1 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('SRH (0-1 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
@@ -1856,7 +1997,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('SRH (0-3 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('SRH (0-3 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
@@ -1876,7 +2017,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('SRH (2-5 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('SRH (2-5 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
@@ -1914,7 +2055,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
used = send_data( id_pv550K, a2, Time)
endif
deallocate ( a3 )
- if (prt_minmax) call prt_maxmin('PV', wk, isc, iec, jsc, jec, 0, 1, 1.)
+ if (prt_minmax) call prt_mxm('PV', wk, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
@@ -1928,8 +2069,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
enddo
enddo
- call qsmith(iec-isc+1, jec-jsc+1, 1, Atm(n)%pt(isc:iec,jsc:jec,k), &
- a2, Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc,jsc,k))
+ call mqs3d(iec-isc+1, jec-jsc+1, 1, Atm(n)%pt(isc:iec,jsc:jec,k), a2, &
+ Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k))
do j=jsc,jec
do i=isc,iec
wk(i,j,k) = 100.*Atm(n)%q(i,j,k,sphum)/wk(i,j,k)
@@ -1938,8 +2079,9 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
used = send_data ( id_rh, wk, Time )
if(prt_minmax) then
- call prt_maxmin('RH_sf (%)', wk(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1.)
- call prt_maxmin('RH_3D (%)', wk, isc, iec, jsc, jec, 0, npz, 1.)
+ call prt_mxm('RH_Top (%): ', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('RH_Bottom (%): ', wk(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('RH (%): ', wk, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
if (.not. Atm(n)%gridstruct%bounded_domain) then
tmp = 0.
@@ -1954,7 +2096,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call mp_reduce_sum(sar)
call mp_reduce_sum(tmp)
if ( sar > 0. ) then
- if (master) write(*,*) 'RH200 =', tmp/sar
+ if (master) write(*,*) 'RH200 = ', tmp/sar
endif
endif
endif
@@ -1974,8 +2116,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
enddo
enddo
- call rh_calc (a2, Atm(n)%pt(isc:iec,jsc:jec,k), &
- Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k))
+ call mqs3d (iec-isc+1, jec-jsc+1, 1, Atm(n)%pt(isc:iec,jsc:jec,k), a2, &
+ Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k))
+ do j=jsc,jec
+ do i=isc,iec
+ wk(i,j,k) = 100.*Atm(n)%q(i,j,k,sphum)/wk(i,j,k)
+ enddo
+ enddo
enddo
if (id_rh50>0) then
call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
@@ -2093,8 +2240,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))
enddo
enddo
- call rh_calc (a2, Atm(n)%pt(isc:iec,jsc:jec,k), &
- Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k), do_cmip=.true.)
+ call mqs3d (iec-isc+1, jec-jsc+1, 1, Atm(n)%pt(isc:iec,jsc:jec,k), a2, &
+ Atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k))
+ do j=jsc,jec
+ do i=isc,iec
+ wk(i,j,k) = 100.*Atm(n)%q(i,j,k,sphum)/wk(i,j,k)
+ enddo
+ enddo
enddo
if (id_rh10_cmip>0) then
call interpolate_vertical(isc, iec, jsc, jec, npz, 10.e2, Atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
@@ -2158,8 +2310,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call get_height_field(isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%delz, &
wz, Atm(n)%pt, Atm(n)%q, Atm(n)%peln, zvir)
if( prt_minmax ) &
- call prt_mxm('ZTOP',wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain)
-! call prt_maxmin('ZTOP', wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3)
+ call prt_mxm('ZTOP (m): ',wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain)
if (id_hght3d > 0) then
used = send_data(id_hght3d, 0.5*(wz(isc:iec,jsc:jec,1:npz)+wz(isc:iec,jsc:jec,2:npz+1)), Time)
@@ -2177,7 +2328,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
used = send_data (id_slp, slp, Time)
if( prt_minmax ) then
- call prt_maxmin('SLP', slp, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('SLP (Pa): ', slp, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
! US Potential Landfall TCs (PLT):
do j=jsc,jec
do i=isc,iec
@@ -2189,7 +2340,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('ATL SLP', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('SLP_ATL (Pa): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
@@ -2227,13 +2378,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if( prt_minmax ) then
if(id_h(k100)>0 .or. (id_h_plev>0 .and. k100>0)) &
- call prt_mxm('Z100',a3(isc:iec,jsc:jec,k100),isc,iec,jsc,jec,0,1,1.E-3,Atm(n)%gridstruct%area_64,Atm(n)%domain)
+ call prt_mxm('Z100 (m): ',a3(isc:iec,jsc:jec,k100),isc,iec,jsc,jec,0,1,1.E-3,Atm(n)%gridstruct%area_64,Atm(n)%domain)
if(id_h(k500)>0 .or. (id_h_plev>0 .and. k500>0)) then
if (Atm(n)%gridstruct%bounded_domain) then
- call prt_mxm('Z500',a3(isc:iec,jsc:jec,k500),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain)
+ call prt_mxm('Z500 (m): ',a3(isc:iec,jsc:jec,k500),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain)
else
- call prt_gb_nh_sh('fv_GFS Z500', isc,iec, jsc,jec, a3(isc,jsc,k500), Atm(n)%gridstruct%area_64(isc:iec,jsc:jec), &
+ call prt_gb_nh_sh('fv_GFS Z500 (m): ', isc,iec, jsc,jec, a3(isc,jsc,k500), Atm(n)%gridstruct%area_64(isc:iec,jsc:jec), &
Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2))
endif
endif
@@ -2292,7 +2443,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('Depress', depress, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('Depress', depress, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
do j=jsc,jec
do i=isc,iec
if ( Atm(n)%gridstruct%agrid(i,j,2)<0.) then
@@ -2301,7 +2452,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('NH Deps', depress, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('NH Deps', depress, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
! ATL basin cyclones
do j=jsc,jec
@@ -2312,7 +2463,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
enddo
enddo
- call prt_maxmin('ATL Deps', depress, isc, iec, jsc, jec, 0, 1, 1.)
+ call prt_mxm('ATL Deps', depress, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
@@ -2407,7 +2558,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
enddo
if ( id_t(k100)>0 .and. prt_minmax ) then
- call prt_mxm('T100:', a3(isc:iec,jsc:jec,k100), isc, iec, jsc, jec, 0, 1, 1., &
+ call prt_mxm('T100 (K): ', a3(isc:iec,jsc:jec,k100), isc, iec, jsc, jec, 0, 1, 1., &
Atm(n)%gridstruct%area_64, Atm(n)%domain)
if (.not. Atm(n)%gridstruct%bounded_domain) then
tmp = 0.
@@ -2425,14 +2576,14 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call mp_reduce_sum(sar)
call mp_reduce_sum(tmp)
if ( sar > 0. ) then
- if (master) write(*,*) 'Tropical [10s,10n] mean T100 =', tmp/sar
+ if (master) write(*,*) 'Tropical [10s,10n] mean T100 = ', tmp/sar
else
if (master) write(*,*) 'Warning: problem computing tropical mean T100'
endif
endif
endif
if ( id_t(k200) > 0 .and. prt_minmax ) then
- call prt_mxm('T200:', a3(isc:iec,jsc:jec,k200), isc, iec, jsc, jec, 0, 1, 1., &
+ call prt_mxm('T200 (K): ', a3(isc:iec,jsc:jec,k200), isc, iec, jsc, jec, 0, 1, 1., &
Atm(n)%gridstruct%area_64, Atm(n)%domain)
if (.not. Atm(n)%gridstruct%bounded_domain) then
tmp = 0.
@@ -2449,7 +2600,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
call mp_reduce_sum(sar)
call mp_reduce_sum(tmp)
if ( sar > 0. ) then
- if (master) write(*,*) 'Tropical [-20.,20.] mean T200 =', tmp/sar
+ if (master) write(*,*) 'Tropical [-20.,20.] mean T200 = ', tmp/sar
endif
endif
endif
@@ -2757,16 +2908,16 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
if ( id_ctt>0 ) then
used = send_data(id_ctt, a2, Time)
- if(prt_minmax) call prt_maxmin('Cloud_top_T (K)', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('Cloud_top_T (K): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_ctp>0 ) then
used = send_data(id_ctp, var1, Time)
- if(prt_minmax) call prt_maxmin('Cloud_top_P (mb)', var1, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('Cloud_top_P (mb): ', var1, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
deallocate ( var1 )
if ( id_ctz>0 ) then
used = send_data(id_ctz, var2, Time)
- if(prt_minmax) call prt_maxmin('Cloud_top_z (m)', var2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('Cloud_top_Z (m): ', var2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
deallocate ( var2 )
endif
@@ -2868,14 +3019,14 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
used=send_data(id_us, u2, Time)
used=send_data(id_vs, v2, Time)
- if(prt_minmax) call prt_maxmin('Surf_wind_speed', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('Surf_Wind_Speed (m/s): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if(id_tb > 0) then
a2(:,:) = Atm(n)%pt(isc:iec,jsc:jec,npz)
used=send_data(id_tb, a2, Time)
if( prt_minmax ) &
- call prt_mxm('T_bot:', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm('T_Bottom (K): ', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if(id_ua > 0) used=send_data(id_ua, Atm(n)%ua(isc:iec,jsc:jec,:), Time)
@@ -2938,7 +3089,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
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)
+! call prt_mxm(' PFNH (mb)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, npz, 1.E-2, Atm(n)%gridstruct%area_64, Atm(n)%domain)
! endif
used=send_data(id_pfnh, wk, Time)
if (id_ppnh > 0) then
@@ -2997,13 +3148,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if (id_cape > 0) then
if (prt_minmax) then
- call prt_maxmin(' CAPE (J/kg)', a2, isc,iec,jsc,jec, 0, 1, 1.)
+ call prt_mxm(' CAPE (J/kg)', a2, isc,iec,jsc,jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
used=send_data(id_cape, a2, Time)
endif
if (id_cin > 0) then
if (prt_minmax) then
- call prt_maxmin(' CIN (J/kg)', var2, isc,iec,jsc,jec, 0, 1, 1.)
+ call prt_mxm(' CIN (J/kg)', var2, isc,iec,jsc,jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
used=send_data(id_cin, var2, Time)
endif
@@ -3085,44 +3236,44 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
endif
if( prt_minmax ) &
- call prt_maxmin('ZTOP', wz(isc:iec,jsc:jec,1)+Atm(n)%phis(isc:iec,jsc:jec)/grav, isc, iec, jsc, jec, 0, 1, 1.E-3)
+ call prt_mxm('ZTOP', wz(isc:iec,jsc:jec,1)+Atm(n)%phis(isc:iec,jsc:jec)/grav, isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_rain5km>0 ) then
rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat')
call interpolate_z(isc, iec, jsc, jec, npz, 5.e3, wz, Atm(n)%q(isc:iec,jsc:jec,:,rainwat), a2)
used=send_data(id_rain5km, a2, Time)
- if(prt_minmax) call prt_maxmin('rain5km', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('rain5km', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_w5km>0 ) then
call interpolate_z(isc, iec, jsc, jec, npz, 5.e3, wz, Atm(n)%w(isc:iec,jsc:jec,:), a2)
used=send_data(id_w5km, a2, Time)
- if(prt_minmax) call prt_maxmin('W5km', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('W5km', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_w2500m>0 ) then
call interpolate_z(isc, iec, jsc, jec, npz, 2.5e3, wz, Atm(n)%w(isc:iec,jsc:jec,:), a2)
used=send_data(id_w2500m, a2, Time)
- if(prt_minmax) call prt_maxmin('W2500m', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('W2500m', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_w1km>0 ) then
call interpolate_z(isc, iec, jsc, jec, npz, 1.e3, wz, Atm(n)%w(isc:iec,jsc:jec,:), a2)
used=send_data(id_w1km, a2, Time)
- if(prt_minmax) call prt_maxmin('W1km', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('W1km', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_w100m>0 ) then
call interpolate_z(isc, iec, jsc, jec, npz, 100., wz, Atm(n)%w(isc:iec,jsc:jec,:), a2)
used=send_data(id_w100m, a2, Time)
- if(prt_minmax) call prt_maxmin('w100m', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('w100m', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_u100m>0 ) then
call interpolate_z(isc, iec, jsc, jec, npz, 100., wz, Atm(n)%ua(isc:iec,jsc:jec,:), a2)
used=send_data(id_u100m, a2, Time)
- if(prt_minmax) call prt_maxmin('u100m', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('u100m', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( id_v100m>0 ) then
call interpolate_z(isc, iec, jsc, jec, npz, 100., wz, Atm(n)%va(isc:iec,jsc:jec,:), a2)
used=send_data(id_v100m, a2, Time)
- if(prt_minmax) call prt_maxmin('v100m', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('v100m', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if ( rainwat > 0 .and. (id_dbz>0 .or. id_maxdbz>0 .or. id_basedbz>0 .or. id_dbz4km>0 &
@@ -3130,9 +3281,12 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if (.not. allocated(a3)) allocate(a3(isc:iec,jsc:jec,npz))
- 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, &
+! call dbzcalc_smithxue(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
+ call rad_ref(Atm(n)%bd%is, Atm(n)%bd%ie, Atm(n)%bd%js, Atm(n)%bd%je, &
+ Atm(n)%bd%isd, Atm(n)%bd%ied, Atm(n)%bd%jsd, Atm(n)%bd%jed, &
+ Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
+ a3, a2, allmax, npz, Atm(n)%ncnst, Atm(n)%flagstruct%hydrostatic, &
+ zvir, 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)
@@ -3142,7 +3296,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
!interpolate to 1km dbz
call cs_interpolator(isc, iec, jsc, jec, npz, a3, 1000., wz, a2, -20.)
used=send_data(id_basedbz, a2, time)
- if(prt_minmax) call prt_maxmin('Base_dBz', a2, isc, iec, jsc, jec, 0, 1, 1.)
+ if(prt_minmax) call prt_mxm('Base_dBz', a2, isc, iec, jsc, jec, 0, 1, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if (id_dbz4km > 0) then
@@ -3274,6 +3428,168 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
used=send_data(id_q_plev, a3(isc:iec,jsc:jec,:), Time)
endif
+! cloud water mass mixing ratio
+ idg(:) = id_ql(:)
+
+ do_cs_intp = .false.
+ do i=1,nplev
+ if ( idg(i)>0 ) then
+ do_cs_intp = .true.
+ exit
+ endif
+ enddo
+
+ if ( do_cs_intp ) then
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,liq_wat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
+! plevs(1:nplev), Atm(n)%peln, idg, a3, 0)
+ do i=1,nplev
+ if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
+ enddo
+ endif
+
+ if (id_ql_plev>0) then
+ id1(:) = 1
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,liq_wat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
+ used=send_data(id_ql_plev, a3(isc:iec,jsc:jec,:), Time)
+ endif
+
+! cloud ice mass mixing ratio
+ idg(:) = id_qi(:)
+
+ do_cs_intp = .false.
+ do i=1,nplev
+ if ( idg(i)>0 ) then
+ do_cs_intp = .true.
+ exit
+ endif
+ enddo
+
+ if ( do_cs_intp ) then
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,ice_wat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
+! plevs(1:nplev), Atm(n)%peln, idg, a3, 0)
+ do i=1,nplev
+ if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
+ enddo
+ endif
+
+ if (id_qi_plev>0) then
+ id1(:) = 1
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,ice_wat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
+ used=send_data(id_qi_plev, a3(isc:iec,jsc:jec,:), Time)
+ endif
+
+! rain mass mixing ratio
+ idg(:) = id_qr(:)
+
+ do_cs_intp = .false.
+ do i=1,nplev
+ if ( idg(i)>0 ) then
+ do_cs_intp = .true.
+ exit
+ endif
+ enddo
+
+ if ( do_cs_intp ) then
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,rainwat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
+! plevs(1:nplev), Atm(n)%peln, idg, a3, 0)
+ do i=1,nplev
+ if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
+ enddo
+ endif
+
+ if (id_qr_plev>0) then
+ id1(:) = 1
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,rainwat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
+ used=send_data(id_qr_plev, a3(isc:iec,jsc:jec,:), Time)
+ endif
+
+! snow mass mixing ratio
+ idg(:) = id_qs(:)
+
+ do_cs_intp = .false.
+ do i=1,nplev
+ if ( idg(i)>0 ) then
+ do_cs_intp = .true.
+ exit
+ endif
+ enddo
+
+ if ( do_cs_intp ) then
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,snowwat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
+! plevs(1:nplev), Atm(n)%peln, idg, a3, 0)
+ do i=1,nplev
+ if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
+ enddo
+ endif
+
+ if (id_qs_plev>0) then
+ id1(:) = 1
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,snowwat), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
+ used=send_data(id_qs_plev, a3(isc:iec,jsc:jec,:), Time)
+ endif
+
+! graupel mass mixing ratio
+ idg(:) = id_qg(:)
+
+ do_cs_intp = .false.
+ do i=1,nplev
+ if ( idg(i)>0 ) then
+ do_cs_intp = .true.
+ exit
+ endif
+ enddo
+
+ if ( do_cs_intp ) then
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,graupel), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
+! plevs(1:nplev), Atm(n)%peln, idg, a3, 0)
+ do i=1,nplev
+ if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
+ enddo
+ endif
+
+ if (id_qg_plev>0) then
+ id1(:) = 1
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,graupel), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
+ used=send_data(id_qg_plev, a3(isc:iec,jsc:jec,:), Time)
+ endif
+
+! cloud fraction
+ idg(:) = id_cf(:)
+
+ do_cs_intp = .false.
+ do i=1,nplev
+ if ( idg(i)>0 ) then
+ do_cs_intp = .true.
+ exit
+ endif
+ enddo
+
+ if ( do_cs_intp ) then
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,cld_amt), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
+! plevs(1:nplev), Atm(n)%peln, idg, a3, 0)
+ do i=1,nplev
+ if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), Time)
+ enddo
+ endif
+
+ if (id_cf_plev>0) then
+ id1(:) = 1
+ call cs3_interpolator(isc,iec,jsc,jec,npz, Atm(n)%q(isc:iec,jsc:jec,:,cld_amt), nplev, &
+ pout(1:nplev), wz, Atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
+ used=send_data(id_cf_plev, a3(isc:iec,jsc:jec,:), Time)
+ endif
+
! Omega
idg(:) = id_omg(:)
@@ -3454,7 +3770,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
endif
if (id_theta_e > 0) then
- if( prt_minmax ) call prt_maxmin('Theta_E', a3, isc, iec, jsc, jec, 0, npz, 1.)
+ if( prt_minmax ) call prt_mxm('Theta_E', a3, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
used=send_data(id_theta_e, a3, Time)
end if
theta_d = get_tracer_index (MODEL_ATMOS, 'theta_d')
@@ -3478,7 +3794,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
enddo
enddo
enddo
- call prt_maxmin('Theta_Err (%)', a3, isc, iec, jsc, jec, 0, npz, 100.)
+ call prt_mxm('Theta_Err (%)', a3, isc, iec, jsc, jec, 0, npz, 100., Atm(n)%gridstruct%area_64, Atm(n)%domain)
! if ( master ) write(*,*) 'PK0=', pk0, 'KAPPA=', kappa
endif
endif
@@ -3518,7 +3834,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
used=send_data(id_ppt, wk, Time)
if( prt_minmax ) then
- call prt_maxmin('PoTemp', wk, isc, iec, jsc, jec, 0, npz, 1.)
+ call prt_mxm('PoTemp', wk, isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
if( allocated(a3) ) deallocate ( a3 )
@@ -3533,11 +3849,11 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
used = send_data (id_tracer(itrac), Atm(n)%q(isc:iec,jsc:jec,:,itrac), Time )
endif
if (itrac .le. nq) then
- if( prt_minmax ) call prt_maxmin(trim(tname), Atm(n)%q(:,:,1,itrac), &
- isc, iec, jsc, jec, ngc, npz, 1.)
+ if( prt_minmax ) call prt_mxm(trim(tname)//": ", Atm(n)%q(:,:,1,itrac), &
+ isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
else
- if( prt_minmax ) call prt_maxmin(trim(tname), Atm(n)%qdiag(:,:,1,itrac), &
- isc, iec, jsc, jec, ngc, npz, 1.)
+ if( prt_minmax ) call prt_mxm(trim(tname)//": ", Atm(n)%qdiag(:,:,1,itrac), &
+ isc, iec, jsc, jec, ngc, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
!-------------------------------
! ESM TRACER diagnostics output:
@@ -3558,10 +3874,10 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
used = send_data (id_tracer_dmmr(itrac), dmmr, Time )
used = send_data (id_tracer_dvmr(itrac), dvmr, Time )
if( prt_minmax ) then
- call prt_maxmin(trim(tname)//'_dmmr', dmmr, &
- isc, iec, jsc, jec, 0, npz, 1.)
- call prt_maxmin(trim(tname)//'_dvmr', dvmr, &
- isc, iec, jsc, jec, 0, npz, 1.)
+ call prt_mxm(trim(tname)//'_dmmr', dmmr, &
+ isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
+ call prt_mxm(trim(tname)//'_dvmr', dvmr, &
+ isc, iec, jsc, jec, 0, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain)
endif
endif
enddo
@@ -4190,7 +4506,7 @@ subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain
call z_sum(is, ie, js, je, kstrat, n_g, delp, q(is-n_g,js-n_g,1,sphum), q_strat(is,js))
psmo = g_sum(domain, q_strat(is,js), is, ie, js, je, n_g, area, 1) * 1.e6 &
/ p_sum(is, ie, js, je, kstrat, n_g, delp, area, domain)
- if(master) write(*,*) 'Mean specific humidity (mg/kg) above 75 mb', trim(gn), '=', psmo
+ if(master) write(*,*) 'Mean_Specific_Humidity (mg/kg) above 75 mb', trim(gn), ' = ', psmo
endif
@@ -4207,23 +4523,23 @@ subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain
psdry = psmo - totw
if( master ) then
- write(*,*) 'Total surface pressure (mb)', trim(gn), ' = ', 0.01*psmo
- write(*,*) 'mean dry surface pressure', trim(gn), ' = ', 0.01*psdry
- write(*,*) 'Total Water Vapor (kg/m**2)', trim(gn), ' =', qtot(sphum)*ginv
+ write(*,*) 'Total_Surface_Pressure (mb)', trim(gn), ' = ', 0.01*psmo
+ write(*,*) 'Mean_Dry_Surface_Pressure (mb)', trim(gn), ' = ', 0.01*psdry
+ write(*,*) 'Total_Water_Vapor (kg/m**2)', trim(gn), ' = ', qtot(sphum)*ginv
if ( nwat> 2 ) then
write(*,*) '--- Micro Phys water substances (kg/m**2) ---'
- write(*,*) 'Total cloud water', trim(gn), '=', qtot(liq_wat)*ginv
+ write(*,*) 'Total_Cloud_Water', trim(gn), ' = ', qtot(liq_wat)*ginv
if (rainwat > 0) &
- write(*,*) 'Total rain water', trim(gn), '=', qtot(rainwat)*ginv
+ write(*,*) 'Total_Rain_Water ', trim(gn), ' = ', qtot(rainwat)*ginv
if (ice_wat > 0) &
- write(*,*) 'Total cloud ice ', trim(gn), '=', qtot(ice_wat)*ginv
+ write(*,*) 'Total_Cloud_Ice ', trim(gn), ' = ', qtot(ice_wat)*ginv
if (snowwat > 0) &
- write(*,*) 'Total snow ', trim(gn), '=', qtot(snowwat)*ginv
+ write(*,*) 'Total_Snow ', trim(gn), ' = ', qtot(snowwat)*ginv
if (graupel > 0) &
- write(*,*) 'Total graupel ', trim(gn), '=', qtot(graupel)*ginv
+ write(*,*) 'Total_Graupel ', trim(gn), ' = ', qtot(graupel)*ginv
write(*,*) '---------------------------------------------'
elseif ( nwat==2 ) then
- write(*,*) 'GFS condensate (kg/m^2)', trim(gn), '=', qtot(liq_wat)*ginv
+ write(*,*) 'GFS_Condensate (kg/m^2)', trim(gn), ' = ', qtot(liq_wat)*ginv
endif
endif
@@ -5361,7 +5677,7 @@ subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, np
if ( moist ) then
do i=is,ie
rq(i) = max(0., q(i,j,k))
-! rh(i) = max(1.e-12, rq(i)/wqs1(pt(i,j,k),den(i))) ! relative humidity
+! rh(i) = max(1.e-12, rq(i)/wqs(pt(i,j,k),den(i),rh(i))) ! relative humidity
! theta_e(i,j,k) = exp(rq(i)/cp_air*((hlv+dc_vap*(pt(i,j,k)-tice))/pt(i,j,k) - &
! rvgas*log(rh(i))) + kappa*log(1.e5/pd(i))) * pt(i,j,k)
! Simplified form: (ignoring the RH term)
@@ -5540,7 +5856,7 @@ subroutine nh_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, &
enddo
psm = g_sum(domain, te, is, ie, js, je, 3, area_l, 1)
- if( master ) write(*,*) 'TE ( Joule/m^2 * E9) =', psm * 1.E-9
+ if( master ) write(*,*) 'Total_Energy (J/m**2 * E9) = ', psm * 1.E-9
end subroutine nh_total_energy
diff --git a/tools/fv_diagnostics.h b/tools/fv_diagnostics.h
index 099d4c290..c1a5e3d37 100644
--- a/tools/fv_diagnostics.h
+++ b/tools/fv_diagnostics.h
@@ -46,8 +46,10 @@
integer :: id_srh1, id_srh3, id_ustm, id_vstm
! NGGPS 31-level diag
integer, allocatable :: id_u(:), id_v(:), id_t(:), id_h(:), id_q(:), id_omg(:)
+ integer, allocatable :: id_ql(:), id_qi(:), id_qr(:), id_qs(:), id_qg(:), id_cf(:)
integer:: id_u_plev, id_v_plev, id_t_plev, id_h_plev, id_q_plev, id_omg_plev
+ integer:: id_ql_plev, id_qi_plev, id_qr_plev, id_qs_plev, id_qg_plev, id_cf_plev
integer:: id_t_plev_ave, id_q_plev_ave, id_qv_dt_gfdlmp_plev_ave, id_t_dt_gfdlmp_plev_ave, id_qv_dt_phys_plev_ave, id_t_dt_phys_plev_ave
! IPCC diag
@@ -79,7 +81,13 @@
real, allocatable :: zsurf(:,:)
real, allocatable :: pt1(:)
- integer :: id_prec, id_prer, id_prei, id_pres, id_preg, id_cond, id_dep, id_reevap, id_sub
+ integer :: id_pret, id_prew, id_prer, id_prei, id_pres, id_preg, id_cond, id_dep, id_reevap, id_sub
+ integer :: id_prefluxw, id_prefluxr, id_prefluxi, id_prefluxs, id_prefluxg
+ integer :: id_pcw, id_edw, id_oew, id_rrw, id_tvw
+ integer :: id_pci, id_edi, id_oei, id_rri, id_tvi
+ integer :: id_pcr, id_edr, id_oer, id_rrr, id_tvr
+ integer :: id_pcs, id_eds, id_oes, id_rrs, id_tvs
+ integer :: id_pcg, id_edg, id_oeg, id_rrg, id_tvg
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
diff --git a/tools/fv_io.F90 b/tools/fv_io.F90
index fd4eb58dc..d8a310c4d 100644
--- a/tools/fv_io.F90
+++ b/tools/fv_io.F90
@@ -46,19 +46,22 @@ module fv_io_mod
use mpp_domains_mod, only: domain2d, EAST, WEST, NORTH, CENTER, SOUTH, CORNER, &
mpp_get_compute_domain, mpp_get_data_domain, &
mpp_get_layout, mpp_get_ntile_count, &
- mpp_get_global_domain
+ mpp_get_global_domain, mpp_update_domains
use tracer_manager_mod, only: tr_get_tracer_names=>get_tracer_names, &
get_tracer_names, get_number_tracers, &
set_tracer_profile, &
get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
use external_sst_mod, only: sst_ncep, sst_anom, use_ncep_sst
- use fv_arrays_mod, only: fv_atmos_type, fv_nest_BC_type_3D
+ use fv_arrays_mod, only: fv_atmos_type, fv_nest_BC_type_3D, R_GRID, &
+ fv_grid_bounds_type, fv_grid_type
use fv_eta_mod, only: set_external_eta
use fv_mp_mod, only: mp_gather, is_master
use fv_treat_da_inc_mod, only: read_da_inc
-
+ use mpp_parameter_mod, only: DGRID_NE
+ use fv_grid_utils_mod, only: cubed_a2d
+
implicit none
private
@@ -271,8 +274,29 @@ subroutine fv_io_register_restart(Atm)
elseif (Atm%Fv_restart_tile_is_open) then
zsize = (/size(Atm%u,3)/)
call fv_io_register_axis(Atm%Fv_restart_tile, numx=numx_2d, numy=numy_2d, xpos=xpos_2d, ypos=ypos_2d, numz=numz, zsize=zsize)
- call register_restart_field(Atm%Fv_restart_tile, 'u', Atm%u, dim_names_4d)
- call register_restart_field(Atm%Fv_restart_tile, 'v', Atm%v, dim_names_4d2)
+
+ !--- optionally include D-grid winds even if restarting from A-grid winds
+ if (Atm%flagstruct%write_optional_dgrid_vel_rst .and. Atm%flagstruct%restart_from_agrid_winds) then
+ call register_restart_field(Atm%Fv_restart_tile, 'u', Atm%u, &
+ dim_names_4d, is_optional=.true.)
+ call register_restart_field(Atm%Fv_restart_tile, 'v', Atm%v, &
+ dim_names_4d2, is_optional=.true.)
+ endif
+
+ !--- include agrid winds in restarts for use in data assimilation or for restarting
+ if (Atm%flagstruct%agrid_vel_rst .or. Atm%flagstruct%restart_from_agrid_winds) 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%flagstruct%restart_from_agrid_winds) then
+ call register_restart_field(Atm%Fv_restart_tile, 'u', Atm%u, &
+ dim_names_4d)
+ call register_restart_field(Atm%Fv_restart_tile, 'v', Atm%v, &
+ dim_names_4d2)
+ endif
if (.not.Atm%flagstruct%hydrostatic) then
if (Atm%flagstruct%make_nh) then ! Hydrostatic restarts dont have these variables
@@ -293,17 +317,15 @@ subroutine fv_io_register_restart(Atm)
call register_restart_field(Atm%Fv_restart_tile, 'delp', Atm%delp, dim_names_4d3)
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
- 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, 'u')) then
+ 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"))
+ endif
+ if (variable_exists(Atm%Fv_restart_tile, 'v')) then
+ 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"))
+ endif
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"))
@@ -322,9 +344,11 @@ subroutine fv_io_register_restart(Atm)
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
+ if (variable_exists(Atm%Fv_restart_tile, 'ua')) 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"))
+ endif
+ if (variable_exists(Atm%Fv_restart_tile, 'va')) then
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
@@ -459,6 +483,12 @@ subroutine fv_io_read_restart(fv_domain,Atm,prefix,directory)
call read_restart(Atm(1)%Fv_restart_tile, ignore_checksum=Atm(1)%flagstruct%ignore_rst_cksum)
call close_file(Atm(1)%Fv_restart_tile)
Atm(1)%Fv_restart_tile_is_open = .false.
+ if (Atm(1)%flagstruct%restart_from_agrid_winds) then
+ call cubed_a2d(Atm(1)%npx, Atm(1)%npy, Atm(1)%npz, &
+ Atm(1)%ua, Atm(1)%va, Atm(1)%u, Atm(1)%v, &
+ Atm(1)%gridstruct, Atm(1)%domain, Atm(1)%bd)
+ call mpp_update_domains(Atm(1)%u, Atm(1)%v, Atm(1)%domain, gridtype=DGRID_NE, complete=.true.)
+ endif
endif
!--- restore data for fv_tracer - if it exists
diff --git a/tools/fv_nggps_diag.F90 b/tools/fv_nggps_diag.F90
index 63b086699..f87cd0b07 100644
--- a/tools/fv_nggps_diag.F90
+++ b/tools/fv_nggps_diag.F90
@@ -75,7 +75,7 @@ module fv_nggps_diags_mod
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 gfdl_mp_mod, only: rad_ref
use fv_eta_mod, only: get_eta_level
#ifdef MULTI_GASES
use multi_gases_mod, only: virq
@@ -657,10 +657,11 @@ subroutine fv_nggps_diag(Atm, zvir, Time)
!--- 3-D Reflectivity field
if ( rainwat > 0 .and. id_dbz>0) then
- 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, &
- sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top) ! GFDL MP has constant N_0 intercept
+ call rad_ref(isco, ieco, jsco, jeco, isdo, iedo, jsdo, jedo, &
+ Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
+ wk, wk2, allmax, npzo, Atm(n)%ncnst, Atm(n)%flagstruct%hydrostatic, &
+ zvir, 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
diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90
index 363d30d26..8ae109b3f 100644
--- a/tools/fv_restart.F90
+++ b/tools/fv_restart.F90
@@ -123,7 +123,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
character(len=10) :: inputdir
character(len=6) :: gnn
- integer :: npts, sphum
+ integer :: npts, sphum, aero_id
integer, allocatable :: pelist(:), global_pelist(:), smoothed_topo(:)
real :: sumpertn
real :: zvir, nbg_inv
@@ -595,6 +595,13 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
endif
!---------------------------------------------------------------------------------------------
+ if (Atm(n)%flagstruct%do_aerosol) then
+ aero_id = get_tracer_index(MODEL_ATMOS, 'aerosol')
+ if (aero_id .gt. 0) then
+ Atm(n)%q(isc:iec,jsc:jec,:,aero_id) = 0.0
+ endif
+ endif
+
if (Atm(n)%flagstruct%add_noise > 0.) then
write(errstring,'(A, E16.9)') "Adding thermal noise of amplitude ", Atm(n)%flagstruct%add_noise
call mpp_error(NOTE, errstring)
@@ -640,6 +647,8 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
write(unit,*)
write(unit,*) 'fv_restart u ', trim(gn),' = ', mpp_chksum(Atm(n)%u(isc:iec,jsc:jec,:))
write(unit,*) 'fv_restart v ', trim(gn),' = ', mpp_chksum(Atm(n)%v(isc:iec,jsc:jec,:))
+ write(unit,*) 'fv_restart ua ', trim(gn),' = ', mpp_chksum(Atm(n)%ua(isc:iec,jsc:jec,:))
+ write(unit,*) 'fv_restart va ', trim(gn),' = ', mpp_chksum(Atm(n)%va(isc:iec,jsc:jec,:))
if ( .not.Atm(n)%flagstruct%hydrostatic ) &
write(unit,*) 'fv_restart w ', trim(gn),' = ', mpp_chksum(Atm(n)%w(isc:iec,jsc:jec,:))
write(unit,*) 'fv_restart delp', trim(gn),' = ', mpp_chksum(Atm(n)%delp(isc:iec,jsc:jec,:))
@@ -1323,6 +1332,8 @@ subroutine fv_restart_end(Atm)
write(unit,*)
write(unit,*) 'fv_restart_end u ', trim(gn),' = ', mpp_chksum(Atm%u(isc:iec,jsc:jec,:))
write(unit,*) 'fv_restart_end v ', trim(gn),' = ', mpp_chksum(Atm%v(isc:iec,jsc:jec,:))
+ write(unit,*) 'fv_restart_end ua ', trim(gn),' = ', mpp_chksum(Atm%ua(isc:iec,jsc:jec,:))
+ write(unit,*) 'fv_restart_end va ', trim(gn),' = ', mpp_chksum(Atm%va(isc:iec,jsc:jec,:))
if ( .not. Atm%flagstruct%hydrostatic ) &
write(unit,*) 'fv_restart_end w ', trim(gn),' = ', mpp_chksum(Atm%w(isc:iec,jsc:jec,:))
write(unit,*) 'fv_restart_end delp', trim(gn),' = ', mpp_chksum(Atm%delp(isc:iec,jsc:jec,:))
diff --git a/tools/rad_ref.F90 b/tools/rad_ref.F90
deleted file mode 100644
index 2b79ed0d1..000000000
--- a/tools/rad_ref.F90
+++ /dev/null
@@ -1,235 +0,0 @@
-!***********************************************************************
-!* 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/test_cases.F90 b/tools/test_cases.F90
index 034a91fde..cd132b925 100644
--- a/tools/test_cases.F90
+++ b/tools/test_cases.F90
@@ -42,7 +42,7 @@ module test_cases_mod
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 gfdl_mp_mod, only: mqs3d
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
@@ -3843,7 +3843,7 @@ subroutine rankine_vortex(ubar, r0, p1, u, v, grid, bd )
real, intent(in):: ubar ! max wind (m/s)
real, intent(in):: r0 ! Radius of max wind (m)
- real, intent(in):: p1(2) ! center position (longitude, latitude) in radian
+ real(kind=R_GRID), intent(in):: p1(2) ! center position (longitude, latitude) in radian
real, intent(inout):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
real, intent(inout):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed)
real(kind=R_GRID), intent(IN) :: grid(bd%isd:bd%ied+1,bd%jsd:bd%jed+1,2)
@@ -3928,8 +3928,9 @@ end subroutine rankine_vortex
real function gh_jet(npy, lat_in)
integer, intent(in):: npy
- real, intent(in):: lat_in
- real lat, lon, dp, uu
+ real(kind=R_GRID), intent(in):: lat_in
+ real(kind=R_GRID) lat, lon, dp
+ real uu
real h0, ft
integer j,jm
@@ -3974,7 +3975,7 @@ real function gh_jet(npy, lat_in)
end function gh_jet
real function u_jet(lat)
- real lat, lon, dp
+ real(kind=R_GRID) lat, lon, dp
real umax, en, ph0, ph1
umax = 80.
@@ -3992,7 +3993,7 @@ end function u_jet
subroutine get_case9_B(B, agrid, isd, ied, jsd, jed)
integer, intent(IN) :: isd, ied, jsd, jed
real, intent(OUT) :: B(isd:ied,jsd:jed)
- real, intent(IN) :: agrid(isd:ied,jsd:jed,2)
+ real(kind=R_GRID), intent(IN) :: agrid(isd:ied,jsd:jed,2)
real :: myC,yy,myB
integer :: i,j
! Generate B forcing function
@@ -4669,7 +4670,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
do i=is,ie
pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
enddo
- call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
+ call mqs3d(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
do i=is,ie
q(i,j,k,1) = max(2.E-6, 0.8*pm(i)/ps(i,j)*qs(i) )
enddo
@@ -5494,7 +5495,7 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
do i=is,ie
pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
enddo
- call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
+ call mqs3d(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
do i=is,ie
if ( pm(i) > 100.E2 ) then
q(i,j,k,1) = 0.9*qs(i)
@@ -5917,7 +5918,7 @@ end subroutine superK_u
subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
- use gfdl_mp_mod, only: wqsat_moist, qsmith_init, qs_blend
+ use gfdl_mp_mod, only: qs_init, wqs, mqs
! Morris Weisman & J. Klemp 2002 sounding
! Output sounding on pressure levels:
integer, intent(in):: km
@@ -5947,7 +5948,7 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
write(*,*) 'Computing sounding for super-cell test'
endif
- call qsmith_init
+ call qs_init
dz0 = 50.
zs(ns) = 0.
@@ -5992,7 +5993,7 @@ subroutine SuperCell_Sounding(km, ps, pk1, tp, qp)
! if ( (is_master()) ) write(*,*) k, temp1, rh(k)
if ( pk(k) > 0. ) then
pp(k) = exp(log(pk(k))/kappa)
- qs(k) = min(qv0, rh(k)*wqsat_moist(temp1, qs(k), pp(k)))
+ qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k)))
!qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k)))
!if ( (is_master()) ) write(*,*) 0.001*pp(k), qs(k)
else
@@ -6031,7 +6032,7 @@ 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
+ use gfdl_mp_mod, only: qs_init, wqs, mqs
! Morris Weisman & J. Klemp 2002 sounding
! Output sounding on pressure levels:
integer, intent(in):: km
@@ -6061,7 +6062,7 @@ subroutine SuperCell_Sounding_Marine(km, ps, pk1, tp, qp)
write(*,*) 'Computing sounding for super-cell test'
endif
- !call qsmith_init
+ !call qs_init
dz0 = 50.
zs(ns) = 0.
@@ -6113,9 +6114,9 @@ subroutine SuperCell_Sounding_Marine(km, ps, pk1, tp, qp)
!#else
!
!#ifdef USE_MIXED_TABLE
-! qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k)))
+! qs(k) = min(qv0, rh(k)*mqs(temp1, pp(k), qs(k)))
!#else
-! qs(k) = min(qv0, rh(k)*wqsat_moist(temp1, qs(k), pp(k)))
+! qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k)))
!#endif
!
!#endif
@@ -6155,7 +6156,7 @@ 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
+ use gfdl_mp_mod, only: qs_init, wqs, mqs
! JASMINE CETRONE AND ROBERT A. HOUZE JR. MWR 225
! Output sounding on pressure levels:
integer, intent(in):: km
@@ -6186,7 +6187,7 @@ subroutine Marine_Sounding(km, ps, pk1, tp, qp)
write(*,*) 'Computing sounding for super-cell test'
endif
- call qsmith_init
+ call qs_init
dz0 = 50.
zs(ns) = 0.
@@ -6240,9 +6241,9 @@ subroutine Marine_Sounding(km, ps, pk1, tp, qp)
#else
#ifdef USE_MIXED_TABLE
- qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k)))
+ qs(k) = min(qv0, rh(k)*mqs(temp1, pp(k), qs(k)))
#else
- qs(k) = min(qv0, rh(k)*wqsat_moist(temp1, qs(k), pp(k)))
+ qs(k) = min(qv0, rh(k)*wqs(temp1, pp(k), qs(k)))
#endif
#endif