diff --git a/driver/SHiELD/atmosphere.F90 b/driver/SHiELD/atmosphere.F90
index 22e9bfdfc..3fa697855 100644
--- a/driver/SHiELD/atmosphere.F90
+++ b/driver/SHiELD/atmosphere.F90
@@ -90,6 +90,11 @@ 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 sa_tke_edmf_mod, only: sa_tke_edmf_init
+use sa_tke_edmf_new_mod,only: sa_tke_edmf_new_init
+use sa_sas_mod, only: sa_sas_init
+use sa_aamf_mod, only: sa_aamf_init
+use sa_gwd_mod, only: sa_gwd_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
@@ -331,6 +336,15 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area, IAU_Data
allocate(pref(npz+1,2), dum1d(npz+1))
call gfdl_mp_init(input_nml_file, stdlog(), Atm(mygrid)%flagstruct%hydrostatic)
+ if (Atm(mygrid)%flagstruct%do_inline_pbl) then
+ if (Atm(mygrid)%flagstruct%inline_pbl_flag .eq. 1) call sa_tke_edmf_init(input_nml_file, stdlog())
+ if (Atm(mygrid)%flagstruct%inline_pbl_flag .eq. 2) call sa_tke_edmf_new_init(input_nml_file, stdlog())
+ endif
+ if (Atm(mygrid)%flagstruct%do_inline_cnv) then
+ if (Atm(mygrid)%flagstruct%inline_cnv_flag .eq. 1) call sa_sas_init(input_nml_file, stdlog())
+ if (Atm(mygrid)%flagstruct%inline_cnv_flag .eq. 2) call sa_aamf_init(input_nml_file, stdlog())
+ endif
+ if (Atm(mygrid)%flagstruct%do_inline_gwd) call sa_gwd_init(input_nml_file, stdlog())
call timing_on('FV_RESTART')
call fv_restart(Atm(mygrid)%domain, Atm, dt_atmos, seconds, days, cold_start, &
@@ -545,6 +559,7 @@ subroutine atmosphere_dynamics ( Time )
Atm(n)%flagstruct, Atm(n)%neststruct, &
Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, &
Atm(n)%parent_grid, Atm(n)%domain, Atm(n)%inline_mp, &
+ Atm(n)%inline_pbl, Atm(n)%inline_cnv, Atm(n)%inline_gwd, &
Atm(n)%heat_source,Atm(n)%diss_est,time_total=time_total)
call timing_off('FV_DYNAMICS')
@@ -722,11 +737,11 @@ subroutine atmosphere_resolution (i_size, j_size, global)
end subroutine atmosphere_resolution
subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num, &
- do_inline_mp, do_cosp)
+ do_inline_mp, do_inline_cnv, do_inline_pbl, do_inline_gwd, do_cosp)
integer, intent(out) :: i1, i2, j1, j2, kt
logical, intent(out), optional :: p_hydro, hydro
integer, intent(out), optional :: tile_num
- logical, intent(out), optional :: do_inline_mp, do_cosp
+ logical, intent(out), optional :: do_inline_mp, do_inline_cnv, do_inline_pbl, do_inline_gwd, do_cosp
i1 = Atm(mygrid)%bd%isc
i2 = Atm(mygrid)%bd%iec
j1 = Atm(mygrid)%bd%jsc
@@ -737,6 +752,9 @@ subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num
if (present( hydro)) hydro = Atm(mygrid)%flagstruct%hydrostatic
if (present(tile_num)) tile_num = Atm(mygrid)%global_tile
if (present(do_inline_mp)) do_inline_mp = Atm(mygrid)%flagstruct%do_inline_mp
+ if (present(do_inline_cnv)) do_inline_cnv = Atm(mygrid)%flagstruct%do_inline_cnv
+ if (present(do_inline_pbl)) do_inline_pbl = Atm(mygrid)%flagstruct%do_inline_pbl
+ if (present(do_inline_gwd)) do_inline_gwd = Atm(mygrid)%flagstruct%do_inline_gwd
if (present(do_cosp)) do_cosp = Atm(mygrid)%flagstruct%do_cosp
end subroutine atmosphere_control_data
@@ -1200,9 +1218,46 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block)
Atm(n)%delp(i,j,k1) = q0
Atm(n)%q(i,j,k1,1:nq_adv) = qwat(1:nq_adv) / q0
if (dnats .gt. 0) Atm(n)%q(i,j,k1,nq_adv+1:nq) = IPD_Data(nb)%Stateout%gq0(ix,k,nq_adv+1:nq)
+ if (Atm(n)%flagstruct%do_inline_pbl) Atm(n)%inline_pbl%radh(i,j,k1) = IPD_Data(nb)%Stateout%radh(ix,k)
enddo
enddo
+ if (Atm(n)%flagstruct%do_inline_pbl) then
+ do ix = 1, blen
+ i = Atm_block%index(nb)%ii(ix)
+ j = Atm_block%index(nb)%jj(ix)
+ Atm(n)%inline_pbl%lsm(i,j) = IPD_Data(nb)%Stateout%lsm(ix)
+ Atm(n)%inline_pbl%hflx(i,j) = IPD_Data(nb)%Stateout%hflx(ix)
+ Atm(n)%inline_pbl%evap(i,j) = IPD_Data(nb)%Stateout%evap(ix)
+ Atm(n)%inline_pbl%tsfc(i,j) = IPD_Data(nb)%Stateout%tsfc(ix)
+ Atm(n)%inline_pbl%vfrac(i,j) = IPD_Data(nb)%Stateout%vfrac(ix)
+ Atm(n)%inline_pbl%vtype(i,j) = IPD_Data(nb)%Stateout%vtype(ix)
+ Atm(n)%inline_pbl%ffmm(i,j) = IPD_Data(nb)%Stateout%ffmm(ix)
+ Atm(n)%inline_pbl%ffhh(i,j) = IPD_Data(nb)%Stateout%ffhh(ix)
+ Atm(n)%inline_pbl%snowd(i,j) = IPD_Data(nb)%Stateout%snowd(ix)
+ Atm(n)%inline_pbl%zorl(i,j) = IPD_Data(nb)%Stateout%zorl(ix)
+ Atm(n)%inline_pbl%ztrl(i,j) = IPD_Data(nb)%Stateout%ztrl(ix)
+ Atm(n)%inline_pbl%uustar(i,j) = IPD_Data(nb)%Stateout%uustar(ix)
+ Atm(n)%inline_pbl%shdmax(i,j) = IPD_Data(nb)%Stateout%shdmax(ix)
+ Atm(n)%inline_pbl%sfcemis(i,j) = IPD_Data(nb)%Stateout%sfcemis(ix)
+ Atm(n)%inline_pbl%dlwflx(i,j) = IPD_Data(nb)%Stateout%dlwflx(ix)
+ Atm(n)%inline_pbl%sfcnsw(i,j) = IPD_Data(nb)%Stateout%sfcnsw(ix)
+ Atm(n)%inline_pbl%sfcdsw(i,j) = IPD_Data(nb)%Stateout%sfcdsw(ix)
+ Atm(n)%inline_pbl%srflag(i,j) = IPD_Data(nb)%Stateout%srflag(ix)
+ Atm(n)%inline_pbl%hice(i,j) = IPD_Data(nb)%Stateout%hice(ix)
+ Atm(n)%inline_pbl%fice(i,j) = IPD_Data(nb)%Stateout%fice(ix)
+ Atm(n)%inline_pbl%tice(i,j) = IPD_Data(nb)%Stateout%tice(ix)
+ Atm(n)%inline_pbl%weasd(i,j) = IPD_Data(nb)%Stateout%weasd(ix)
+ Atm(n)%inline_pbl%qsurf(i,j) = IPD_Data(nb)%Stateout%qsurf(ix)
+ Atm(n)%inline_pbl%cmm(i,j) = IPD_Data(nb)%Stateout%cmm(ix)
+ Atm(n)%inline_pbl%chh(i,j) = IPD_Data(nb)%Stateout%chh(ix)
+ Atm(n)%inline_pbl%gflux(i,j) = IPD_Data(nb)%Stateout%gflux(ix)
+ Atm(n)%inline_pbl%ep(i,j) = IPD_Data(nb)%Stateout%ep(ix)
+ Atm(n)%inline_pbl%tprcp(i,j) = IPD_Data(nb)%Stateout%tprcp(ix)
+ Atm(n)%inline_pbl%stc(i,j,:) = IPD_Data(nb)%Stateout%stc(ix,:)
+ enddo
+ endif
+
!GFDL if ( dnats > 0 ) then
!GFDL do iq = nq-dnats+1, nq
!GFDL do k = 1, npz
@@ -1474,7 +1529,8 @@ subroutine adiabatic_init(zvir,nudge_dz)
Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, &
Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, &
Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, &
- Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
+ Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%inline_pbl, &
+ Atm(mygrid)%inline_cnv, Atm(mygrid)%inline_gwd, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
! Backward
call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, -dt_atmos, 0., &
Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, &
@@ -1488,7 +1544,8 @@ subroutine adiabatic_init(zvir,nudge_dz)
Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, &
Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, &
Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, &
- Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
+ Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%inline_pbl, &
+ Atm(mygrid)%inline_cnv, Atm(mygrid)%inline_gwd, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
! Nudging back to IC
!$omp parallel do default (none) &
!$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mygrid, nudge_dz, dz0) &
@@ -1560,7 +1617,8 @@ subroutine adiabatic_init(zvir,nudge_dz)
Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, &
Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, &
Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, &
- Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
+ Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%inline_pbl, &
+ Atm(mygrid)%inline_cnv, Atm(mygrid)%inline_gwd, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
! Forward call
call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, dt_atmos, 0., &
Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, &
@@ -1574,7 +1632,8 @@ subroutine adiabatic_init(zvir,nudge_dz)
Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, &
Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, Atm(mygrid)%neststruct, &
Atm(mygrid)%thermostruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, &
- Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
+ Atm(mygrid)%domain, Atm(mygrid)%inline_mp, Atm(mygrid)%inline_pbl, &
+ Atm(mygrid)%inline_cnv, Atm(mygrid)%inline_gwd, Atm(mygrid)%heat_source,Atm(mygrid)%diss_est)
! Nudging back to IC
!$omp parallel do default (none) &
!$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mygrid) &
@@ -1697,6 +1756,56 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block)
enddo
endif
+ if (Atm(mygrid)%flagstruct%do_inline_cnv) then
+ do ix = 1, blen
+ i = Atm_block%index(nb)%ii(ix)
+ j = Atm_block%index(nb)%jj(ix)
+ IPD_Data(nb)%Statein%prec(ix) = _DBL_((Atm(mygrid)%inline_cnv%prec(i,j)))
+ IPD_Data(nb)%Statein%ktop(ix) = _DBL_((Atm(mygrid)%inline_cnv%ktop(i,j)))
+ IPD_Data(nb)%Statein%kbot(ix) = _DBL_((Atm(mygrid)%inline_cnv%kbot(i,j)))
+ IPD_Data(nb)%Statein%kcnv(ix) = _DBL_((Atm(mygrid)%inline_cnv%kcnv(i,j)))
+ IPD_Data(nb)%Statein%cumabs(ix) = _DBL_((Atm(mygrid)%inline_cnv%cumabs(i,j)))
+ enddo
+ endif
+
+ if (Atm(mygrid)%flagstruct%do_inline_pbl) then
+ do ix = 1, blen
+ i = Atm_block%index(nb)%ii(ix)
+ j = Atm_block%index(nb)%jj(ix)
+ IPD_Data(nb)%Statein%hpbl(ix) = _DBL_((Atm(mygrid)%inline_pbl%hpbl(i,j)))
+ IPD_Data(nb)%Statein%kpbl(ix) = Atm(mygrid)%inline_pbl%kpbl(i,j)
+ IPD_Data(nb)%Statein%dusfc(ix) = _DBL_((Atm(mygrid)%inline_pbl%dusfc(i,j)))
+ IPD_Data(nb)%Statein%dvsfc(ix) = _DBL_((Atm(mygrid)%inline_pbl%dvsfc(i,j)))
+ IPD_Data(nb)%Statein%dtsfc(ix) = _DBL_((Atm(mygrid)%inline_pbl%dtsfc(i,j)))
+ IPD_Data(nb)%Statein%dqsfc(ix) = _DBL_((Atm(mygrid)%inline_pbl%dqsfc(i,j)))
+ IPD_Data(nb)%Statein%lsm(ix) = Atm(mygrid)%inline_pbl%lsm(i,j)
+ IPD_Data(nb)%Statein%hflx(ix) = _DBL_((Atm(mygrid)%inline_pbl%hflx(i,j)))
+ IPD_Data(nb)%Statein%evap(ix) = _DBL_((Atm(mygrid)%inline_pbl%evap(i,j)))
+ IPD_Data(nb)%Statein%tsfc(ix) = _DBL_((Atm(mygrid)%inline_pbl%tsfc(i,j)))
+ IPD_Data(nb)%Statein%vfrac(ix) = _DBL_((Atm(mygrid)%inline_pbl%vfrac(i,j)))
+ IPD_Data(nb)%Statein%vtype(ix) = _DBL_((Atm(mygrid)%inline_pbl%vtype(i,j)))
+ IPD_Data(nb)%Statein%ffmm(ix) = _DBL_((Atm(mygrid)%inline_pbl%ffmm(i,j)))
+ IPD_Data(nb)%Statein%ffhh(ix) = _DBL_((Atm(mygrid)%inline_pbl%ffhh(i,j)))
+ IPD_Data(nb)%Statein%snowd(ix) = _DBL_((Atm(mygrid)%inline_pbl%snowd(i,j)))
+ IPD_Data(nb)%Statein%zorl(ix) = _DBL_((Atm(mygrid)%inline_pbl%zorl(i,j)))
+ IPD_Data(nb)%Statein%ztrl(ix) = _DBL_((Atm(mygrid)%inline_pbl%ztrl(i,j)))
+ IPD_Data(nb)%Statein%uustar(ix) = _DBL_((Atm(mygrid)%inline_pbl%uustar(i,j)))
+ IPD_Data(nb)%Statein%shdmax(ix) = _DBL_((Atm(mygrid)%inline_pbl%shdmax(i,j)))
+ IPD_Data(nb)%Statein%srflag(ix) = _DBL_((Atm(mygrid)%inline_pbl%srflag(i,j)))
+ IPD_Data(nb)%Statein%hice(ix) = _DBL_((Atm(mygrid)%inline_pbl%hice(i,j)))
+ IPD_Data(nb)%Statein%fice(ix) = _DBL_((Atm(mygrid)%inline_pbl%fice(i,j)))
+ IPD_Data(nb)%Statein%tice(ix) = _DBL_((Atm(mygrid)%inline_pbl%tice(i,j)))
+ IPD_Data(nb)%Statein%weasd(ix) = _DBL_((Atm(mygrid)%inline_pbl%weasd(i,j)))
+ IPD_Data(nb)%Statein%qsurf(ix) = _DBL_((Atm(mygrid)%inline_pbl%qsurf(i,j)))
+ IPD_Data(nb)%Statein%cmm(ix) = _DBL_((Atm(mygrid)%inline_pbl%cmm(i,j)))
+ IPD_Data(nb)%Statein%chh(ix) = _DBL_((Atm(mygrid)%inline_pbl%chh(i,j)))
+ IPD_Data(nb)%Statein%gflux(ix) = _DBL_((Atm(mygrid)%inline_pbl%gflux(i,j)))
+ IPD_Data(nb)%Statein%ep(ix) = _DBL_((Atm(mygrid)%inline_pbl%ep(i,j)))
+ IPD_Data(nb)%Statein%tprcp(ix) = _DBL_((Atm(mygrid)%inline_pbl%tprcp(i,j)))
+ IPD_Data(nb)%Statein%stc(ix,:) = _DBL_((Atm(mygrid)%inline_pbl%stc(i,j,:)))
+ enddo
+ endif
+
do k = 1, npz
do ix = 1, blen
i = Atm_block%index(nb)%ii(ix)
diff --git a/driver/solo/atmosphere.F90 b/driver/solo/atmosphere.F90
index f1c8d94c9..b647cae25 100644
--- a/driver/solo/atmosphere.F90
+++ b/driver/solo/atmosphere.F90
@@ -53,6 +53,11 @@ module atmosphere_mod
use fv_dynamics_mod, only: fv_dynamics
use fv_nesting_mod, only: twoway_nesting
use gfdl_mp_mod, only: gfdl_mp_init, gfdl_mp_end
+use sa_tke_edmf_mod, only: sa_tke_edmf_init
+use sa_tke_edmf_new_mod,only: sa_tke_edmf_new_init
+use sa_sas_mod, only: sa_sas_init
+use sa_aamf_mod, only: sa_aamf_init
+use sa_gwd_mod, only: sa_gwd_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,7 +168,18 @@ subroutine atmosphere_init ( Time_init, Time, Time_step )
Time, axes, Atm(mygrid)%gridstruct%agrid(isc:iec,jsc:jec,2))
endif
- if (.not. Atm(mygrid)%flagstruct%adiabatic) call gfdl_mp_init (input_nml_file, stdlog(), Atm(mygrid)%flagstruct%hydrostatic)
+ if (.not. Atm(mygrid)%flagstruct%adiabatic) then
+ call gfdl_mp_init (input_nml_file, stdlog(), Atm(mygrid)%flagstruct%hydrostatic)
+ if (Atm(mygrid)%flagstruct%do_inline_pbl) then
+ if (Atm(mygrid)%flagstruct%inline_pbl_flag .eq. 1) call sa_tke_edmf_init(input_nml_file, stdlog())
+ if (Atm(mygrid)%flagstruct%inline_pbl_flag .eq. 2) call sa_tke_edmf_new_init(input_nml_file, stdlog())
+ endif
+ if (Atm(mygrid)%flagstruct%do_inline_cnv) then
+ if (Atm(mygrid)%flagstruct%inline_cnv_flag .eq. 1) call sa_sas_init(input_nml_file, stdlog())
+ if (Atm(mygrid)%flagstruct%inline_cnv_flag .eq. 2) call sa_aamf_init(input_nml_file, stdlog())
+ endif
+ if (Atm(mygrid)%flagstruct%do_inline_gwd) call sa_gwd_init(input_nml_file, stdlog())
+ endif
if ( Atm(mygrid)%flagstruct%nudge ) &
@@ -270,7 +286,8 @@ subroutine adiabatic_init(zvir, n)
Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, &
Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, &
Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid,&
- Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est)
+ Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%inline_pbl, Atm(n)%inline_cnv, &
+ Atm(n)%inline_gwd, Atm(n)%heat_source, Atm(n)%diss_est)
! Backward
call fv_dynamics(Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ncnst, Atm(n)%ng, -dt_atmos, 0., &
Atm(n)%flagstruct%fill, Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir, &
@@ -284,7 +301,8 @@ subroutine adiabatic_init(zvir, n)
Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, &
Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, &
Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, &
- Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est)
+ Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%inline_pbl, Atm(n)%inline_cnv, &
+ Atm(n)%inline_gwd, Atm(n)%heat_source, Atm(n)%diss_est)
! Nudging back to IC
!$omp parallel do default(shared)
do k=1,npz
@@ -331,7 +349,8 @@ subroutine adiabatic_init(zvir, n)
Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, &
Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, &
Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, &
- Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est)
+ Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%inline_pbl, Atm(n)%inline_cnv, &
+ Atm(n)%inline_gwd, Atm(n)%heat_source, Atm(n)%diss_est)
! Forwardward call
call fv_dynamics(Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ncnst, Atm(n)%ng, dt_atmos, 0., &
Atm(n)%flagstruct%fill, Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir, &
@@ -345,7 +364,8 @@ subroutine adiabatic_init(zvir, n)
Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, &
Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, &
Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, &
- Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est)
+ Atm(n)%domain, Atm(n)%inline_mp, Atm(n)%inline_pbl, Atm(n)%inline_cnv, &
+ Atm(n)%inline_gwd, Atm(n)%heat_source, Atm(n)%diss_est)
! Nudging back to IC
!$omp parallel do default(shared)
do k=1,npz
@@ -438,7 +458,8 @@ subroutine atmosphere (Time)
Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, &
Atm(n)%ze0, Atm(n)%flagstruct%hybrid_z, Atm(n)%gridstruct, Atm(n)%flagstruct, &
Atm(n)%neststruct, Atm(n)%thermostruct, Atm(n)%idiag, Atm(n)%bd, Atm(n)%parent_grid, Atm(n)%domain, &
- Atm(n)%inline_mp, Atm(n)%heat_source, Atm(n)%diss_est, time_total=time_total)
+ Atm(n)%inline_mp, Atm(n)%inline_pbl, Atm(n)%inline_cnv, Atm(n)%inline_gwd, &
+ Atm(n)%heat_source, Atm(n)%diss_est, time_total=time_total)
call timing_off('FV_DYNAMICS')
if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then
diff --git a/model/dyn_core.F90 b/model/dyn_core.F90
index 2245681b8..1dc12b8ff 100644
--- a/model/dyn_core.F90
+++ b/model/dyn_core.F90
@@ -53,6 +53,7 @@ module dyn_core_mod
use diag_manager_mod, only: send_data
use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_diag_type
use fv_arrays_mod, only: fv_grid_bounds_type, R_GRID, fv_nest_BC_type_3d, fv_thermo_type
+ use fv_arrays_mod, only: inline_pbl_type, inline_gwd_type
use boundary_mod, only: extrapolation_BC, nested_grid_BC_apply_intT
use fv_regional_mod, only: regional_boundary_update
@@ -95,7 +96,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
u, v, w, delz, pt, q, delp, pe, pk, phis, ws, omga, ptop, pfull, ua, va, &
uc, vc, mfx, mfy, cx, cy, pkz, peln, q_con, ak, bk, &
ks, gridstruct, flagstruct, neststruct, thermostruct, idiag, bd, domain, &
- init_step, i_pack, end_step, heat_source, diss_est, consv, te0_2d, time_total)
+ init_step, i_pack, end_step, heat_source, diss_est, consv, te0_2d, inline_pbl, inline_gwd, time_total)
integer, intent(IN) :: npx
integer, intent(IN) :: npy
integer, intent(IN) :: npz
@@ -133,6 +134,9 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
real, intent(inout):: peln(bd%is:bd%ie,npz+1,bd%js:bd%je) ! ln(pe)
real, intent(inout):: pk(bd%is:bd%ie,bd%js:bd%je, npz+1) ! pe**kappa
+ type(inline_pbl_type), intent(inout):: inline_pbl
+ type(inline_gwd_type), intent(inout):: inline_gwd
+
!-----------------------------------------------------------------------
! Others:
real, parameter:: near0 = 1.E-8
@@ -1102,11 +1106,12 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
call timing_on('FAST_PHYS')
- call fast_phys (is, ie, js, je, isd, ied, jsd, jed, npz, npx, npy, nq, &
+ call fast_phys (is, ie, js, je, isd, ied, jsd, jed, npz, npx, npy, nq, flagstruct%nwat, &
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, &
+ delp, delz, q_con, cappa, q, pkz, zvir, flagstruct%te_err, flagstruct%tw_err, inline_pbl, inline_gwd, &
gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, &
- flagstruct%consv_checker, flagstruct%adj_mass_vmr)
+ flagstruct%do_inline_pbl, flagstruct%do_inline_gwd, flagstruct%consv_checker, flagstruct%adj_mass_vmr, &
+ flagstruct%inline_pbl_flag)
call timing_on('COMM_TOTAL')
!some mpp domains updates are commented out at this moment -- Linjiong
@@ -1139,6 +1144,23 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp,
call pe_halo (is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, delp)
endif
+ if (idiag%id_inline_pbl_fast_te_a_chg>0) &
+ used = send_data(idiag%id_inline_pbl_fast_te_a_chg, inline_pbl%fast_te_a_chg, fv_time)
+ if (idiag%id_inline_pbl_fast_te_b_chg>0) &
+ used = send_data(idiag%id_inline_pbl_fast_te_b_chg, inline_pbl%fast_te_b_chg, fv_time)
+ if (idiag%id_inline_pbl_fast_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_pbl_fast_tw_a_chg, inline_pbl%fast_tw_a_chg, fv_time)
+ if (idiag%id_inline_pbl_fast_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_pbl_fast_tw_b_chg, inline_pbl%fast_tw_b_chg, fv_time)
+ if (idiag%id_inline_gwd_fast_te_a_chg>0) &
+ used = send_data(idiag%id_inline_gwd_fast_te_a_chg, inline_gwd%fast_te_a_chg, fv_time)
+ if (idiag%id_inline_gwd_fast_te_b_chg>0) &
+ used = send_data(idiag%id_inline_gwd_fast_te_b_chg, inline_gwd%fast_te_b_chg, fv_time)
+ if (idiag%id_inline_gwd_fast_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_gwd_fast_tw_a_chg, inline_gwd%fast_tw_a_chg, fv_time)
+ if (idiag%id_inline_gwd_fast_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_gwd_fast_tw_b_chg, inline_gwd%fast_tw_b_chg, fv_time)
+
call timing_off('FAST_PHYS')
endif
diff --git a/model/fast_phys.F90 b/model/fast_phys.F90
index 69077dd13..7047e0234 100644
--- a/model/fast_phys.F90
+++ b/model/fast_phys.F90
@@ -28,19 +28,24 @@
module fast_phys_mod
#ifdef OVERLOAD_R4
- use constantsR4_mod, only: rdgas, grav
+ use constantsR4_mod, only: rdgas, rvgas, grav, kappa, cp_air
#else
- use constants_mod, only: rdgas, grav
+ use constants_mod, only: rdgas, rvgas, grav, kappa, cp_air
#endif
use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys
use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, fv_thermo_type
+ use fv_arrays_mod, only: inline_pbl_type, inline_gwd_type
use mpp_domains_mod, only: domain2d, mpp_update_domains
use tracer_manager_mod, only: get_tracer_index, get_tracer_names
use field_manager_mod, only: model_atmos
- use gfdl_mp_mod, only: mtetw
-
+ use gfdl_mp_mod, only: c_liq, c_ice, cv_air, cv_vap, hlv, mtetw, tice
+ use sa_tke_edmf_mod, only: sa_tke_edmf_sfc, sa_tke_edmf_pbl
+ use sa_tke_edmf_new_mod, only: sa_tke_edmf_new_sfc, sa_tke_edmf_new_pbl
+ use sa_gwd_mod, only: sa_gwd_oro
+ use fv_timing_mod, only: timing_on, timing_off
+
implicit none
-
+
private
real, parameter :: consv_min = 0.001
@@ -52,24 +57,25 @@ module fast_phys_mod
! -----------------------------------------------------------------------
integer, parameter :: r8 = 8 ! double precision
-
+
contains
-subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, &
+subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, &
mdt, consv, akap, ptop, hs, te0_2d, u, v, w, pt, &
- delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, &
+ delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, inline_pbl, inline_gwd, &
gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, &
- consv_checker, adj_mass_vmr)
-
+ do_inline_pbl, do_inline_gwd, consv_checker, adj_mass_vmr, inline_pbl_flag)
+
implicit none
-
+
! -----------------------------------------------------------------------
! input / output arguments
! -----------------------------------------------------------------------
- integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, adj_mass_vmr
+ integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, adj_mass_vmr, inline_pbl_flag
- logical, intent (in) :: hydrostatic, do_adiabatic_init, consv_checker
+ logical, intent (in) :: hydrostatic, do_adiabatic_init, do_inline_pbl, do_inline_gwd
+ logical, intent (in) :: consv_checker
real, intent (in) :: consv, mdt, akap, r_vir, ptop, te_err, tw_err
@@ -99,32 +105,41 @@ subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, &
type (domain2d), intent (inout) :: domain
+ type (inline_pbl_type), intent (inout) :: inline_pbl
+
+ type (inline_gwd_type), intent (inout) :: inline_gwd
! -----------------------------------------------------------------------
! local variables
! -----------------------------------------------------------------------
+ logical :: safety_check = .true.
+
logical, allocatable, dimension (:) :: conv_vmr_mmr
- integer :: i, j, k, m, kmp, sphum, liq_wat, ice_wat
+ integer :: i, j, k, m, kr, kmp, ncld, ntke, sphum, liq_wat, ice_wat, lsoil
integer :: rainwat, snowwat, graupel, cld_amt, ccn_cm3, cin_cm3, aerosol
real :: rrg
- real, dimension (is:ie) :: gsize
+ real, dimension (is:ie) :: gsize, dqv, dql, dqi, dqr, dqs, dqg, ps_dt, q_liq, q_sol, c_moist
- real, dimension (is:ie, km) :: q2, q3, qliq, qsol, adj_vmr
+ real, dimension (is:ie, km) :: q2, q3, qliq, qsol, cvm, 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
+ integer, allocatable, dimension (:) :: kinver, vegtype
- real, allocatable, dimension (:,:) :: dz, wa
+ real, allocatable, dimension (:) :: rn, rb, u10m, v10m, sigmaf, stress, wind, tmp, wz
+
+ real, allocatable, dimension (:) :: dtsfc, dqvsfc, dqlsfc, dqisfc, dqrsfc, dqssfc, dqgsfc
+
+ real, allocatable, dimension (:,:) :: dz, zm, zi, wa, dp, pm, pi, pmk, pik, qv, ql, ta, uu, vv, ww, radh
+
+ real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0, qa
- 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
@@ -143,6 +158,7 @@ subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, &
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')
+ ntke = get_tracer_index (model_atmos, 'sgs_tke')
rrg = - rdgas / grav
@@ -184,6 +200,960 @@ subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, &
enddo
endif
+ !-----------------------------------------------------------------------
+ ! Inline Planetary Boundary Layer >>>
+ !-----------------------------------------------------------------------
+
+ if ((.not. do_adiabatic_init) .and. do_inline_pbl) then
+
+ allocate (kinver (is:ie))
+
+ allocate (dz (is:ie, 1:km))
+ allocate (zm (is:ie, 1:km))
+ allocate (zi (is:ie, 1:km+1))
+ allocate (dp (is:ie, 1:km))
+ allocate (pm (is:ie, 1:km))
+ allocate (pi (is:ie, 1:km+1))
+ allocate (pmk (is:ie, 1:km))
+ allocate (pik (is:ie, 1:km+1))
+
+ allocate (ta (is:ie, 1:km))
+ allocate (uu (is:ie, 1:km))
+ allocate (vv (is:ie, 1:km))
+ allocate (qa (is:ie, 1:km, 1:nq))
+
+ allocate (radh (is:ie, 1:km))
+ allocate (rb (is:ie))
+ allocate (u10m (is:ie))
+ allocate (v10m (is:ie))
+ allocate (stress (is:ie))
+ allocate (wind (is:ie))
+ allocate (sigmaf (is:ie))
+ allocate (vegtype (is:ie))
+
+ allocate (dtsfc (is:ie))
+ allocate (dqvsfc (is:ie))
+ allocate (dqlsfc (is:ie))
+ allocate (dqisfc (is:ie))
+ allocate (dqrsfc (is:ie))
+ allocate (dqssfc (is:ie))
+ allocate (dqgsfc (is:ie))
+
+ allocate (tz (1:km))
+ allocate (wz (1:km))
+
+ allocate (u_dt (isd:ied, jsd:jed, km))
+ allocate (v_dt (isd:ied, jsd:jed, 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, 4, bd)
+
+ ! save delp
+ if (consv .gt. consv_min) then
+ allocate (dp0 (isd:ied, jsd:jed, km))
+ dp0 = delp
+ endif
+
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, km, nq, ua, va, w, &
+!$OMP te, delp, hydrostatic, hs, pt, delz, q_con, &
+!$OMP rainwat, liq_wat, ice_wat, snowwat, graupel, &
+!$OMP sphum, pkz, consv, te0_2d, gridstruct, q, &
+!$OMP mdt, cappa, rrg, akap, r_vir, u_dt, v_dt, &
+!$OMP ptop, ntke, inline_pbl, safety_check, nwat, &
+!$OMP adj_mass_vmr, conv_vmr_mmr, consv_checker, &
+!$OMP te_err, tw_err, inline_pbl_flag, thermostruct) &
+!$OMP private (gsize, dz, zi, pi, pik, pmk, lsoil, pe, &
+!$OMP zm, dp, pm, ta, uu, vv, qliq, qsol, qa, adj_vmr, &
+!$OMP radh, rb, u10m, v10m, sigmaf, vegtype, q_liq, &
+!$OMP stress, wind, kinver, q_sol, c_moist, peln, &
+!$OMP cvm, kr, dqv, dql, dqi, dqr, dqs, dqg, ps_dt, &
+!$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, &
+!$OMP dtsfc, dqvsfc, dqlsfc, dqisfc, dqrsfc, dqssfc, dqgsfc)
+
+ do j = js, je
+
+ ! grid size
+ gsize (is:ie) = sqrt (gridstruct%area_64 (is:ie, j))
+
+ ! save ua, va for wind tendency calculation
+ u_dt (is:ie, j, 1:km) = ua (is:ie, j, 1:km)
+ v_dt (is:ie, j, 1:km) = va (is:ie, j, 1:km)
+
+ kinver = km
+ lsoil = 4
+
+ ! total energy before parameterization
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = - cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_beg (is:ie, 1:km) = 0.0
+ tw_beg (is:ie, 1:km) = 0.0
+ te_b_beg (is:ie) = 0.0
+ tw_b_beg (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_beg (i, 1:km), tw_beg (i, 1: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 index flip over
+ zi (is:ie, 1) = 0.0
+ pi (is:ie, 1) = pe (is:ie, km+1)
+ pik (is:ie, 1) = exp (kappa * log (pi (is:ie, 1) * 1.e-5))
+ inline_pbl%dtsfc (is:ie, j) = 0.0
+ inline_pbl%dqsfc (is:ie, j) = 0.0
+ dtsfc (is:ie) = 0.0
+ dqvsfc (is:ie) = 0.0
+ dqlsfc (is:ie) = 0.0
+ dqisfc (is:ie) = 0.0
+ dqrsfc (is:ie) = 0.0
+ dqssfc (is:ie) = 0.0
+ dqgsfc (is:ie) = 0.0
+ inline_pbl%dusfc (is:ie, j) = 0.0
+ inline_pbl%dvsfc (is:ie, j) = 0.0
+ inline_pbl%dksfc (is:ie, j) = 0.0
+ do k = 1, km
+ kr = km - k + 1
+ dp (is:ie, k) = delp (is:ie, j, kr)
+ pi (is:ie, k+1) = pe (is:ie, kr)
+ pik (is:ie, k+1) = exp (kappa * log (pi (is:ie, k+1) * 1.e-5))
+ if (.not. hydrostatic) then
+ pm (is:ie, k) = dp (is:ie, k) / delz (is:ie, j, kr) * &
+ rrg * pt (is:ie, j, kr)
+ dz (is:ie, k) = delz (is:ie, j, kr)
+ ! ensure subgrid monotonicity of pressure
+ do i = is, ie
+ pm (i, k) = min (pm (i, k), pi (i, k) - 0.01 * pm (i, k))
+ pm (i, k) = max (pm (i, k), pi (i, k+1) + 0.01 * pm (i, k))
+ enddo
+ else
+ pm (is:ie, k) = dp (is:ie, k) / (peln (is:ie, kr+1) - peln (is:ie, kr))
+ dz (is:ie, k) = (peln (is:ie, kr+1) - peln (is:ie, kr)) * &
+ rrg * pt (is:ie, j, kr)
+ endif
+ pmk (is:ie, k) = exp (kappa * log (pm (is:ie, k) * 1.e-5))
+ zi (is:ie, k+1) = zi (is:ie, k) - dz (is:ie, k) * grav
+ if (k .eq. 1) then
+ zm (is:ie, k) = - 0.5 * dz (is:ie, k) * grav
+ else
+ zm (is:ie, k) = zm (is:ie, k-1) - 0.5 * (dz (is:ie, k-1) + dz (is:ie, k)) * grav
+ endif
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ ta (is:ie, k) = pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * &
+ (1. - (q_liq + q_sol)))
+ uu (is:ie, k) = ua (is:ie, j, kr)
+ vv (is:ie, k) = va (is:ie, j, kr)
+ qa (is:ie, k, 1:nq) = q (is:ie, j, kr, 1:nq)
+ radh (is:ie, k) = inline_pbl%radh (is:ie, j, kr)
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ inline_pbl%dtsfc (is:ie, j) = inline_pbl%dtsfc (is:ie, j) - cp_air * ta (is:ie, k) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dqsfc (is:ie, j) = inline_pbl%dqsfc (is:ie, j) - (hlv - rvgas * tice + (cv_vap - c_liq) * (ta (is:ie, k) - tice)) * q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dtsfc (is:ie) = dtsfc (is:ie) - c_moist * ta (is:ie, k) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqvsfc (is:ie) = dqvsfc (is:ie) - q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqlsfc (is:ie) = dqlsfc (is:ie) - q (is:ie, j, kr, liq_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqisfc (is:ie) = dqisfc (is:ie) - q (is:ie, j, kr, ice_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqrsfc (is:ie) = dqrsfc (is:ie) - q (is:ie, j, kr, rainwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqssfc (is:ie) = dqssfc (is:ie) - q (is:ie, j, kr, snowwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqgsfc (is:ie) = dqgsfc (is:ie) - q (is:ie, j, kr, graupel) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dusfc (is:ie, j) = inline_pbl%dusfc (is:ie, j) - ua (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dvsfc (is:ie, j) = inline_pbl%dvsfc (is:ie, j) - va (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dksfc (is:ie, j) = inline_pbl%dksfc (is:ie, j) - 0.5 * (ua (is:ie, j, kr) ** 2 + va (is:ie, j, kr) ** 2 + w (is:ie, j, kr) ** 2) * delp (is:ie, j, kr) / grav / abs (mdt)
+ enddo
+
+ do i = is, ie
+ sigmaf (i) = max (inline_pbl%vfrac (i, j), 0.01)
+ vegtype (i) = int (inline_pbl%vtype (i, j) + 0.5)
+ enddo
+
+ ! check if pressure or height cross over
+ if (safety_check) then
+ do k = 1, km
+ do i = is, ie
+ if (k .lt. km) then
+ if (pm (i, k) .le. pm (i, k+1)) then
+ print*, "Warning: inline edmf pressure layer cross over", k, pm (i, k), pm (i, k+1)
+ endif
+ if (zm (i, k) .ge. zm (i, k+1)) then
+ print*, "Warning: inline edmf height layer cross over", k, zm (i, k), zm (i, k+1)
+ endif
+ endif
+ if (pi (i, k) .le. pi (i, k+1)) then
+ print*, "Warning: inline edmf pressure interface cross over", k, pi (i, k), pi (i, k+1)
+ endif
+ if (zi (i, k) .ge. zi (i, k+1)) then
+ print*, "Warning: inline edmf height interface cross over", k, zi (i, k), zi (i, k+1)
+ endif
+ enddo
+ enddo
+ endif
+
+ if (inline_pbl_flag .eq. 1) then
+
+ ! diagnose surface variables for PBL parameterization
+ call sa_tke_edmf_sfc (ie-is+1, lsoil, pi (is:ie, 1), uu (is:ie, 1), &
+ vv (is:ie, 1), ta (is:ie, 1), qa (is:ie, 1, sphum), &
+ abs (mdt), inline_pbl%tsfc (is:ie, j), pm (is:ie, 1), &
+ pik (is:ie, 1) / pmk (is:ie, 1), inline_pbl%evap (is:ie, j), &
+ inline_pbl%hflx (is:ie, j), inline_pbl%ffmm (is:ie, j), &
+ inline_pbl%ffhh (is:ie, j), zm (is:ie, 1) / grav, &
+ inline_pbl%snowd (is:ie, j), inline_pbl%zorl (is:ie, j), inline_pbl%ztrl (is:ie, j), &
+ inline_pbl%lsm (is:ie, j), inline_pbl%uustar (is:ie, j), sigmaf, vegtype, &
+ inline_pbl%shdmax (is:ie, j), inline_pbl%sfcemis (is:ie, j), &
+ inline_pbl%dlwflx (is:ie, j), inline_pbl%sfcnsw (is:ie, j), &
+ inline_pbl%sfcdsw (is:ie, j), inline_pbl%srflag (is:ie, j), &
+ inline_pbl%hice (is:ie, j), inline_pbl%fice (is:ie, j), &
+ inline_pbl%tice (is:ie, j), inline_pbl%weasd (is:ie, j), &
+ inline_pbl%tprcp (is:ie, j), inline_pbl%stc (is:ie, j, :), &
+ inline_pbl%qsurf (is:ie, j), inline_pbl%cmm (is:ie, j), &
+ inline_pbl%chh (is:ie, j), inline_pbl%gflux (is:ie, j), &
+ inline_pbl%ep (is:ie, j), u10m_out = u10m, v10m_out = v10m, &
+ rb_out = rb, stress_out = stress, wind_out = wind)
+
+ ! SA-TKE-EDMF main program
+ call sa_tke_edmf_pbl (ie-is+1, km, nq, liq_wat, ice_wat, ntke, &
+ abs (mdt), uu, vv, ta, qa, gsize, inline_pbl%lsm (is:ie, j), &
+ radh, rb, inline_pbl%zorl (is:ie, j), u10m, v10m, &
+ inline_pbl%ffmm (is:ie, j), inline_pbl%ffhh (is:ie, j), &
+ inline_pbl%tsfc (is:ie, j), inline_pbl%hflx (is:ie, j), &
+ inline_pbl%evap (is:ie, j), stress, wind, kinver, &
+ pik (is:ie, 1), dp, pi, pm, pmk, zi, zm, &
+ inline_pbl%hpbl (is:ie, j), inline_pbl%kpbl (is:ie, j))
+ !inline_pbl%dusfc (is:ie, j), inline_pbl%dvsfc (is:ie, j), &
+ !inline_pbl%dtsfc (is:ie, j), inline_pbl%dqsfc (is:ie, j))
+
+ endif
+
+ if (inline_pbl_flag .eq. 2) then
+
+ ! diagnose surface variables for PBL parameterization
+ call sa_tke_edmf_new_sfc (ie-is+1, lsoil, pi (is:ie, 1), uu (is:ie, 1), &
+ vv (is:ie, 1), ta (is:ie, 1), qa (is:ie, 1, sphum), &
+ abs (mdt), inline_pbl%tsfc (is:ie, j), pm (is:ie, 1), &
+ pik (is:ie, 1) / pmk (is:ie, 1), inline_pbl%evap (is:ie, j), &
+ inline_pbl%hflx (is:ie, j), inline_pbl%ffmm (is:ie, j), &
+ inline_pbl%ffhh (is:ie, j), zm (is:ie, 1) / grav, &
+ inline_pbl%snowd (is:ie, j), inline_pbl%zorl (is:ie, j), inline_pbl%ztrl (is:ie, j), &
+ inline_pbl%lsm (is:ie, j), inline_pbl%uustar (is:ie, j), sigmaf, vegtype, &
+ inline_pbl%shdmax (is:ie, j), inline_pbl%sfcemis (is:ie, j), &
+ inline_pbl%dlwflx (is:ie, j), inline_pbl%sfcnsw (is:ie, j), &
+ inline_pbl%sfcdsw (is:ie, j), inline_pbl%srflag (is:ie, j), &
+ inline_pbl%hice (is:ie, j), inline_pbl%fice (is:ie, j), &
+ inline_pbl%tice (is:ie, j), inline_pbl%weasd (is:ie, j), &
+ inline_pbl%tprcp (is:ie, j), inline_pbl%stc (is:ie, j, :), &
+ inline_pbl%qsurf (is:ie, j), inline_pbl%cmm (is:ie, j), &
+ inline_pbl%chh (is:ie, j), inline_pbl%gflux (is:ie, j), &
+ inline_pbl%ep (is:ie, j), u10m_out = u10m, v10m_out = v10m, &
+ rb_out = rb, stress_out = stress, wind_out = wind)
+
+ ! SA-TKE-EDMF main program
+ call sa_tke_edmf_new_pbl (ie-is+1, km, nq, liq_wat, ice_wat, ntke, &
+ abs (mdt), uu, vv, ta, qa, gsize, inline_pbl%lsm (is:ie, j), &
+ radh, rb, sigmaf, inline_pbl%zorl (is:ie, j), u10m, v10m, &
+ inline_pbl%ffmm (is:ie, j), inline_pbl%ffhh (is:ie, j), &
+ inline_pbl%tsfc (is:ie, j), inline_pbl%hflx (is:ie, j), &
+ inline_pbl%evap (is:ie, j), stress, wind, kinver, &
+ pik (is:ie, 1), dp, pi, pm, pmk, zi, zm, &
+ inline_pbl%hpbl (is:ie, j), inline_pbl%kpbl (is:ie, j))
+ !inline_pbl%dusfc (is:ie, j), inline_pbl%dvsfc (is:ie, j), &
+ !inline_pbl%dtsfc (is:ie, j), inline_pbl%dqsfc (is:ie, j))
+
+ endif
+
+ ! update u, v, T, q, and delp, vertical index flip over
+ do k = 1, km
+ kr = km - k + 1
+ q (is:ie, j, kr, nwat+1:nq) = qa (is:ie, k, nwat+1:nq)
+ dqv = qa (is:ie, k, sphum) - q (is:ie, j, kr, sphum)
+ dql = qa (is:ie, k, liq_wat) - q (is:ie, j, kr, liq_wat)
+ dqi = qa (is:ie, k, ice_wat) - q (is:ie, j, kr, ice_wat)
+ dqr = qa (is:ie, k, rainwat) - q (is:ie, j, kr, rainwat)
+ dqs = qa (is:ie, k, snowwat) - q (is:ie, j, kr, snowwat)
+ dqg = qa (is:ie, k, graupel) - q (is:ie, j, kr, graupel)
+ ps_dt = 1 + dqv + dql + dqi + dqr + dqs + dqg
+ adj_vmr (is:ie, kr) = (ps_dt - (qa (is:ie, k, sphum) + &
+ qa (is:ie, k, liq_wat) + qa (is:ie, k, ice_wat) + &
+ qa (is:ie, k, rainwat) + qa (is:ie, k, snowwat) + &
+ qa (is:ie, k, graupel))) / (1. - (qa (is:ie, k, sphum) + &
+ qa (is:ie, k, liq_wat) + qa (is:ie, k, ice_wat) + &
+ qa (is:ie, k, rainwat) + qa (is:ie, k, snowwat) + &
+ qa (is:ie, k, graupel))) / ps_dt
+ q (is:ie, j, kr, sphum) = qa (is:ie, k, sphum) / ps_dt
+ q (is:ie, j, kr, liq_wat) = qa (is:ie, k, liq_wat) / ps_dt
+ q (is:ie, j, kr, ice_wat) = qa (is:ie, k, ice_wat) / ps_dt
+ q (is:ie, j, kr, rainwat) = qa (is:ie, k, rainwat) / ps_dt
+ q (is:ie, j, kr, snowwat) = qa (is:ie, k, snowwat) / ps_dt
+ q (is:ie, j, kr, graupel) = qa (is:ie, k, graupel) / ps_dt
+ delp (is:ie, j, kr) = delp (is:ie, j, kr) * ps_dt
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ if (thermostruct%use_cond) then
+ q_con (is:ie, j, kr) = q_liq + q_sol
+ endif
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ if (thermostruct%moist_kappa) then
+ cappa (is:ie, j, kr) = rdgas / (rdgas + c_moist / (1. + r_vir * q (is:ie, j, kr, sphum)))
+ endif
+ pt (is:ie, j, kr) = pt (is:ie, j, kr) + (ta (is:ie, k) * &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol))) - &
+ pt (is:ie, j, kr)) * cp_air / c_moist
+ ua (is:ie, j, kr) = uu (is:ie, k)
+ va (is:ie, j, kr) = vv (is:ie, k)
+ inline_pbl%dtsfc (is:ie, j) = inline_pbl%dtsfc (is:ie, j) + cp_air * ta (is:ie, k) * delp (is:ie, j, kr) / ps_dt / grav / abs (mdt)
+ inline_pbl%dqsfc (is:ie, j) = inline_pbl%dqsfc (is:ie, j) + (hlv - rvgas * tice + (cv_vap - c_liq) * (ta (is:ie, k) - tice)) * q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dtsfc (is:ie) = dtsfc (is:ie) + c_moist * (pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol)))) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqvsfc (is:ie) = dqvsfc (is:ie) + q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqlsfc (is:ie) = dqlsfc (is:ie) + q (is:ie, j, kr, liq_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqisfc (is:ie) = dqisfc (is:ie) + q (is:ie, j, kr, ice_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqrsfc (is:ie) = dqrsfc (is:ie) + q (is:ie, j, kr, rainwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqssfc (is:ie) = dqssfc (is:ie) + q (is:ie, j, kr, snowwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqgsfc (is:ie) = dqgsfc (is:ie) + q (is:ie, j, kr, graupel) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dusfc (is:ie, j) = inline_pbl%dusfc (is:ie, j) + ua (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dvsfc (is:ie, j) = inline_pbl%dvsfc (is:ie, j) + va (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dksfc (is:ie, j) = inline_pbl%dksfc (is:ie, j) + 0.5 * (ua (is:ie, j, kr) ** 2 + va (is:ie, j, kr) ** 2 + w (is:ie, j, kr) ** 2) * delp (is:ie, j, kr) / grav / abs (mdt)
+ enddo
+
+ ! update non-microphyiscs tracers due to mass change
+ if (adj_mass_vmr .gt. 0) then
+ do m = 1, nq
+ if (conv_vmr_mmr (m)) then
+ q (is:ie, j, 1:km, m) = q (is:ie, j, 1:km, m) * adj_vmr (is:ie, 1:km)
+ endif
+ enddo
+ endif
+
+ ! compute wind tendency at A grid fori D grid wind update
+ u_dt (is:ie, j, 1:km) = (ua (is:ie, j, 1:km) - u_dt (is:ie, j, 1:km)) / abs (mdt)
+ v_dt (is:ie, j, 1:km) = (va (is:ie, j, 1:km) - v_dt (is:ie, j, 1:km)) / abs (mdt)
+
+ ! update pkz
+ if (.not. hydrostatic) then
+ if (thermostruct%moist_kappa) then
+ pkz (is:ie, j, 1:km) = exp (cappa (is:ie, j, 1:km) * &
+ log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ else
+ pkz (is:ie, j, 1:km) = exp (akap * log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_end (is:ie, 1:km) = 0.0
+ tw_end (is:ie, 1:km) = 0.0
+ te_b_end (is:ie) = 0.0
+ tw_b_end (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), - dqvsfc (i) * 86400, - dqlsfc (i) * 86400, &
+ - dqrsfc (i) * 86400, - dqisfc (i) * 86400, - dqssfc (i) * 86400, - dqgsfc (i) * 86400, &
+ - dtsfc (i), - inline_pbl%dksfc (i, j), abs (mdt), te_end (i, 1:km), tw_end (i, 1:km), &
+ te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
+ enddo
+ endif
+
+ ! total energy after parameterization, add total energy change to te0_2d
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = te (is:ie, j, 1:km) + &
+ cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ do k = 1, km
+ te0_2d (is:ie, j) = te0_2d (is:ie, j) + te (is:ie, j, k)
+ enddo
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ do i = is, ie
+ !if (abs (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i)) .gt. te_err) then
+ ! print*, "PBL-FAST TE: ", &
+ ! !(sum (te_beg (i, :)) + te_b_beg (i)), &
+ ! !(sum (te_end (i, :)) + te_b_end (i)), &
+ ! (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i))
+ !endif
+ inline_pbl%fast_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_pbl%fast_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !if (abs (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i)) .gt. tw_err) then
+ ! print*, "PBL-FAST TW: ", &
+ ! !(sum (tw_beg (i, :)) + tw_b_beg (i)), &
+ ! !(sum (tw_end (i, :)) + tw_b_end (i)), &
+ ! (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i))
+ !endif
+ inline_pbl%fast_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_pbl%fast_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
+ !print*, "PBL-FAST LOSS (%) : ", te_loss (i) / (sum (te_beg (i, :)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ deallocate (kinver)
+
+ deallocate (dz)
+ deallocate (zm)
+ deallocate (zi)
+ deallocate (dp)
+ deallocate (pm)
+ deallocate (pi)
+ deallocate (pmk)
+ deallocate (pik)
+
+ deallocate (ta)
+ deallocate (uu)
+ deallocate (vv)
+ deallocate (qa)
+
+ deallocate (radh)
+ deallocate (rb)
+ deallocate (u10m)
+ deallocate (v10m)
+ deallocate (stress)
+ deallocate (wind)
+ deallocate (sigmaf)
+ deallocate (vegtype)
+
+ deallocate (dtsfc)
+ deallocate (dqvsfc)
+ deallocate (dqlsfc)
+ deallocate (dqisfc)
+ deallocate (dqrsfc)
+ deallocate (dqssfc)
+ deallocate (dqgsfc)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ ! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ call timing_on('COMM_TOTAL')
+ 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
+ call timing_off('COMM_TOTAL')
+
+ ! 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)
+
+ ! 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
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Inline Planetary Boundary Layer
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Inline Gravity Wave Drag >>>
+ !-----------------------------------------------------------------------
+
+ if ((.not. do_adiabatic_init) .and. do_inline_gwd) then
+
+ allocate (dz (is:ie, 1:km))
+ allocate (zm (is:ie, 1:km))
+ allocate (zi (is:ie, 1:km+1))
+ allocate (dp (is:ie, 1:km))
+ allocate (pm (is:ie, 1:km))
+ allocate (pi (is:ie, 1:km+1))
+ allocate (pmk (is:ie, 1:km))
+
+ allocate (ta (is:ie, 1:km))
+ allocate (qv (is:ie, 1:km))
+ allocate (uu (is:ie, 1:km))
+ allocate (vv (is:ie, 1:km))
+
+ allocate (u_dt (isd:ied, jsd:jed, km))
+ allocate (v_dt (isd:ied, jsd:jed, km))
+
+ allocate (tz (1:km))
+ allocate (wz (1: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, 4, bd)
+
+ ! save delp
+ if (consv .gt. consv_min) then
+ allocate (dp0 (isd:ied, jsd:jed, km))
+ dp0 = delp
+ endif
+
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, km, ua, va, w, &
+!$OMP te, delp, hydrostatic, pt, delz, q_con, &
+!$OMP rainwat, liq_wat, ice_wat, snowwat, graupel, &
+!$OMP sphum, pkz, consv, te0_2d, gridstruct, q, &
+!$OMP mdt, cappa, rrg, akap, r_vir, inline_gwd, &
+!$OMP ptop, inline_pbl, u_dt, v_dt, safety_check, &
+!$OMP conv_vmr_mmr, nq, consv_checker, &
+!$OMP te_err, tw_err, thermostruct) &
+!$OMP private (gsize, dz, pi, pmk, zi, q_liq, q_sol, pe, &
+!$OMP zm, dp, pm, qv, ta, uu, vv, qliq, qsol, &
+!$OMP cvm, kr, c_moist, peln, &
+!$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))
+
+ ! save ua, va for wind tendency calculation
+ u_dt (is:ie, j, 1:km) = ua (is:ie, j, 1:km)
+ v_dt (is:ie, j, 1:km) = va (is:ie, j, 1:km)
+
+ ! total energy before parameterization
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = - cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_beg (is:ie, 1:km) = 0.0
+ tw_beg (is:ie, 1:km) = 0.0
+ te_b_beg (is:ie) = 0.0
+ tw_b_beg (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_beg (i, 1:km), tw_beg (i, 1: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 index flip over
+ zi (is:ie, 1) = 0.0
+ pi (is:ie, 1) = pe (is:ie, km+1)
+ do k = 1, km
+ kr = km - k + 1
+ dp (is:ie, k) = delp (is:ie, j, kr)
+ pi (is:ie, k+1) = pe (is:ie, kr)
+ if (.not. hydrostatic) then
+ pm (is:ie, k) = dp (is:ie, k) / delz (is:ie, j, kr) * &
+ rrg * pt (is:ie, j, kr)
+ dz (is:ie, k) = delz (is:ie, j, kr)
+ ! ensure subgrid monotonicity of pressure
+ do i = is, ie
+ pm (i, k) = min (pm (i, k), pi (i, k) - 0.01 * pm (i, k))
+ pm (i, k) = max (pm (i, k), pi (i, k+1) + 0.01 * pm (i, k))
+ enddo
+ else
+ pm (is:ie, k) = dp (is:ie, k) / (peln (is:ie, kr+1) - peln (is:ie, kr))
+ dz (is:ie, k) = (peln (is:ie, kr+1) - peln (is:ie, kr)) * &
+ rrg * pt (is:ie, j, kr)
+ endif
+ pmk (is:ie, k) = exp (kappa * log (pm (is:ie, k) * 1.e-5))
+ zi (is:ie, k+1) = zi (is:ie, k) - dz (is:ie, k) * grav
+ if (k .eq. 1) then
+ zm (is:ie, k) = - 0.5 * dz (is:ie, k) * grav
+ else
+ zm (is:ie, k) = zm (is:ie, k-1) - 0.5 * (dz (is:ie, k-1) + dz (is:ie, k)) * grav
+ endif
+ qv (is:ie, k) = q (is:ie, j, kr, sphum)
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ ta (is:ie, k) = pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * &
+ (1. - (q_liq + q_sol)))
+ uu (is:ie, k) = ua (is:ie, j, kr)
+ vv (is:ie, k) = va (is:ie, j, kr)
+ enddo
+
+ ! check if pressure or height cross over
+ if (safety_check) then
+ do k = 1, km
+ do i = is, ie
+ if (k .lt. km) then
+ if (pm (i, k) .le. pm (i, k+1)) then
+ print*, "Warning: inline gwd pressure layer cross over", k, pm (i, k), pm (i, k+1)
+ endif
+ if (zm (i, k) .ge. zm (i, k+1)) then
+ print*, "Warning: inline gwd height layer cross over", k, zm (i, k), zm (i, k+1)
+ endif
+ endif
+ if (pi (i, k) .le. pi (i, k+1)) then
+ print*, "Warning: inline gwd pressure interface cross over", k, pi (i, k), pi (i, k+1)
+ endif
+ if (zi (i, k) .ge. zi (i, k+1)) then
+ print*, "Warning: inline gwd height interface cross over", k, zi (i, k), zi (i, k+1)
+ endif
+ enddo
+ enddo
+ endif
+
+ ! orographic gravity wave drag and mountain blocking main program
+ call sa_gwd_oro (ie-is+1, km, uu, vv, ta, qv, abs (mdt), gsize, &
+ inline_pbl%kpbl (is:ie, j), pi, dp, pm, pmk, zi, zm, &
+ inline_gwd%hprime (is:ie, j), inline_gwd%oc (is:ie, j), inline_gwd%oa (is:ie, j, :), &
+ inline_gwd%ol (is:ie, j, :), inline_gwd%theta (is:ie, j), inline_gwd%sigma (is:ie, j), &
+ inline_gwd%gamma (is:ie, j), inline_gwd%elvmax (is:ie, j))
+
+ ! update u, v, T, q, and delp, vertical index flip over
+ do k = 1, km
+ kr = km - k + 1
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ if (thermostruct%use_cond) then
+ q_con (is:ie, j, kr) = q_liq + q_sol
+ endif
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ if (thermostruct%moist_kappa) then
+ cappa (is:ie, j, kr) = rdgas / (rdgas + c_moist / (1. + r_vir * q (is:ie, j, kr, sphum)))
+ endif
+ pt (is:ie, j, kr) = pt (is:ie, j, kr) + (ta (is:ie, k) * &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol))) - &
+ pt (is:ie, j, kr)) * cp_air / c_moist
+ ua (is:ie, j, kr) = uu (is:ie, k)
+ va (is:ie, j, kr) = vv (is:ie, k)
+ enddo
+
+ ! compute wind tendency at A grid fori D grid wind update
+ u_dt (is:ie, j, 1:km) = (ua (is:ie, j, 1:km) - u_dt (is:ie, j, 1:km)) / abs (mdt)
+ v_dt (is:ie, j, 1:km) = (va (is:ie, j, 1:km) - v_dt (is:ie, j, 1:km)) / abs (mdt)
+
+ ! update pkz
+ if (.not. hydrostatic) then
+ if (thermostruct%moist_kappa) then
+ pkz (is:ie, j, 1:km) = exp (cappa (is:ie, j, 1:km) * &
+ log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ else
+ pkz (is:ie, j, 1:km) = exp (akap * log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_end (is:ie, 1:km) = 0.0
+ tw_end (is:ie, 1:km) = 0.0
+ te_b_end (is:ie) = 0.0
+ tw_b_end (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_end (i, 1:km), tw_end (i, 1:km), &
+ te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
+ enddo
+ endif
+
+ ! total energy after parameterization, add total energy change to te0_2d
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = te (is:ie, j, 1:km) + &
+ cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ do k = 1, km
+ te0_2d (is:ie, j) = te0_2d (is:ie, j) + te (is:ie, j, k)
+ enddo
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ do i = is, ie
+ !if (abs (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i)) .gt. te_err) then
+ ! print*, "GWD-FAST TE: ", &
+ ! !(sum (te_beg (i, :)) + te_b_beg (i)), &
+ ! !(sum (te_end (i, :)) + te_b_end (i)), &
+ ! (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i))
+ !endif
+ inline_gwd%fast_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_gwd%fast_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !if (abs (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i)) .gt. tw_err) then
+ ! print*, "GWD-FAST TW: ", &
+ ! !(sum (tw_beg (i, :)) + tw_b_beg (i)), &
+ ! !(sum (tw_end (i, :)) + tw_b_end (i)), &
+ ! (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i))
+ !endif
+ inline_gwd%fast_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_gwd%fast_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
+ !print*, "GWD-FAST LOSS (%) : ", te_loss (i) / (sum (te_beg (i, :)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ deallocate (dz)
+ deallocate (zm)
+ deallocate (dp)
+ deallocate (pm)
+ deallocate (pi)
+ deallocate (pmk)
+
+ deallocate (ta)
+ deallocate (qv)
+ deallocate (uu)
+ deallocate (vv)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ ! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ call timing_on('COMM_TOTAL')
+ 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
+ call timing_off('COMM_TOTAL')
+
+ ! 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)
+
+ ! 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
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Inline Gravity Wave Drag
+ !-----------------------------------------------------------------------
+
!-----------------------------------------------------------------------
! pt conversion
!-----------------------------------------------------------------------
diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90
index 4c11a5f0e..b324cacb6 100644
--- a/model/fv_arrays.F90
+++ b/model/fv_arrays.F90
@@ -66,6 +66,15 @@ module fv_arrays_mod
real :: efx(max_step), efx_sum, efx_nest(max_step), efx_sum_nest, mtq(max_step), mtq_sum
integer :: steps
+! Integrated physics diagnostics
+ integer :: id_inline_mp_fast_te_a_chg, id_inline_mp_fast_te_b_chg, id_inline_mp_fast_tw_a_chg, id_inline_mp_fast_tw_b_chg
+ integer :: id_inline_mp_intm_te_a_chg, id_inline_mp_intm_te_b_chg, id_inline_mp_intm_tw_a_chg, id_inline_mp_intm_tw_b_chg
+ integer :: id_inline_pbl_fast_te_a_chg, id_inline_pbl_fast_te_b_chg, id_inline_pbl_fast_tw_a_chg, id_inline_pbl_fast_tw_b_chg
+ integer :: id_inline_pbl_intm_te_a_chg, id_inline_pbl_intm_te_b_chg, id_inline_pbl_intm_tw_a_chg, id_inline_pbl_intm_tw_b_chg
+ integer :: id_inline_cnv_intm_te_a_chg, id_inline_cnv_intm_te_b_chg, id_inline_cnv_intm_tw_a_chg, id_inline_cnv_intm_tw_b_chg
+ integer :: id_inline_gwd_fast_te_a_chg, id_inline_gwd_fast_te_b_chg, id_inline_gwd_fast_tw_a_chg, id_inline_gwd_fast_tw_b_chg
+ integer :: id_inline_gwd_intm_te_a_chg, id_inline_gwd_intm_te_b_chg, id_inline_gwd_intm_tw_a_chg, id_inline_gwd_intm_tw_b_chg
+
end type fv_diag_type
@@ -367,9 +376,24 @@ module fv_arrays_mod
logical :: do_intermediate_phys = .true.!< Controls intermediate physics, in which the GFDL MP, SA-SAS and part of the GWD are
!< within the remapping time step of FV3. If .false. disabling the GFDL MP, SA-SAS
!< 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
+ logical :: do_inline_mp = .false.!< Controls inline 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_inline_pbl = .false.!< Controls inline planetary boundary layer, in which the planetary boundary layer is
+ !< called entirely within FV3. If .true. disabling planetary boundary layer within the physics
+ !< is very strongly recommended. .false. by default.
+ logical :: do_inline_cnv = .false.!< Controls inline convection, in which the convection is
+ !< called entirely within FV3. If .true. disabling convection within the physics
+ !< is very strongly recommended. .false. by default.
+ logical :: do_inline_gwd = .false.!< Controls inline gravity wave drag, in which the gravity wave drag is
+ !< called entirely within FV3. If .true. disabling gravity wave drag within the physics
+ !< is very strongly recommended. .false. by default.
+ integer :: inline_cnv_flag = 1 !< inline convection scheme
+ !< 1: Scale-Aware Simplified-Arakawa-Schubert (SA-SAS) Convection Scheme
+ !< 2: Scale-Aware Aerosol-Aware Mass-Flux (SA-AAMP) Convection Scheme
+ integer :: inline_pbl_flag = 1 !< inline pbl scheme
+ !< 1: Scale-Aware Turbulent-Kinetic-Energy based Moist-Eddy-Diffusivity-Mass-Flux scheme
+ !< 2: A New Scale-Aware Turbulent-Kinetic-Energy based Moist-Eddy-Diffusivity-Mass-Flux scheme
logical :: do_aerosol = .false. !< Controls climatological aerosol data used in the GFDL cloud microphyiscs.
!< .false. by default.
logical :: do_cosp = .false. !< Controls COSP
@@ -1045,6 +1069,15 @@ module fv_arrays_mod
real, _ALLOCATABLE :: u_dt(:,:,:)
real, _ALLOCATABLE :: v_dt(:,:,:)
+ real, _ALLOCATABLE :: fast_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_tw_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_b_chg(:,:) _NULL
+
real, _ALLOCATABLE :: qcw(:,:,:)
real, _ALLOCATABLE :: qci(:,:,:)
real, _ALLOCATABLE :: qcr(:,:,:)
@@ -1088,6 +1121,97 @@ module fv_arrays_mod
end type inline_mp_type
+ type inline_pbl_type
+
+ integer, _ALLOCATABLE :: lsm(:,:) _NULL
+ real, _ALLOCATABLE :: zorl(:,:) _NULL
+ real, _ALLOCATABLE :: ztrl(:,:) _NULL
+ real, _ALLOCATABLE :: ffmm(:,:) _NULL
+ real, _ALLOCATABLE :: ffhh(:,:) _NULL
+ real, _ALLOCATABLE :: tsfc(:,:) _NULL
+ real, _ALLOCATABLE :: shdmax(:,:) _NULL
+ real, _ALLOCATABLE :: vtype(:,:) _NULL
+ real, _ALLOCATABLE :: vfrac(:,:) _NULL
+ real, _ALLOCATABLE :: snowd(:,:) _NULL
+ real, _ALLOCATABLE :: uustar(:,:) _NULL
+ real, _ALLOCATABLE :: radh(:,:,:) _NULL
+ real, _ALLOCATABLE :: hflx(:,:) _NULL
+ real, _ALLOCATABLE :: evap(:,:) _NULL
+ real, _ALLOCATABLE :: sfcemis(:,:) _NULL
+ real, _ALLOCATABLE :: dlwflx(:,:) _NULL
+ real, _ALLOCATABLE :: sfcnsw(:,:) _NULL
+ real, _ALLOCATABLE :: sfcdsw(:,:) _NULL
+ real, _ALLOCATABLE :: srflag(:,:) _NULL
+ real, _ALLOCATABLE :: hice(:,:) _NULL
+ real, _ALLOCATABLE :: fice(:,:) _NULL
+ real, _ALLOCATABLE :: tice(:,:) _NULL
+ real, _ALLOCATABLE :: weasd(:,:) _NULL
+ real, _ALLOCATABLE :: tprcp(:,:) _NULL
+ real, _ALLOCATABLE :: stc(:,:,:) _NULL
+ real, _ALLOCATABLE :: qsurf(:,:) _NULL
+ real, _ALLOCATABLE :: cmm(:,:) _NULL
+ real, _ALLOCATABLE :: chh(:,:) _NULL
+ real, _ALLOCATABLE :: gflux(:,:) _NULL
+ real, _ALLOCATABLE :: ep(:,:) _NULL
+ real, _ALLOCATABLE :: hpbl(:,:) _NULL
+ integer, _ALLOCATABLE :: kpbl(:,:) _NULL
+ real, _ALLOCATABLE :: dtsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqvsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqlsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqisfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqrsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqssfc(:,:) _NULL
+ real, _ALLOCATABLE :: dqgsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dusfc(:,:) _NULL
+ real, _ALLOCATABLE :: dvsfc(:,:) _NULL
+ real, _ALLOCATABLE :: dksfc(:,:) _NULL
+ real, _ALLOCATABLE :: fast_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_tw_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_b_chg(:,:) _NULL
+
+ end type inline_pbl_type
+
+ type inline_cnv_type
+
+ real, _ALLOCATABLE :: prec(:,:) _NULL
+ real, _ALLOCATABLE :: cumabs(:,:) _NULL
+ integer, _ALLOCATABLE :: ktop(:,:) _NULL
+ integer, _ALLOCATABLE :: kbot(:,:) _NULL
+ integer, _ALLOCATABLE :: kcnv(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_b_chg(:,:) _NULL
+
+ end type inline_cnv_type
+
+ type inline_gwd_type
+
+ real, _ALLOCATABLE :: hprime(:,:)
+ real, _ALLOCATABLE :: oc(:,:)
+ real, _ALLOCATABLE :: oa(:,:,:)
+ real, _ALLOCATABLE :: ol(:,:,:)
+ real, _ALLOCATABLE :: theta(:,:)
+ real, _ALLOCATABLE :: sigma(:,:)
+ real, _ALLOCATABLE :: gamma(:,:)
+ real, _ALLOCATABLE :: elvmax(:,:)
+ real, _ALLOCATABLE :: fast_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: fast_tw_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_a_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_te_b_chg(:,:) _NULL
+ real, _ALLOCATABLE :: intm_tw_b_chg(:,:) _NULL
+
+ end type inline_gwd_type
+
type phys_diag_type
real, _ALLOCATABLE :: phys_t_dt(:,:,:)
@@ -1388,7 +1512,8 @@ module fv_arrays_mod
!!!!!!!!!!!!!!
type(FmsNetcdfFile_t) :: Fv_restart
type(FmsNetcdfDomainFile_t) :: SST_restart, Fv_restart_tile, &
- Rsf_restart, Mg_restart, Lnd_restart, Tra_restart
+ Rsf_restart, Mg_restart, Lnd_restart, Tra_restart, &
+ Oro_restart, Phy_restart, Sfc_restart, Soi_restart
logical :: Fv_restart_is_open=.false.
logical :: SST_restart_is_open=.false.
logical :: Fv_restart_tile_is_open=.false.
@@ -1396,6 +1521,10 @@ module fv_arrays_mod
logical :: Mg_restart_is_open=.false.
logical :: Lnd_restart_is_open=.false.
logical :: Tra_restart_is_open=.false.
+ logical :: Oro_restart_is_open=.false.
+ logical :: Phy_restart_is_open=.false.
+ logical :: Sfc_restart_is_open=.false.
+ logical :: Soi_restart_is_open=.false.
type(fv_nest_type) :: neststruct
!Hold on to coarse-grid global grid, so we don't have to waste processor time getting it again when starting to do grid nesting
@@ -1404,6 +1533,9 @@ module fv_arrays_mod
integer :: atmos_axes(4)
type(inline_mp_type) :: inline_mp
+ type(inline_pbl_type) :: inline_pbl
+ type(inline_cnv_type) :: inline_cnv
+ type(inline_gwd_type) :: inline_gwd
type(phys_diag_type) :: phys_diag
type(nudge_diag_type) :: nudge_diag
type(sg_diag_type) :: sg_diag
@@ -1576,6 +1708,107 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie
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) )
+ if (Atm%flagstruct%consv_checker) then
+ allocate ( Atm%inline_mp%fast_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%fast_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%fast_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%fast_tw_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%intm_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%intm_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%intm_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_mp%intm_tw_b_chg(is:ie,js:je) )
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_pbl) then
+ allocate ( Atm%inline_pbl%lsm(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%zorl(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%ztrl(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%ffmm(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%ffhh(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%tsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%shdmax(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%vtype(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%vfrac(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%snowd(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%uustar(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%radh(is:ie,js:je,npz) )
+ allocate ( Atm%inline_pbl%hflx(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%evap(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%sfcemis(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dlwflx(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%sfcnsw(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%sfcdsw(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%srflag(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%hice(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%fice(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%tice(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%weasd(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%tprcp(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%stc(is:ie,js:je,4) )
+ allocate ( Atm%inline_pbl%qsurf(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%cmm(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%chh(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%gflux(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%ep(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%hpbl(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%kpbl(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dtsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqvsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqlsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqisfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqrsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqssfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dqgsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dusfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dvsfc(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%dksfc(is:ie,js:je) )
+ if (Atm%flagstruct%consv_checker) then
+ allocate ( Atm%inline_pbl%fast_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%fast_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%fast_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%fast_tw_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%intm_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%intm_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%intm_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_pbl%intm_tw_b_chg(is:ie,js:je) )
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_cnv) then
+ allocate ( Atm%inline_cnv%prec(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%cumabs(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%ktop(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%kbot(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%kcnv(is:ie,js:je) )
+ if (Atm%flagstruct%consv_checker) then
+ allocate ( Atm%inline_cnv%intm_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%intm_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%intm_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_cnv%intm_tw_b_chg(is:ie,js:je) )
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_gwd) then
+ allocate ( Atm%inline_gwd%hprime(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%oc(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%oa(is:ie,js:je,4) )
+ allocate ( Atm%inline_gwd%ol(is:ie,js:je,4) )
+ allocate ( Atm%inline_gwd%theta(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%sigma(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%gamma(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%elvmax(is:ie,js:je) )
+ if (Atm%flagstruct%consv_checker) then
+ allocate ( Atm%inline_gwd%fast_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%fast_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%fast_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%fast_tw_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%intm_te_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%intm_tw_a_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%intm_te_b_chg(is:ie,js:je) )
+ allocate ( Atm%inline_gwd%intm_tw_b_chg(is:ie,js:je) )
+ endif
endif
allocate ( Atm%inline_mp%mppcw(is:ie,js:je) )
allocate ( Atm%inline_mp%mppew(is:ie,js:je) )
@@ -1704,6 +1937,135 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie
Atm%inline_mp%prefluxg(i,j,:) = real_big
enddo
enddo
+ if (Atm%flagstruct%consv_checker) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_mp%fast_te_a_chg(i,j) = real_big
+ Atm%inline_mp%fast_tw_a_chg(i,j) = real_big
+ Atm%inline_mp%fast_te_b_chg(i,j) = real_big
+ Atm%inline_mp%fast_tw_b_chg(i,j) = real_big
+ Atm%inline_mp%intm_te_a_chg(i,j) = real_big
+ Atm%inline_mp%intm_tw_a_chg(i,j) = real_big
+ Atm%inline_mp%intm_te_b_chg(i,j) = real_big
+ Atm%inline_mp%intm_tw_b_chg(i,j) = real_big
+ enddo
+ enddo
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_pbl) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_pbl%lsm(i,j) = 0
+ Atm%inline_pbl%zorl(i,j) = 0
+ Atm%inline_pbl%ztrl(i,j) = 0
+ Atm%inline_pbl%ffmm(i,j) = real_big
+ Atm%inline_pbl%ffhh(i,j) = real_big
+ Atm%inline_pbl%tsfc(i,j) = real_big
+ Atm%inline_pbl%shdmax(i,j) = real_big
+ Atm%inline_pbl%vtype(i,j) = real_big
+ Atm%inline_pbl%vfrac(i,j) = real_big
+ Atm%inline_pbl%snowd(i,j) = real_big
+ Atm%inline_pbl%uustar(i,j) = real_big
+ Atm%inline_pbl%radh(i,j,:) = 0.0
+ Atm%inline_pbl%hflx(i,j) = 0.0
+ Atm%inline_pbl%evap(i,j) = 0.0
+ Atm%inline_pbl%sfcemis(i,j) = 0.0
+ Atm%inline_pbl%dlwflx(i,j) = 0.0
+ Atm%inline_pbl%sfcnsw(i,j) = 0.0
+ Atm%inline_pbl%sfcdsw(i,j) = 0.0
+ Atm%inline_pbl%srflag(i,j) = real_big
+ Atm%inline_pbl%hice(i,j) = real_big
+ Atm%inline_pbl%fice(i,j) = real_big
+ Atm%inline_pbl%tice(i,j) = real_big
+ Atm%inline_pbl%weasd(i,j) = real_big
+ Atm%inline_pbl%tprcp(i,j) = real_big
+ Atm%inline_pbl%stc(i,j,:) = real_big
+ Atm%inline_pbl%qsurf(i,j) = real_big
+ Atm%inline_pbl%cmm(i,j) = real_big
+ Atm%inline_pbl%chh(i,j) = real_big
+ Atm%inline_pbl%gflux(i,j) = real_big
+ Atm%inline_pbl%ep(i,j) = real_big
+ Atm%inline_pbl%hpbl(i,j) = real_big
+ Atm%inline_pbl%kpbl(i,j) = 1
+ Atm%inline_pbl%dtsfc(i,j) = real_big
+ Atm%inline_pbl%dqsfc(i,j) = real_big
+ Atm%inline_pbl%dqvsfc(i,j) = real_big
+ Atm%inline_pbl%dqlsfc(i,j) = real_big
+ Atm%inline_pbl%dqisfc(i,j) = real_big
+ Atm%inline_pbl%dqrsfc(i,j) = real_big
+ Atm%inline_pbl%dqssfc(i,j) = real_big
+ Atm%inline_pbl%dqgsfc(i,j) = real_big
+ Atm%inline_pbl%dusfc(i,j) = real_big
+ Atm%inline_pbl%dvsfc(i,j) = real_big
+ Atm%inline_pbl%dksfc(i,j) = real_big
+ enddo
+ enddo
+ if (Atm%flagstruct%consv_checker) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_pbl%fast_te_a_chg(i,j) = real_big
+ Atm%inline_pbl%fast_tw_a_chg(i,j) = real_big
+ Atm%inline_pbl%fast_te_b_chg(i,j) = real_big
+ Atm%inline_pbl%fast_tw_b_chg(i,j) = real_big
+ Atm%inline_pbl%intm_te_a_chg(i,j) = real_big
+ Atm%inline_pbl%intm_tw_a_chg(i,j) = real_big
+ Atm%inline_pbl%intm_te_b_chg(i,j) = real_big
+ Atm%inline_pbl%intm_tw_b_chg(i,j) = real_big
+ enddo
+ enddo
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_cnv) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_cnv%prec(i,j) = real_big
+ Atm%inline_cnv%cumabs(i,j) = real_big
+ Atm%inline_cnv%ktop(i,j) = 1
+ Atm%inline_cnv%kbot(i,j) = npz
+ Atm%inline_cnv%kcnv(i,j) = 0
+ enddo
+ enddo
+ if (Atm%flagstruct%consv_checker) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_cnv%intm_te_a_chg(i,j) = real_big
+ Atm%inline_cnv%intm_tw_a_chg(i,j) = real_big
+ Atm%inline_cnv%intm_te_b_chg(i,j) = real_big
+ Atm%inline_cnv%intm_tw_b_chg(i,j) = real_big
+ enddo
+ enddo
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_gwd) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_gwd%hprime(i,j) = real_big
+ Atm%inline_gwd%oc(i,j) = real_big
+ Atm%inline_gwd%oa(i,j,4) = real_big
+ Atm%inline_gwd%ol(i,j,4) = real_big
+ Atm%inline_gwd%theta(i,j) = real_big
+ Atm%inline_gwd%sigma(i,j) = real_big
+ Atm%inline_gwd%gamma(i,j) = real_big
+ Atm%inline_gwd%elvmax(i,j) = real_big
+ enddo
+ enddo
+ if (Atm%flagstruct%consv_checker) then
+ do j=js, je
+ do i=is, ie
+ Atm%inline_gwd%fast_te_a_chg(i,j) = real_big
+ Atm%inline_gwd%fast_tw_a_chg(i,j) = real_big
+ Atm%inline_gwd%fast_te_b_chg(i,j) = real_big
+ Atm%inline_gwd%fast_tw_b_chg(i,j) = real_big
+ Atm%inline_gwd%intm_te_a_chg(i,j) = real_big
+ Atm%inline_gwd%intm_tw_a_chg(i,j) = real_big
+ Atm%inline_gwd%intm_te_b_chg(i,j) = real_big
+ Atm%inline_gwd%intm_tw_b_chg(i,j) = real_big
+ enddo
+ enddo
+ endif
endif
do j=js, je
do i=is, ie
@@ -2004,6 +2366,107 @@ subroutine deallocate_fv_atmos_type(Atm)
deallocate ( Atm%inline_mp%prefluxi )
deallocate ( Atm%inline_mp%prefluxs )
deallocate ( Atm%inline_mp%prefluxg )
+ if (Atm%flagstruct%consv_checker) then
+ deallocate ( Atm%inline_mp%fast_te_a_chg )
+ deallocate ( Atm%inline_mp%fast_tw_a_chg )
+ deallocate ( Atm%inline_mp%fast_te_b_chg )
+ deallocate ( Atm%inline_mp%fast_tw_b_chg )
+ deallocate ( Atm%inline_mp%intm_te_a_chg )
+ deallocate ( Atm%inline_mp%intm_tw_a_chg )
+ deallocate ( Atm%inline_mp%intm_te_b_chg )
+ deallocate ( Atm%inline_mp%intm_tw_b_chg )
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_pbl) then
+ deallocate ( Atm%inline_pbl%lsm )
+ deallocate ( Atm%inline_pbl%zorl )
+ deallocate ( Atm%inline_pbl%ztrl )
+ deallocate ( Atm%inline_pbl%ffmm )
+ deallocate ( Atm%inline_pbl%ffhh )
+ deallocate ( Atm%inline_pbl%tsfc )
+ deallocate ( Atm%inline_pbl%shdmax )
+ deallocate ( Atm%inline_pbl%vtype )
+ deallocate ( Atm%inline_pbl%vfrac )
+ deallocate ( Atm%inline_pbl%snowd )
+ deallocate ( Atm%inline_pbl%uustar )
+ deallocate ( Atm%inline_pbl%radh )
+ deallocate ( Atm%inline_pbl%hflx )
+ deallocate ( Atm%inline_pbl%evap )
+ deallocate ( Atm%inline_pbl%sfcemis )
+ deallocate ( Atm%inline_pbl%dlwflx )
+ deallocate ( Atm%inline_pbl%sfcnsw )
+ deallocate ( Atm%inline_pbl%sfcdsw )
+ deallocate ( Atm%inline_pbl%srflag )
+ deallocate ( Atm%inline_pbl%hice )
+ deallocate ( Atm%inline_pbl%fice )
+ deallocate ( Atm%inline_pbl%tice )
+ deallocate ( Atm%inline_pbl%weasd )
+ deallocate ( Atm%inline_pbl%tprcp )
+ deallocate ( Atm%inline_pbl%stc )
+ deallocate ( Atm%inline_pbl%qsurf )
+ deallocate ( Atm%inline_pbl%cmm )
+ deallocate ( Atm%inline_pbl%chh )
+ deallocate ( Atm%inline_pbl%gflux )
+ deallocate ( Atm%inline_pbl%ep )
+ deallocate ( Atm%inline_pbl%hpbl )
+ deallocate ( Atm%inline_pbl%kpbl )
+ deallocate ( Atm%inline_pbl%dtsfc )
+ deallocate ( Atm%inline_pbl%dqsfc )
+ deallocate ( Atm%inline_pbl%dqvsfc )
+ deallocate ( Atm%inline_pbl%dqlsfc )
+ deallocate ( Atm%inline_pbl%dqisfc )
+ deallocate ( Atm%inline_pbl%dqrsfc )
+ deallocate ( Atm%inline_pbl%dqssfc )
+ deallocate ( Atm%inline_pbl%dqgsfc )
+ deallocate ( Atm%inline_pbl%dusfc )
+ deallocate ( Atm%inline_pbl%dvsfc )
+ deallocate ( Atm%inline_pbl%dksfc )
+ if (Atm%flagstruct%consv_checker) then
+ deallocate ( Atm%inline_pbl%fast_te_a_chg )
+ deallocate ( Atm%inline_pbl%fast_tw_a_chg )
+ deallocate ( Atm%inline_pbl%fast_te_b_chg )
+ deallocate ( Atm%inline_pbl%fast_tw_b_chg )
+ deallocate ( Atm%inline_pbl%intm_te_a_chg )
+ deallocate ( Atm%inline_pbl%intm_tw_a_chg )
+ deallocate ( Atm%inline_pbl%intm_te_b_chg )
+ deallocate ( Atm%inline_pbl%intm_tw_b_chg )
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_cnv) then
+ deallocate ( Atm%inline_cnv%prec )
+ deallocate ( Atm%inline_cnv%cumabs )
+ deallocate ( Atm%inline_cnv%ktop )
+ deallocate ( Atm%inline_cnv%kbot )
+ deallocate ( Atm%inline_cnv%kcnv )
+ if (Atm%flagstruct%consv_checker) then
+ deallocate ( Atm%inline_cnv%intm_te_a_chg )
+ deallocate ( Atm%inline_cnv%intm_tw_a_chg )
+ deallocate ( Atm%inline_cnv%intm_te_b_chg )
+ deallocate ( Atm%inline_cnv%intm_tw_b_chg )
+ endif
+ endif
+
+ if (Atm%flagstruct%do_inline_gwd) then
+ deallocate ( Atm%inline_gwd%hprime )
+ deallocate ( Atm%inline_gwd%oc )
+ deallocate ( Atm%inline_gwd%oa )
+ deallocate ( Atm%inline_gwd%ol )
+ deallocate ( Atm%inline_gwd%theta )
+ deallocate ( Atm%inline_gwd%sigma )
+ deallocate ( Atm%inline_gwd%gamma )
+ deallocate ( Atm%inline_gwd%elvmax )
+ if (Atm%flagstruct%consv_checker) then
+ deallocate ( Atm%inline_gwd%fast_te_a_chg )
+ deallocate ( Atm%inline_gwd%fast_tw_a_chg )
+ deallocate ( Atm%inline_gwd%fast_te_b_chg )
+ deallocate ( Atm%inline_gwd%fast_tw_b_chg )
+ deallocate ( Atm%inline_gwd%intm_te_a_chg )
+ deallocate ( Atm%inline_gwd%intm_tw_a_chg )
+ deallocate ( Atm%inline_gwd%intm_te_b_chg )
+ deallocate ( Atm%inline_gwd%intm_tw_b_chg )
+ endif
endif
deallocate ( Atm%inline_mp%mppcw )
deallocate ( Atm%inline_mp%mppew )
diff --git a/model/fv_control.F90 b/model/fv_control.F90
index 0fd48ea7b..bf5fd3fcf 100644
--- a/model/fv_control.F90
+++ b/model/fv_control.F90
@@ -169,6 +169,11 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split)
logical , pointer :: do_fast_phys
logical , pointer :: do_intermediate_phys
logical , pointer :: do_inline_mp
+ logical , pointer :: do_inline_pbl
+ logical , pointer :: do_inline_cnv
+ logical , pointer :: do_inline_gwd
+ integer , pointer :: inline_pbl_flag
+ integer , pointer :: inline_cnv_flag
logical , pointer :: do_aerosol
logical , pointer :: do_cosp
logical , pointer :: do_f3d
@@ -709,6 +714,11 @@ subroutine set_namelist_pointers(Atm)
do_fast_phys => Atm%flagstruct%do_fast_phys
do_intermediate_phys => Atm%flagstruct%do_intermediate_phys
do_inline_mp => Atm%flagstruct%do_inline_mp
+ do_inline_pbl => Atm%flagstruct%do_inline_pbl
+ do_inline_cnv => Atm%flagstruct%do_inline_cnv
+ do_inline_gwd => Atm%flagstruct%do_inline_gwd
+ inline_pbl_flag => Atm%flagstruct%inline_pbl_flag
+ inline_cnv_flag => Atm%flagstruct%inline_cnv_flag
do_aerosol => Atm%flagstruct%do_aerosol
do_cosp => Atm%flagstruct%do_cosp
do_f3d => Atm%flagstruct%do_f3d
@@ -1142,7 +1152,8 @@ end subroutine read_namelist_fv_core_nml
subroutine read_namelist_integ_phys_nml
integer :: ios, ierr
- namelist /integ_phys_nml/ do_sat_adj, do_fast_phys, do_intermediate_phys, do_inline_mp, do_aerosol, do_cosp, consv_checker, te_err, tw_err
+ namelist /integ_phys_nml/ do_sat_adj, do_fast_phys, do_intermediate_phys, do_inline_mp, do_inline_pbl, do_inline_cnv, do_inline_gwd, &
+ inline_pbl_flag, inline_cnv_flag, do_aerosol, do_cosp, consv_checker, te_err, tw_err
read (input_nml_file,integ_phys_nml,iostat=ios)
ierr = check_nml_error(ios,'integ_phys_nml')
diff --git a/model/fv_dynamics.F90 b/model/fv_dynamics.F90
index c657be222..34e2fdcce 100644
--- a/model/fv_dynamics.F90
+++ b/model/fv_dynamics.F90
@@ -51,6 +51,7 @@ module fv_dynamics_mod
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
use fv_arrays_mod, only: fv_diag_type, fv_grid_bounds_type, inline_mp_type, fv_thermo_type
+ use fv_arrays_mod, only: inline_pbl_type, inline_cnv_type, inline_gwd_type
use fv_nwp_nudge_mod, only: do_adiabatic_init
implicit none
@@ -82,7 +83,8 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
ps, pe, pk, peln, pkz, phis, q_con, omga, ua, va, uc, vc, &
ak, bk, mfx, mfy, cx, cy, ze0, hybrid_z, &
gridstruct, flagstruct, neststruct, thermostruct, idiag, bd, &
- parent_grid, domain, inline_mp, heat_source, diss_est, time_total)
+ parent_grid, domain, inline_mp, inline_pbl, inline_cnv, &
+ inline_gwd, heat_source, diss_est, time_total)
real, intent(IN) :: bdt ! Large time-step
real, intent(IN) :: consv_te
@@ -143,6 +145,9 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
real, intent(in), dimension(npz+1):: ak, bk
type(inline_mp_type), intent(inout) :: inline_mp
+ type(inline_pbl_type), intent(inout) :: inline_pbl
+ type(inline_cnv_type), intent(inout) :: inline_cnv
+ type(inline_gwd_type), intent(inout) :: inline_gwd
! Accumulated Mass flux arrays: the "Flux Capacitor"
real, intent(inout) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
@@ -454,6 +459,9 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
inline_mp%mppxs = 0.0
inline_mp%mppxg = 0.0
endif
+ if (flagstruct%do_inline_cnv) then
+ inline_cnv%prec = 0.0
+ endif
call timing_on('FV_DYN_LOOP')
@@ -495,7 +503,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
uc, vc, mfx, mfy, cx, cy, pkz, peln, q_con, ak, bk, ks, &
gridstruct, flagstruct, neststruct, thermostruct, idiag, bd, &
domain, n_map==1, i_pack, last_step, heat_source, diss_est, &
- consv_te, te_2d, time_total)
+ consv_te, te_2d, inline_pbl, inline_gwd, time_total)
call timing_off('DYN_CORE')
#ifdef SW_DYNAMICS
@@ -609,14 +617,14 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill,
nr, nwat, sphum, q_con, u, v, w, delz, pt, q, phis, &
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, &
+ ng, ua, va, omga, dp1, ws, fill, reproduce_sum, idiag, &
ptop, ak, bk, pfull, gridstruct, thermostruct, domain, &
- flagstruct%do_sat_adj, hydrostatic, &
- hybrid_z, &
+ flagstruct%do_sat_adj, fv_time, hydrostatic, hybrid_z, &
flagstruct%adiabatic, do_adiabatic_init, flagstruct%do_inline_mp, &
- inline_mp, bd, flagstruct%fv_debug, &
+ flagstruct%do_inline_pbl, flagstruct%do_inline_cnv, flagstruct%do_inline_gwd, &
+ inline_mp, inline_pbl, inline_cnv, inline_gwd, bd, flagstruct%fv_debug, &
flagstruct%do_fast_phys, flagstruct%do_intermediate_phys, &
- flagstruct%consv_checker, flagstruct%adj_mass_vmr)
+ flagstruct%consv_checker, flagstruct%adj_mass_vmr, flagstruct%inline_pbl_flag, flagstruct%inline_cnv_flag)
if ( flagstruct%fv_debug ) then
if (is_master()) write(*,'(A, I3, A1, I3)') 'finished k_split ', n_map, '/', k_split
diff --git a/model/fv_mapz.F90 b/model/fv_mapz.F90
index 6e79e1632..f9e24034b 100644
--- a/model/fv_mapz.F90
+++ b/model/fv_mapz.F90
@@ -31,13 +31,17 @@ 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 time_manager_mod, only: time_type
use fv_grid_utils_mod, only: g_sum, ptop_min, cubed_to_latlon
use fv_fill_mod, only: fillz
- use mpp_domains_mod, only: domain2d
- use mpp_mod, only: FATAL, NOTE, mpp_error
+ 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_arrays_mod, only: inline_pbl_type, inline_cnv_type, inline_gwd_type, fv_diag_type
use fv_timing_mod, only: timing_on, timing_off
use intermediate_phys_mod, only: intermediate_phys
+ use gfdl_mp_mod, only: c_liq, c_ice
+ use diag_manager_mod, only: send_data
use fv_operators_mod, only: map_scalar, map1_ppm, mapn_tracer, map1_q2, map1_cubic
use fv_thermodynamics_mod, only: moist_cv, fv_thermo_type
@@ -57,11 +61,13 @@ 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, 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, &
+ ng, ua, va, omga, te, ws, fill, reproduce_sum, idiag, &
ptop, ak, bk, pfull, gridstruct, thermostruct, domain, do_sat_adj, &
- hydrostatic, hybrid_z, adiabatic, do_adiabatic_init, &
- do_inline_mp, inline_mp, bd, fv_debug, &
- do_fast_phys, do_intermediate_phys, consv_checker, adj_mass_vmr)
+ fv_time, hydrostatic, hybrid_z, adiabatic, do_adiabatic_init, &
+ do_inline_mp, do_inline_pbl, do_inline_cnv, do_inline_gwd, &
+ inline_mp, inline_pbl, inline_cnv, inline_gwd, bd, fv_debug, &
+ do_fast_phys, do_intermediate_phys, consv_checker, adj_mass_vmr, &
+ inline_pbl_flag, inline_cnv_flag)
logical, intent(in):: last_step
logical, intent(in):: fv_debug
@@ -83,6 +89,8 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
integer, intent(in):: kord_wz ! Mapping order/option for w
integer, intent(in):: kord_tr(nq) ! Mapping order for tracers
integer, intent(in):: kord_tm ! Mapping order for thermodynamics
+ integer, intent(in):: inline_pbl_flag
+ integer, intent(in):: inline_cnv_flag
real, intent(in):: consv ! factor for TE conservation
real, intent(in):: r_vir
@@ -96,6 +104,9 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
logical, intent(in):: do_sat_adj
logical, intent(in):: do_inline_mp
+ logical, intent(in):: do_inline_pbl
+ logical, intent(in):: do_inline_cnv
+ logical, intent(in):: do_inline_gwd
logical, intent(in):: fill ! fill negative tracers
logical, intent(in):: reproduce_sum
logical, intent(in):: adiabatic, do_adiabatic_init
@@ -108,6 +119,8 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
type(fv_thermo_type), intent(IN), target :: thermostruct
type(domain2d), intent(INOUT) :: domain
type(fv_grid_bounds_type), intent(IN) :: bd
+ type(fv_diag_type), intent(IN) :: idiag
+ type(time_type), intent(IN) :: fv_time
! !INPUT/OUTPUT
real, intent(inout):: pk(is:ie,js:je,km+1) ! pe to the kappa
@@ -135,6 +148,9 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
real, intent(out):: te(isd:ied,jsd:jed,km)
type(inline_mp_type), intent(inout):: inline_mp
+ type(inline_pbl_type), intent(inout):: inline_pbl
+ type(inline_cnv_type), intent(inout):: inline_cnv
+ type(inline_gwd_type), intent(inout):: inline_gwd
! !DESCRIPTION:
!
@@ -154,6 +170,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
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, aerosol
+ logical used
k1k = rdgas/cv_air ! akap / (1.-akap) = rg/Cv=0.4
rg = rdgas
@@ -776,14 +793,62 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, &
! Intermediate Physics >>>
! Note: if intemediate physics is disable, cloud fraction will be zero at the first time step.
!-----------------------------------------------------------------------
+
if (do_intermediate_phys) then
+
call timing_on('INTERMEDIATE_PHYS')
+
call intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, &
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, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, &
- do_inline_mp, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr)
+ v, w, omga, pt, delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, &
+ inline_mp, inline_pbl, inline_cnv, inline_gwd, gridstruct, thermostruct, domain, bd, &
+ hydrostatic, do_adiabatic_init, do_inline_mp, do_inline_pbl, do_inline_cnv, &
+ do_inline_gwd, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr, &
+ inline_pbl_flag, inline_cnv_flag)
+
+ if (idiag%id_inline_mp_fast_te_a_chg>0) &
+ used = send_data(idiag%id_inline_mp_fast_te_a_chg, inline_mp%fast_te_a_chg, fv_time)
+ if (idiag%id_inline_mp_fast_te_b_chg>0) &
+ used = send_data(idiag%id_inline_mp_fast_te_b_chg, inline_mp%fast_te_b_chg, fv_time)
+ if (idiag%id_inline_mp_fast_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_mp_fast_tw_a_chg, inline_mp%fast_tw_a_chg, fv_time)
+ if (idiag%id_inline_mp_fast_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_mp_fast_tw_b_chg, inline_mp%fast_tw_b_chg, fv_time)
+ if (idiag%id_inline_pbl_intm_te_a_chg>0) &
+ used = send_data(idiag%id_inline_pbl_intm_te_a_chg, inline_pbl%intm_te_a_chg, fv_time)
+ if (idiag%id_inline_pbl_intm_te_b_chg>0) &
+ used = send_data(idiag%id_inline_pbl_intm_te_b_chg, inline_pbl%intm_te_b_chg, fv_time)
+ if (idiag%id_inline_pbl_intm_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_pbl_intm_tw_a_chg, inline_pbl%intm_tw_a_chg, fv_time)
+ if (idiag%id_inline_pbl_intm_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_pbl_intm_tw_b_chg, inline_pbl%intm_tw_b_chg, fv_time)
+ if (idiag%id_inline_cnv_intm_te_a_chg>0) &
+ used = send_data(idiag%id_inline_cnv_intm_te_a_chg, inline_cnv%intm_te_a_chg, fv_time)
+ if (idiag%id_inline_cnv_intm_te_b_chg>0) &
+ used = send_data(idiag%id_inline_cnv_intm_te_b_chg, inline_cnv%intm_te_b_chg, fv_time)
+ if (idiag%id_inline_cnv_intm_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_cnv_intm_tw_a_chg, inline_cnv%intm_tw_a_chg, fv_time)
+ if (idiag%id_inline_cnv_intm_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_cnv_intm_tw_b_chg, inline_cnv%intm_tw_b_chg, fv_time)
+ if (idiag%id_inline_gwd_intm_te_a_chg>0) &
+ used = send_data(idiag%id_inline_gwd_intm_te_a_chg, inline_gwd%intm_te_a_chg, fv_time)
+ if (idiag%id_inline_gwd_intm_te_b_chg>0) &
+ used = send_data(idiag%id_inline_gwd_intm_te_b_chg, inline_gwd%intm_te_b_chg, fv_time)
+ if (idiag%id_inline_gwd_intm_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_gwd_intm_tw_a_chg, inline_gwd%intm_tw_a_chg, fv_time)
+ if (idiag%id_inline_gwd_intm_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_gwd_intm_tw_b_chg, inline_gwd%intm_tw_b_chg, fv_time)
+ if (idiag%id_inline_mp_intm_te_a_chg>0) &
+ used = send_data(idiag%id_inline_mp_intm_te_a_chg, inline_mp%intm_te_a_chg, fv_time)
+ if (idiag%id_inline_mp_intm_te_b_chg>0) &
+ used = send_data(idiag%id_inline_mp_intm_te_b_chg, inline_mp%intm_te_b_chg, fv_time)
+ if (idiag%id_inline_mp_intm_tw_a_chg>0) &
+ used = send_data(idiag%id_inline_mp_intm_tw_a_chg, inline_mp%intm_tw_a_chg, fv_time)
+ if (idiag%id_inline_mp_intm_tw_b_chg>0) &
+ used = send_data(idiag%id_inline_mp_intm_tw_b_chg, inline_mp%intm_tw_b_chg, fv_time)
+
call timing_off('INTERMEDIATE_PHYS')
+
endif
!-----------------------------------------------------------------------
diff --git a/model/intermediate_phys.F90 b/model/intermediate_phys.F90
index e629d4e20..008469a8c 100644
--- a/model/intermediate_phys.F90
+++ b/model/intermediate_phys.F90
@@ -28,17 +28,25 @@
module intermediate_phys_mod
#ifdef OVERLOAD_R4
- use constantsR4_mod, only: rdgas, grav
+ use constantsR4_mod, only: rdgas, rvgas, grav, kappa, cp_air
#else
- use constants_mod, only: rdgas, grav
+ use constants_mod, only: rdgas, rvgas, grav, kappa, cp_air
#endif
use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys
use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, inline_mp_type
+ use fv_arrays_mod, only: inline_pbl_type, inline_cnv_type, inline_gwd_type
use fv_arrays_mod, only: fv_thermo_type
use mpp_domains_mod, only: domain2d, mpp_update_domains
use tracer_manager_mod, only: get_tracer_index, get_tracer_names
use field_manager_mod, only: model_atmos
- use gfdl_mp_mod, only: gfdl_mp_driver, fast_sat_adj, mtetw
+ use gfdl_mp_mod, only: gfdl_mp_driver, fast_sat_adj, c_liq, c_ice, cv_air, &
+ cv_vap, hlv, hlf, mtetw, tice
+ use sa_tke_edmf_mod, only: sa_tke_edmf_sfc, sa_tke_edmf_pbl
+ use sa_tke_edmf_new_mod, only: sa_tke_edmf_new_sfc, sa_tke_edmf_new_pbl
+ use sa_sas_mod, only: sa_sas_deep, sa_sas_shal
+ use sa_aamf_mod, only: sa_aamf_deep, sa_aamf_shal
+ use sa_gwd_mod, only: sa_gwd_oro, sa_gwd_cnv
+ use fv_timing_mod, only: timing_on, timing_off
implicit none
@@ -57,10 +65,13 @@ module intermediate_phys_mod
contains
subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, &
- 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, &
+ mdt, consv, akap, ptop, pfull, hs, te0_2d, u, v, w, omga, pt, &
+ delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, &
+ inline_mp, inline_pbl, inline_cnv, inline_gwd, &
gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, &
- do_inline_mp, do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr)
+ do_inline_mp, do_inline_pbl, do_inline_cnv, do_inline_gwd, &
+ do_sat_adj, last_step, do_fast_phys, consv_checker, adj_mass_vmr, &
+ inline_pbl_flag, inline_cnv_flag)
implicit none
@@ -68,11 +79,10 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
! input / output arguments
! -----------------------------------------------------------------------
- integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat
+ integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, nwat, inline_pbl_flag, inline_cnv_flag, adj_mass_vmr
- logical, intent (in) :: hydrostatic, do_adiabatic_init, do_inline_mp, consv_checker
- logical, intent (in) :: do_sat_adj, last_step, do_fast_phys
- integer, intent (in) :: adj_mass_vmr
+ logical, intent (in) :: hydrostatic, do_adiabatic_init, do_inline_mp, do_inline_pbl, consv_checker
+ logical, intent (in) :: do_inline_cnv, do_inline_gwd, do_sat_adj, last_step, do_fast_phys
real, intent (in) :: consv, mdt, akap, r_vir, ptop, te_err, tw_err
@@ -80,6 +90,8 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
real, intent (in), dimension (isd:ied, jsd:jed) :: hs
+ real, intent (in), dimension (isd:ied, jsd:jed, km) :: omga
+
real, intent (inout), dimension (is:, js:, 1:) :: delz
real, intent (inout), dimension (isd:, jsd:, 1:) :: q_con, cappa, w
@@ -106,40 +118,55 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
type (inline_mp_type), intent (inout) :: inline_mp
+ type (inline_pbl_type), intent (inout) :: inline_pbl
+
+ type (inline_cnv_type), intent (inout) :: inline_cnv
+
+ type (inline_gwd_type), intent (inout) :: inline_gwd
+
! -----------------------------------------------------------------------
! local variables
! -----------------------------------------------------------------------
+ logical :: safety_check = .true.
+
logical, allocatable, dimension (:) :: conv_vmr_mmr
- integer :: i, j, k, m, kmp, sphum, liq_wat, ice_wat
+ integer :: i, j, k, m, n, kr, kmp, ncld, ntke, sphum, liq_wat, ice_wat, lsoil
integer :: rainwat, snowwat, graupel, cld_amt, ccn_cm3, cin_cm3, aerosol
+ integer :: ios, ntchm, ntchs
integer :: k_con, k_cappa
- real :: rrg
+ real :: rrg, tem
- real, dimension (is:ie) :: gsize
+ real, dimension (is:ie) :: gsize, dqv, dql, dqi, dqr, dqs, dqg, ps_dt, q_liq, q_sol, c_moist, k1, k2
- real, dimension (is:ie, km) :: q2, q3, qliq, qsol, adj_vmr
+ real, dimension (is:ie, km) :: q2, q3, qliq, qsol, cvm, 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
+ integer, allocatable, dimension (:) :: kinver, vegtype
+
+ real, allocatable, dimension (:) :: rn, rb, u10m, v10m, sigmaf, stress, wind, tmp, wz, fscav
- real, allocatable, dimension (:,:) :: dz, wa
+ real, allocatable, dimension (:) :: dtsfc, dqvsfc, dqlsfc, dqisfc, dqrsfc, dqssfc, dqgsfc
- real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0
+ real, allocatable, dimension (:,:) :: dz, zm, zi, wa, dp, pm, pi, pmk, pik, qv, ql, qr, ta, uu, vv, ww, radh
+
+ real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0, qa
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
+ real (kind = r8), dimension (is:ie, 1:km) :: te_beg, te_end, tw_beg, tw_end, te8, dte8
character (len = 32) :: tracer_units, tracer_name
+ character (len = 20) :: fscav_aero (20) = 'default'
+
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')
@@ -150,6 +177,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
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')
+ ntke = get_tracer_index (model_atmos, 'sgs_tke')
rrg = - rdgas / grav
@@ -187,6 +215,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
else
k_cappa = 1
endif
+
!-----------------------------------------------------------------------
! Fast Saturation Adjustment >>>
!-----------------------------------------------------------------------
@@ -389,22 +418,26 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
! 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)), &
- !(sum (te_end (i, kmp:km)) + te_b_end (i)), &
- (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)), &
- !(sum (tw_end (i, kmp:km)) + tw_b_end (i)), &
- (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
+ !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)), &
+ ! !(sum (te_end (i, kmp:km)) + te_b_end (i)), &
+ ! (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
+ inline_mp%fast_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_mp%fast_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !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)), &
+ ! !(sum (tw_end (i, kmp:km)) + tw_b_end (i)), &
+ ! (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
+ inline_mp%fast_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_mp%fast_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
!print*, "FAST_SAT_ADJ LOSS (%) : ", te_loss (i) / (sum (te_beg (i, kmp:km)) + te_b_beg (i)) * 100.0
enddo
endif
@@ -423,17 +456,50 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
- ! Inline GFDL MP >>>
+ ! Inline Planetary Boundary Layer >>>
!-----------------------------------------------------------------------
- if ((.not. do_adiabatic_init) .and. do_inline_mp .and. nwat .eq. 6) then
+ if ((.not. do_adiabatic_init) .and. do_inline_pbl .and. (.not. do_fast_phys)) then
+
+ allocate (kinver (is:ie))
+
+ allocate (dz (is:ie, 1:km))
+ allocate (zm (is:ie, 1:km))
+ allocate (zi (is:ie, 1:km+1))
+ allocate (dp (is:ie, 1:km))
+ allocate (pm (is:ie, 1:km))
+ allocate (pi (is:ie, 1:km+1))
+ allocate (pmk (is:ie, 1:km))
+ allocate (pik (is:ie, 1:km+1))
+
+ allocate (ta (is:ie, 1:km))
+ allocate (uu (is:ie, 1:km))
+ allocate (vv (is:ie, 1:km))
+ allocate (qa (is:ie, 1:km, 1:nq))
+
+ allocate (radh (is:ie, 1:km))
+ allocate (rb (is:ie))
+ allocate (u10m (is:ie))
+ allocate (v10m (is:ie))
+ allocate (stress (is:ie))
+ allocate (wind (is:ie))
+ allocate (sigmaf (is:ie))
+ allocate (vegtype (is:ie))
+
+ allocate (dtsfc (is:ie))
+ allocate (dqvsfc (is:ie))
+ allocate (dqlsfc (is:ie))
+ allocate (dqisfc (is:ie))
+ allocate (dqrsfc (is:ie))
+ allocate (dqssfc (is:ie))
+ allocate (dqgsfc (is:ie))
+
+ allocate (tz (1:km))
+ allocate (wz (1:km))
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
@@ -462,102 +528,66 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
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, k_con, k_cappa, thermostruct) &
-!$OMP private (q2, q3, gsize, dz, wa, pe, peln, adj_vmr, qliq, qsol, &
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, km, nq, ua, va, w, &
+!$OMP te, delp, hydrostatic, hs, pt, delz, q_con, &
+!$OMP rainwat, liq_wat, ice_wat, snowwat, graupel, &
+!$OMP sphum, pkz, consv, te0_2d, gridstruct, q, &
+!$OMP mdt, cappa, rrg, akap, r_vir, u_dt, v_dt, &
+!$OMP ptop, ntke, inline_pbl, safety_check, nwat, &
+!$OMP adj_mass_vmr, conv_vmr_mmr, consv_checker, &
+!$OMP te_err, tw_err, inline_pbl_flag, thermostruct) &
+!$OMP private (gsize, dz, zi, pi, pik, pmk, lsoil, pe, &
+!$OMP zm, dp, pm, ta, uu, vv, qliq, qsol, qa, adj_vmr, &
+!$OMP radh, rb, u10m, v10m, sigmaf, vegtype, q_liq, &
+!$OMP stress, wind, kinver, q_sol, c_moist, peln, &
+!$OMP cvm, kr, dqv, dql, dqi, dqr, dqs, dqg, ps_dt, &
!$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)
+!$OMP te_end, tw_end, te_b_end, tw_b_end, te_loss, &
+!$OMP dtsfc, dqvsfc, dqlsfc, dqisfc, dqrsfc, dqssfc, dqgsfc)
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
-
! 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)
+ u_dt (is:ie, j, 1:km) = ua (is:ie, j, 1:km)
+ v_dt (is:ie, j, 1:km) = va (is:ie, j, 1: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)
+ kinver = km
+ lsoil = 4
+
+ ! total energy before parameterization
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = - cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ 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
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_beg (is:ie, 1:km) = 0.0
+ tw_beg (is:ie, 1: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))))
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
if (hydrostatic) then
- wz (kmp:km) = 0.0
+ wz = 0.0
else
- wz (kmp:km) = w (i, j, kmp:km)
+ wz = w (i, j, 1: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), 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), &
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_beg (i, 1:km), tw_beg (i, 1:km), &
te_b_beg (i), tw_b_beg (i), .true., hydrostatic)
enddo
endif
@@ -570,158 +600,1673 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
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)
+ ! vertical index flip over
+ zi (is:ie, 1) = 0.0
+ pi (is:ie, 1) = pe (is:ie, km+1)
+ pik (is:ie, 1) = exp (kappa * log (pi (is:ie, 1) * 1.e-5))
+ inline_pbl%dtsfc (is:ie, j) = 0.0
+ inline_pbl%dqsfc (is:ie, j) = 0.0
+ dtsfc (is:ie) = 0.0
+ dqvsfc (is:ie) = 0.0
+ dqlsfc (is:ie) = 0.0
+ dqisfc (is:ie) = 0.0
+ dqrsfc (is:ie) = 0.0
+ dqssfc (is:ie) = 0.0
+ dqgsfc (is:ie) = 0.0
+ inline_pbl%dusfc (is:ie, j) = 0.0
+ inline_pbl%dvsfc (is:ie, j) = 0.0
+ inline_pbl%dksfc (is:ie, j) = 0.0
+ do k = 1, km
+ kr = km - k + 1
+ dp (is:ie, k) = delp (is:ie, j, kr)
+ pi (is:ie, k+1) = pe (is:ie, kr)
+ pik (is:ie, k+1) = exp (kappa * log (pi (is:ie, k+1) * 1.e-5))
+ if (.not. hydrostatic) then
+ pm (is:ie, k) = dp (is:ie, k) / delz (is:ie, j, kr) * &
+ rrg * pt (is:ie, j, kr)
+ dz (is:ie, k) = delz (is:ie, j, kr)
+ ! ensure subgrid monotonicity of pressure
+ do i = is, ie
+ pm (i, k) = min (pm (i, k), pi (i, k) - 0.01 * pm (i, k))
+ pm (i, k) = max (pm (i, k), pi (i, k+1) + 0.01 * pm (i, k))
+ enddo
+ else
+ pm (is:ie, k) = dp (is:ie, k) / (peln (is:ie, kr+1) - peln (is:ie, kr))
+ dz (is:ie, k) = (peln (is:ie, kr+1) - peln (is:ie, kr)) * &
+ rrg * pt (is:ie, j, kr)
+ endif
+ pmk (is:ie, k) = exp (kappa * log (pm (is:ie, k) * 1.e-5))
+ zi (is:ie, k+1) = zi (is:ie, k) - dz (is:ie, k) * grav
+ if (k .eq. 1) then
+ zm (is:ie, k) = - 0.5 * dz (is:ie, k) * grav
+ else
+ zm (is:ie, k) = zm (is:ie, k-1) - 0.5 * (dz (is:ie, k-1) + dz (is:ie, k)) * grav
+ endif
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ ta (is:ie, k) = pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * &
+ (1. - (q_liq + q_sol)))
+ uu (is:ie, k) = ua (is:ie, j, kr)
+ vv (is:ie, k) = va (is:ie, j, kr)
+ qa (is:ie, k, 1:nq) = q (is:ie, j, kr, 1:nq)
+ radh (is:ie, k) = inline_pbl%radh (is:ie, j, kr)
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ inline_pbl%dtsfc (is:ie, j) = inline_pbl%dtsfc (is:ie, j) - cp_air * ta (is:ie, k) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dqsfc (is:ie, j) = inline_pbl%dqsfc (is:ie, j) - (hlv - rvgas * tice + (cv_vap - c_liq) * (ta (is:ie, k) - tice)) * q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dtsfc (is:ie) = dtsfc (is:ie) - c_moist * ta (is:ie, k) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqvsfc (is:ie) = dqvsfc (is:ie) - q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqlsfc (is:ie) = dqlsfc (is:ie) - q (is:ie, j, kr, liq_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqisfc (is:ie) = dqisfc (is:ie) - q (is:ie, j, kr, ice_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqrsfc (is:ie) = dqrsfc (is:ie) - q (is:ie, j, kr, rainwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqssfc (is:ie) = dqssfc (is:ie) - q (is:ie, j, kr, snowwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqgsfc (is:ie) = dqgsfc (is:ie) - q (is:ie, j, kr, graupel) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dusfc (is:ie, j) = inline_pbl%dusfc (is:ie, j) - ua (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dvsfc (is:ie, j) = inline_pbl%dvsfc (is:ie, j) - va (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dksfc (is:ie, j) = inline_pbl%dksfc (is:ie, j) - 0.5 * (ua (is:ie, j, kr) ** 2 + va (is:ie, j, kr) ** 2 + w (is:ie, j, kr) ** 2) * delp (is:ie, j, kr) / grav / abs (mdt)
+ enddo
+
+ do i = is, ie
+ sigmaf (i) = max (inline_pbl%vfrac (i, j), 0.01)
+ vegtype (i) = int (inline_pbl%vtype (i, j) + 0.5)
+ enddo
+
+ ! check if pressure or height cross over
+ if (safety_check) then
+ do k = 1, km
+ do i = is, ie
+ if (k .lt. km) then
+ if (pm (i, k) .le. pm (i, k+1)) then
+ print*, "Warning: inline edmf pressure layer cross over", k, pm (i, k), pm (i, k+1)
+ endif
+ if (zm (i, k) .ge. zm (i, k+1)) then
+ print*, "Warning: inline edmf height layer cross over", k, zm (i, k), zm (i, k+1)
+ endif
+ endif
+ if (pi (i, k) .le. pi (i, k+1)) then
+ print*, "Warning: inline edmf pressure interface cross over", k, pi (i, k), pi (i, k+1)
+ endif
+ if (zi (i, k) .ge. zi (i, k+1)) then
+ print*, "Warning: inline edmf height interface cross over", k, zi (i, k), zi (i, k+1)
+ endif
+ enddo
+ enddo
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, &
- q_con (is:ie, j, k_con:), cappa (is:ie, j, k_cappa:), &
- consv .gt. consv_min, adj_vmr (is:ie, kmp:km), te (is:ie, j, kmp:km), dte (is:ie), &
- inline_mp%prefluxw(is:ie, j, kmp:km), &
- inline_mp%prefluxr(is:ie, j, kmp:km), inline_mp%prefluxi(is:ie, j, kmp:km), &
- inline_mp%prefluxs(is:ie, j, kmp:km), inline_mp%prefluxg(is:ie, j, kmp:km), &
- inline_mp%mppcw (is:ie, j), inline_mp%mppew (is:ie, j), inline_mp%mppe1 (is:ie, j), &
- inline_mp%mpper (is:ie, j), inline_mp%mppdi (is:ie, j), inline_mp%mppd1 (is:ie, j), &
- inline_mp%mppds (is:ie, j), inline_mp%mppdg (is:ie, j), inline_mp%mppsi (is:ie, j), &
- inline_mp%mpps1 (is:ie, j), inline_mp%mppss (is:ie, j), inline_mp%mppsg (is:ie, j), &
- inline_mp%mppfw (is:ie, j), inline_mp%mppfr (is:ie, j), inline_mp%mppmi (is:ie, j), &
- inline_mp%mppms (is:ie, j), inline_mp%mppmg (is:ie, j), inline_mp%mppm1 (is:ie, j), &
- inline_mp%mppm2 (is:ie, j), inline_mp%mppm3 (is:ie, j), inline_mp%mppar (is:ie, j), &
- inline_mp%mppas (is:ie, j), inline_mp%mppag (is:ie, j), inline_mp%mpprs (is:ie, j), &
- inline_mp%mpprg (is:ie, j), inline_mp%mppxr (is:ie, j), inline_mp%mppxs (is:ie, j), &
- inline_mp%mppxg (is:ie, j), last_step, do_inline_mp, &
- thermostruct%use_cond, thermostruct%moist_kappa)
+ if (inline_pbl_flag .eq. 1) &
+ ! diagnose surface variables for PBL parameterization
+ call sa_tke_edmf_sfc (ie-is+1, lsoil, pi (is:ie, 1), uu (is:ie, 1), &
+ vv (is:ie, 1), ta (is:ie, 1), qa (is:ie, 1, sphum), &
+ abs (mdt), inline_pbl%tsfc (is:ie, j), pm (is:ie, 1), &
+ pik (is:ie, 1) / pmk (is:ie, 1), inline_pbl%evap (is:ie, j), &
+ inline_pbl%hflx (is:ie, j), inline_pbl%ffmm (is:ie, j), &
+ inline_pbl%ffhh (is:ie, j), zm (is:ie, 1) / grav, &
+ inline_pbl%snowd (is:ie, j), inline_pbl%zorl (is:ie, j), inline_pbl%ztrl (is:ie, j), &
+ inline_pbl%lsm (is:ie, j), inline_pbl%uustar (is:ie, j), sigmaf, vegtype, &
+ inline_pbl%shdmax (is:ie, j), inline_pbl%sfcemis (is:ie, j), &
+ inline_pbl%dlwflx (is:ie, j), inline_pbl%sfcnsw (is:ie, j), &
+ inline_pbl%sfcdsw (is:ie, j), inline_pbl%srflag (is:ie, j), &
+ inline_pbl%hice (is:ie, j), inline_pbl%fice (is:ie, j), &
+ inline_pbl%tice (is:ie, j), inline_pbl%weasd (is:ie, j), &
+ inline_pbl%tprcp (is:ie, j), inline_pbl%stc (is:ie, j, :), &
+ inline_pbl%qsurf (is:ie, j), inline_pbl%cmm (is:ie, j), &
+ inline_pbl%chh (is:ie, j), inline_pbl%gflux (is:ie, j), &
+ inline_pbl%ep (is:ie, j), u10m_out = u10m, v10m_out = v10m, &
+ rb_out = rb, stress_out = stress, wind_out = wind)
+
+ ! SA-TKE-EDMF main program
+ call sa_tke_edmf_pbl (ie-is+1, km, nq, liq_wat, ice_wat, ntke, &
+ abs (mdt), uu, vv, ta, qa, gsize, inline_pbl%lsm (is:ie, j), &
+ radh, rb, inline_pbl%zorl (is:ie, j), u10m, v10m, &
+ inline_pbl%ffmm (is:ie, j), inline_pbl%ffhh (is:ie, j), &
+ inline_pbl%tsfc (is:ie, j), inline_pbl%hflx (is:ie, j), &
+ inline_pbl%evap (is:ie, j), stress, wind, kinver, &
+ pik (is:ie, 1), dp, pi, pm, pmk, zi, zm, &
+ inline_pbl%hpbl (is:ie, j), inline_pbl%kpbl (is:ie, j))
+ !inline_pbl%dusfc (is:ie, j), inline_pbl%dvsfc (is:ie, j), &
+ !inline_pbl%dtsfc (is:ie, j), inline_pbl%dqsfc (is:ie, j))
+
+ if (inline_pbl_flag .eq. 2) &
+ ! diagnose surface variables for PBL parameterization
+ call sa_tke_edmf_new_sfc (ie-is+1, lsoil, pi (is:ie, 1), uu (is:ie, 1), &
+ vv (is:ie, 1), ta (is:ie, 1), qa (is:ie, 1, sphum), &
+ abs (mdt), inline_pbl%tsfc (is:ie, j), pm (is:ie, 1), &
+ pik (is:ie, 1) / pmk (is:ie, 1), inline_pbl%evap (is:ie, j), &
+ inline_pbl%hflx (is:ie, j), inline_pbl%ffmm (is:ie, j), &
+ inline_pbl%ffhh (is:ie, j), zm (is:ie, 1) / grav, &
+ inline_pbl%snowd (is:ie, j), inline_pbl%zorl (is:ie, j), inline_pbl%ztrl (is:ie, j), &
+ inline_pbl%lsm (is:ie, j), inline_pbl%uustar (is:ie, j), sigmaf, vegtype, &
+ inline_pbl%shdmax (is:ie, j), inline_pbl%sfcemis (is:ie, j), &
+ inline_pbl%dlwflx (is:ie, j), inline_pbl%sfcnsw (is:ie, j), &
+ inline_pbl%sfcdsw (is:ie, j), inline_pbl%srflag (is:ie, j), &
+ inline_pbl%hice (is:ie, j), inline_pbl%fice (is:ie, j), &
+ inline_pbl%tice (is:ie, j), inline_pbl%weasd (is:ie, j), &
+ inline_pbl%tprcp (is:ie, j), inline_pbl%stc (is:ie, j, :), &
+ inline_pbl%qsurf (is:ie, j), inline_pbl%cmm (is:ie, j), &
+ inline_pbl%chh (is:ie, j), inline_pbl%gflux (is:ie, j), &
+ inline_pbl%ep (is:ie, j), u10m_out = u10m, v10m_out = v10m, &
+ rb_out = rb, stress_out = stress, wind_out = wind)
+
+ ! SA-TKE-EDMF main program
+ call sa_tke_edmf_new_pbl (ie-is+1, km, nq, liq_wat, ice_wat, ntke, &
+ abs (mdt), uu, vv, ta, qa, gsize, inline_pbl%lsm (is:ie, j), &
+ radh, rb, sigmaf, inline_pbl%zorl (is:ie, j), u10m, v10m, &
+ inline_pbl%ffmm (is:ie, j), inline_pbl%ffhh (is:ie, j), &
+ inline_pbl%tsfc (is:ie, j), inline_pbl%hflx (is:ie, j), &
+ inline_pbl%evap (is:ie, j), stress, wind, kinver, &
+ pik (is:ie, 1), dp, pi, pm, pmk, zi, zm, &
+ inline_pbl%hpbl (is:ie, j), inline_pbl%kpbl (is:ie, j))
+ !inline_pbl%dusfc (is:ie, j), inline_pbl%dvsfc (is:ie, j), &
+ !inline_pbl%dtsfc (is:ie, j), inline_pbl%dqsfc (is:ie, j))
+
+ ! update u, v, T, q, and delp, vertical index flip over
+ do k = 1, km
+ kr = km - k + 1
+ q (is:ie, j, kr, nwat+1:nq) = qa (is:ie, k, nwat+1:nq)
+ dqv = qa (is:ie, k, sphum) - q (is:ie, j, kr, sphum)
+ dql = qa (is:ie, k, liq_wat) - q (is:ie, j, kr, liq_wat)
+ dqi = qa (is:ie, k, ice_wat) - q (is:ie, j, kr, ice_wat)
+ dqr = qa (is:ie, k, rainwat) - q (is:ie, j, kr, rainwat)
+ dqs = qa (is:ie, k, snowwat) - q (is:ie, j, kr, snowwat)
+ dqg = qa (is:ie, k, graupel) - q (is:ie, j, kr, graupel)
+ ps_dt = 1 + dqv + dql + dqi + dqr + dqs + dqg
+ adj_vmr (is:ie, kr) = (ps_dt - (qa (is:ie, k, sphum) + &
+ qa (is:ie, k, liq_wat) + qa (is:ie, k, ice_wat) + &
+ qa (is:ie, k, rainwat) + qa (is:ie, k, snowwat) + &
+ qa (is:ie, k, graupel))) / (1. - (qa (is:ie, k, sphum) + &
+ qa (is:ie, k, liq_wat) + qa (is:ie, k, ice_wat) + &
+ qa (is:ie, k, rainwat) + qa (is:ie, k, snowwat) + &
+ qa (is:ie, k, graupel))) / ps_dt
+ q (is:ie, j, kr, sphum) = qa (is:ie, k, sphum) / ps_dt
+ q (is:ie, j, kr, liq_wat) = qa (is:ie, k, liq_wat) / ps_dt
+ q (is:ie, j, kr, ice_wat) = qa (is:ie, k, ice_wat) / ps_dt
+ q (is:ie, j, kr, rainwat) = qa (is:ie, k, rainwat) / ps_dt
+ q (is:ie, j, kr, snowwat) = qa (is:ie, k, snowwat) / ps_dt
+ q (is:ie, j, kr, graupel) = qa (is:ie, k, graupel) / ps_dt
+ delp (is:ie, j, kr) = delp (is:ie, j, kr) * ps_dt
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ if (thermostruct%use_cond) then
+ q_con (is:ie, j, kr) = q_liq + q_sol
+ endif
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ if (thermostruct%moist_kappa) then
+ cappa (is:ie, j, kr) = rdgas / (rdgas + c_moist / (1. + r_vir * q (is:ie, j, kr, sphum)))
+ endif
+ pt (is:ie, j, kr) = pt (is:ie, j, kr) + (ta (is:ie, k) * &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol))) - &
+ pt (is:ie, j, kr)) * cp_air / c_moist
+ ua (is:ie, j, kr) = uu (is:ie, k)
+ va (is:ie, j, kr) = vv (is:ie, k)
+ inline_pbl%dtsfc (is:ie, j) = inline_pbl%dtsfc (is:ie, j) + cp_air * ta (is:ie, k) * delp (is:ie, j, kr) / ps_dt / grav / abs (mdt)
+ inline_pbl%dqsfc (is:ie, j) = inline_pbl%dqsfc (is:ie, j) + (hlv - rvgas * tice + (cv_vap - c_liq) * (ta (is:ie, k) - tice)) * q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dtsfc (is:ie) = dtsfc (is:ie) + c_moist * (pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol)))) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqvsfc (is:ie) = dqvsfc (is:ie) + q (is:ie, j, kr, sphum) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqlsfc (is:ie) = dqlsfc (is:ie) + q (is:ie, j, kr, liq_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqisfc (is:ie) = dqisfc (is:ie) + q (is:ie, j, kr, ice_wat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqrsfc (is:ie) = dqrsfc (is:ie) + q (is:ie, j, kr, rainwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqssfc (is:ie) = dqssfc (is:ie) + q (is:ie, j, kr, snowwat) * delp (is:ie, j, kr) / grav / abs (mdt)
+ dqgsfc (is:ie) = dqgsfc (is:ie) + q (is:ie, j, kr, graupel) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dusfc (is:ie, j) = inline_pbl%dusfc (is:ie, j) + ua (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dvsfc (is:ie, j) = inline_pbl%dvsfc (is:ie, j) + va (is:ie, j, kr) * delp (is:ie, j, kr) / grav / abs (mdt)
+ inline_pbl%dksfc (is:ie, j) = inline_pbl%dksfc (is:ie, j) + 0.5 * (ua (is:ie, j, kr) ** 2 + va (is:ie, j, kr) ** 2 + w (is:ie, j, kr) ** 2) * delp (is:ie, j, kr) / grav / abs (mdt)
+ enddo
! update non-microphyiscs tracers due to mass change
if (adj_mass_vmr .gt. 0) 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)
+ q (is:ie, j, 1:km, m) = q (is:ie, j, 1:km, m) * adj_vmr (is:ie, 1: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)
+ u_dt (is:ie, j, 1:km) = (ua (is:ie, j, 1:km) - u_dt (is:ie, j, 1:km)) / abs (mdt)
+ v_dt (is:ie, j, 1:km) = (va (is:ie, j, 1:km) - v_dt (is:ie, j, 1:km)) / abs (mdt)
! update pkz
if (.not. hydrostatic) then
- if (thermostruct%moist_kappa) then
- pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * &
- log (rrg * delp (is:ie, j, kmp:km) / &
- delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
- else
- pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / &
- delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
- endif
+ if (thermostruct%moist_kappa) then
+ pkz (is:ie, j, 1:km) = exp (cappa (is:ie, j, 1:km) * &
+ log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ else
+ pkz (is:ie, j, 1:km) = exp (akap * log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1: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
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_end (is:ie, 1:km) = 0.0
+ tw_end (is:ie, 1: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))))
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
if (hydrostatic) then
- wz (kmp:km) = 0.0
+ wz = 0.0
else
- wz (kmp:km) = w (i, j, kmp:km)
+ wz = w (i, j, 1: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), 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), &
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), - dqvsfc (i) * 86400, - dqlsfc (i) * 86400, &
+ - dqrsfc (i) * 86400, - dqisfc (i) * 86400, - dqssfc (i) * 86400, - dqgsfc (i) * 86400, &
+ - dtsfc (i), - inline_pbl%dksfc (i, j), abs (mdt), te_end (i, 1:km), tw_end (i, 1:km), &
te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
enddo
endif
- ! add total energy change to te0_2d
+ ! total energy after parameterization, 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
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = te (is:ie, j, 1:km) + &
+ cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ do k = 1, km
+ te0_2d (is:ie, j) = te0_2d (is:ie, j) + te (is:ie, j, k)
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)), &
- !(sum (te_end (i, kmp:km)) + te_b_end (i)), &
- (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)), &
- !(sum (tw_end (i, kmp:km)) + tw_b_end (i)), &
- (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
+ !if (abs (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i)) .gt. te_err) then
+ ! print*, "PBL-INTM TE: ", &
+ ! !(sum (te_beg (i, :)) + te_b_beg (i)), &
+ ! !(sum (te_end (i, :)) + te_b_end (i)), &
+ ! (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i))
+ !endif
+ inline_pbl%intm_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_pbl%intm_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !if (abs (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i)) .gt. tw_err) then
+ ! print*, "PBL-INTM TW: ", &
+ ! !(sum (tw_beg (i, :)) + tw_b_beg (i)), &
+ ! !(sum (tw_end (i, :)) + tw_b_end (i)), &
+ ! (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i))
+ !endif
+ inline_pbl%intm_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_pbl%intm_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
+ !print*, "PBL-INTM LOSS (%) : ", te_loss (i) / (sum (te_beg (i, :)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ deallocate (kinver)
+
+ deallocate (dz)
+ deallocate (zm)
+ deallocate (zi)
+ deallocate (dp)
+ deallocate (pm)
+ deallocate (pi)
+ deallocate (pmk)
+ deallocate (pik)
+
+ deallocate (ta)
+ deallocate (uu)
+ deallocate (vv)
+ deallocate (qa)
+
+ deallocate (radh)
+ deallocate (rb)
+ deallocate (u10m)
+ deallocate (v10m)
+ deallocate (stress)
+ deallocate (wind)
+ deallocate (sigmaf)
+ deallocate (vegtype)
+
+ deallocate (dtsfc)
+ deallocate (dqvsfc)
+ deallocate (dqlsfc)
+ deallocate (dqisfc)
+ deallocate (dqrsfc)
+ deallocate (dqssfc)
+ deallocate (dqgsfc)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ ! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ call timing_on('COMM_TOTAL')
+ 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
+ call timing_off('COMM_TOTAL')
+
+ ! 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)
+
+ ! 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
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Inline Planetary Boundary Layer
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Inline Convection >>>
+ !-----------------------------------------------------------------------
+
+ if ((.not. do_adiabatic_init) .and. do_inline_cnv) then
+
+ allocate (rn (is:ie))
+ allocate (tmp (is:ie))
+
+ allocate (dz (is:ie, 1:km))
+ allocate (zm (is:ie, 1:km))
+ allocate (dp (is:ie, 1:km))
+ allocate (pm (is:ie, 1:km))
+ allocate (pi (is:ie, 1:km+1))
+
+ allocate (ta (is:ie, 1:km))
+ allocate (qv (is:ie, 1:km))
+ allocate (qr (is:ie, 1:km))
+ allocate (uu (is:ie, 1:km))
+ allocate (vv (is:ie, 1:km))
+ allocate (ww (is:ie, 1:km))
+
+ if (inline_cnv_flag .eq. 1) allocate (ql (is:ie, 1:km))
+ if (inline_cnv_flag .eq. 2) allocate (qa (is:ie, 1:km, 1:nq))
+
+ allocate (u_dt (isd:ied, jsd:jed, km))
+ allocate (v_dt (isd:ied, jsd:jed, km))
+
+ allocate (tz (1:km))
+ allocate (wz (1: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, 4, bd)
+
+ ! save delp
+ if (consv .gt. consv_min) then
+ allocate (dp0 (isd:ied, jsd:jed, km))
+ dp0 = delp
+ endif
+
+ if (inline_cnv_flag .eq. 2) then
+ ntchm = 0 ! number of chemical tracers
+ ntchs = get_tracer_index (model_atmos, 'so2') ! tracer index for first chemical tracer
+ if (ntchs .gt. 0) then
+ ntchm = get_tracer_index (model_atmos, 'pp10')
+ if (ntchm .gt. 0) then
+ ntchm = ntchm - ntchs + 1
+ endif
+ endif
+ ! setup aerosol scavenging factors
+ allocate (fscav (ntchm))
+ if (ntchm .gt. 0) then
+ ! initialize to default
+ fscav = 0.6
+ n = get_tracer_index (model_atmos, 'seas1') - ntchs + 1
+ if (n .gt. 0) fscav (n) = 1.0
+ n = get_tracer_index (model_atmos, 'seas2') - ntchs + 1
+ if (n .gt. 0) fscav (n) = 1.0
+ n = get_tracer_index (model_atmos, 'seas3') - ntchs + 1
+ if (n .gt. 0) fscav (n) = 1.0
+ n = get_tracer_index (model_atmos, 'seas4') - ntchs + 1
+ if (n .gt. 0) fscav (n) = 1.0
+ n = get_tracer_index (model_atmos, 'seas5') - ntchs + 1
+ if (n .gt. 0) fscav (n) = 1.0
+ ! read factors from namelist
+ do i = 1, size (fscav_aero)
+ j = index (fscav_aero (i), ":")
+ if (j .gt. 1) then
+ read (fscav_aero (i) (j+1:), *, iostat = ios) tem
+ if (ios .ne. 0) cycle
+ if (adjustl (fscav_aero (i) (:j-1)) .eq. "*") then
+ fscav = tem
+ exit
+ else
+ n = get_tracer_index (model_atmos, adjustl(fscav_aero (i) (:j-1))) - ntchs + 1
+ if (n .gt. 0) fscav (n) = tem
+ endif
+ endif
+ enddo
+ endif
+ endif
+
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, km, ua, va, q_con, w, &
+!$OMP te, delp, hydrostatic, hs, pt, delz, omga, &
+!$OMP rainwat, liq_wat, ice_wat, snowwat, graupel, &
+!$OMP sphum, pkz, consv, te0_2d, gridstruct, q, &
+!$OMP mdt, cappa, rrg, akap, r_vir, inline_cnv, &
+!$OMP u_dt, v_dt, inline_pbl, safety_check, ptop, &
+!$OMP adj_mass_vmr, conv_vmr_mmr, nq, consv_checker, &
+!$OMP te_err, tw_err, inline_cnv_flag, fscav, ntchs, &
+!$OMP ntchm, ntke, nwat, thermostruct) &
+!$OMP private (gsize, dz, pi, rn, tmp, q_liq, q_sol, pe, peln, qa, &
+!$OMP zm, dp, pm, qv, ql, qr, ta, uu, vv, ww, ncld, qliq, qsol, &
+!$OMP cvm, kr, dqv, dql, dqi, dqr, dqs, dqg, ps_dt, c_moist, &
+!$OMP adj_vmr, k1, k2, 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, te8, dte8)
+
+ do j = js, je
+
+ ! grid size
+ gsize (is:ie) = sqrt (gridstruct%area_64 (is:ie, j))
+
+ ! save ua, va for wind tendency calculation
+ u_dt (is:ie, j, 1:km) = ua (is:ie, j, 1:km)
+ v_dt (is:ie, j, 1:km) = va (is:ie, j, 1:km)
+
+ rn = 0.0
+ ncld = 1
+ inline_cnv%ktop (is:ie, j) = 1
+ inline_cnv%kbot (is:ie, j) = km
+ inline_cnv%kcnv (is:ie, j) = 0
+ inline_cnv%cumabs (is:ie, j) = 0
+
+ ! total energy before parameterization
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = - cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_beg (is:ie, 1:km) = 0.0
+ tw_beg (is:ie, 1:km) = 0.0
+ te_b_beg (is:ie) = 0.0
+ tw_b_beg (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, inline_cnv%prec (i, j) / abs (mdt) * 1.e3 * 86400, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_beg (i, 1:km), tw_beg (i, 1: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 index flip over
+ pi (is:ie, 1) = pe (is:ie, km+1)
+ do k = 1, km
+ kr = km - k + 1
+ dp (is:ie, k) = delp (is:ie, j, kr)
+ pi (is:ie, k+1) = pe (is:ie, kr)
+ if (.not. hydrostatic) then
+ pm (is:ie, k) = dp (is:ie, k) / delz (is:ie, j, kr) * &
+ rrg * pt (is:ie, j, kr)
+ dz (is:ie, k) = delz (is:ie, j, kr)
+ ! ensure subgrid monotonicity of pressure
+ do i = is, ie
+ pm (i, k) = min (pm (i, k), pi (i, k) - 0.01 * pm (i, k))
+ pm (i, k) = max (pm (i, k), pi (i, k+1) + 0.01 * pm (i, k))
+ enddo
+ else
+ pm (is:ie, k) = dp (is:ie, k) / (peln (is:ie, kr+1) - peln (is:ie, kr))
+ dz (is:ie, k) = (peln (is:ie, kr+1) - peln (is:ie, kr)) * &
+ rrg * pt (is:ie, j, kr)
+ endif
+ if (k .eq. 1) then
+ zm (is:ie, k) = - 0.5 * dz (is:ie, k) * grav
+ else
+ zm (is:ie, k) = zm (is:ie, k-1) - 0.5 * (dz (is:ie, k-1) + dz (is:ie, k)) * grav
+ endif
+ qv (is:ie, k) = q (is:ie, j, kr, sphum)
+ if (inline_cnv_flag .eq. 1) ql (is:ie, k) = q (is:ie, j, kr, liq_wat)
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ ta (is:ie, k) = pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * &
+ (1. - (q_liq + q_sol)))
+ uu (is:ie, k) = ua (is:ie, j, kr)
+ vv (is:ie, k) = va (is:ie, j, kr)
+ ww (is:ie, k) = omga (is:ie, j, kr)
+ if (inline_cnv_flag .eq. 2) qa (is:ie, k, 1:nq) = q (is:ie, j, kr, 1:nq)
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ te8 (is:ie, k) = (c_moist * ta (is:ie, k) + &
+ (hlv - rvgas * tice - (cv_vap - c_liq) * tice) * q (is:ie, j, kr, sphum) - &
+ (hlf - (c_liq - c_ice) * tice) * q_sol) * delp (is:ie, j, kr) / grav
+ dte8 (is:ie, k) = 0.0
+ enddo
+
+ ! check if pressure or height cross over
+ if (safety_check) then
+ do k = 1, km
+ do i = is, ie
+ if (k .lt. km) then
+ if (pm (i, k) .le. pm (i, k+1)) then
+ print*, "Warning: inline sas pressure layer cross over", k, pm (i, k), pm (i, k+1)
+ endif
+ if (pi (i, k) .le. pi (i, k+1)) then
+ print*, "Warning: inline sas pressure interface cross over", k, pi (i, k), pi (i, k+1)
+ endif
+ if (zm (i, k) .ge. zm (i, k+1)) then
+ print*, "Warning: inline sas height layer cross over", k, zm (i, k), zm (i, k+1)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+
+ if (inline_cnv_flag .eq. 1) &
+ ! SA-SAS deep convection main program
+ call sa_sas_deep (ie-is+1, km, abs (mdt), dp, pm, pi (is:ie, 1), zm, ql, &
+ qv, ta, uu, vv, qr, rn, inline_cnv%kbot (is:ie, j), inline_cnv%ktop (is:ie, j), &
+ inline_cnv%kcnv (is:ie, j), inline_pbl%lsm (is:ie, j), gsize, ww, ncld)
+
+ if (inline_cnv_flag .eq. 2) &
+ ! SA-AAMF deep convection main program
+ call sa_aamf_deep (ie-is+1, km, abs (mdt), ntchs, ntchm, liq_wat, ice_wat, ntke, nq - 2, dp, &
+ pm, pi (is:ie, 1), zm, qa, qv, ta, uu, vv, qr, fscav, rn, inline_cnv%kbot (is:ie, j), &
+ inline_cnv%ktop (is:ie, j), inline_cnv%kcnv (is:ie, j), inline_pbl%lsm (is:ie, j), gsize, ww, ncld)
+
+ ! convective precipitation accumulation
+ inline_cnv%prec (is:ie, j) = inline_cnv%prec (is:ie, j) + rn
+
+ if (inline_cnv_flag .eq. 1) &
+ ! SA-SAS shallow convection main program
+ call sa_sas_shal (ie-is+1, km, abs (mdt), dp, pm, pi (is:ie, 1), zm, ql, &
+ qv, ta, uu, vv, qr, rn, inline_cnv%kbot (is:ie, j), inline_cnv%ktop (is:ie, j), &
+ inline_cnv%kcnv (is:ie, j), inline_pbl%lsm (is:ie, j), gsize, ww, ncld, &
+ inline_pbl%hpbl (is:ie, j))
+
+ if (inline_cnv_flag .eq. 2) &
+ ! SA-AAMF shallow convection main program
+ call sa_aamf_shal (ie-is+1, km, abs (mdt), ntchs, ntchm, liq_wat, ice_wat, ntke, nq - 2, dp, &
+ pm, pi (is:ie, 1), zm, qa, qv, ta, uu, vv, qr, fscav, rn, inline_cnv%kbot (is:ie, j), &
+ inline_cnv%ktop (is:ie, j), inline_cnv%kcnv (is:ie, j), inline_pbl%lsm (is:ie, j), gsize, ww, ncld, &
+ inline_pbl%hpbl (is:ie, j))
+
+ ! convective precipitation accumulation
+ inline_cnv%prec (is:ie, j) = inline_cnv%prec (is:ie, j) + rn
+
+ ! convective heating for convective gravity wave drag parameterization
+ tmp (is:ie) = 0.0
+ do k = 1, km
+ kr = km - k + 1
+ do i = is, ie
+ if (k .ge. inline_cnv%kbot (i, j) .and. k .le. inline_cnv%ktop (i, j)) then
+ inline_cnv%cumabs (i, j) = inline_cnv%cumabs (i, j) + &
+ (ta (i, k) - pt (i, j, kr)) * dp (i, k)
+ tmp (i) = tmp (i) + dp (i, k)
+ endif
+ enddo
+ enddo
+ do i = is, ie
+ if (tmp (i) .gt. 0.0) inline_cnv%cumabs (i, j) = inline_cnv%cumabs (i, j) / (abs (mdt) * tmp (i))
+ enddo
+
+ ! update u, v, T, q, and delp, vertical index flip over
+ do k = 1, km
+ kr = km - k + 1
+ k1 = 0.5 * (ua (is:ie, j, kr) ** 2 + va (is:ie, j, kr) ** 2 + w (is:ie, j, kr) ** 2) * delp (is:ie, j, kr)
+ if (inline_cnv_flag .eq. 1) then
+ dqv = qv (is:ie, k) - q (is:ie, j, kr, sphum)
+ dql = ql (is:ie, k) - q (is:ie, j, kr, liq_wat)
+ ps_dt = 1 + dqv + dql
+ adj_vmr (is:ie, kr) = (ps_dt - (qv (is:ie, k) + ql (is:ie, k) + &
+ q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, rainwat) + &
+ q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel))) / &
+ (1. - (qv (is:ie, k) + ql (is:ie, k) + q (is:ie, j, kr, ice_wat) + &
+ q (is:ie, j, kr, rainwat) + q (is:ie, j, kr, snowwat) + &
+ q (is:ie, j, kr, graupel))) / ps_dt
+ q (is:ie, j, kr, sphum) = qv (is:ie, k) / ps_dt
+ q (is:ie, j, kr, liq_wat) = ql (is:ie, k) / ps_dt
+ q (is:ie, j, kr, ice_wat) = q (is:ie, j, kr, ice_wat) / ps_dt
+ q (is:ie, j, kr, rainwat) = q (is:ie, j, kr, rainwat) / ps_dt
+ q (is:ie, j, kr, snowwat) = q (is:ie, j, kr, snowwat) / ps_dt
+ q (is:ie, j, kr, graupel) = q (is:ie, j, kr, graupel) / ps_dt
+ endif
+ if (inline_cnv_flag .eq. 2) then
+ q (is:ie, j, kr, nwat+1:nq) = qa (is:ie, k, nwat+1:nq)
+ dqv = qv (is:ie, k) - q (is:ie, j, kr, sphum)
+ dql = qa (is:ie, k, liq_wat) - q (is:ie, j, kr, liq_wat)
+ dqi = qa (is:ie, k, ice_wat) - q (is:ie, j, kr, ice_wat)
+ dqr = qa (is:ie, k, rainwat) - q (is:ie, j, kr, rainwat)
+ dqs = qa (is:ie, k, snowwat) - q (is:ie, j, kr, snowwat)
+ dqg = qa (is:ie, k, graupel) - q (is:ie, j, kr, graupel)
+ ps_dt = 1 + dqv + dql + dqi + dqr + dqs + dqg
+ adj_vmr (is:ie, kr) = (ps_dt - (qv (is:ie, k) + &
+ qa (is:ie, k, liq_wat) + qa (is:ie, k, ice_wat) + &
+ qa (is:ie, k, rainwat) + qa (is:ie, k, snowwat) + &
+ qa (is:ie, k, graupel))) / (1. - (qv (is:ie, k) + &
+ qa (is:ie, k, liq_wat) + qa (is:ie, k, ice_wat) + &
+ qa (is:ie, k, rainwat) + qa (is:ie, k, snowwat) + &
+ qa (is:ie, k, graupel))) / ps_dt
+ q (is:ie, j, kr, sphum) = qv (is:ie, k) / ps_dt
+ q (is:ie, j, kr, liq_wat) = qa (is:ie, k, liq_wat) / ps_dt
+ q (is:ie, j, kr, ice_wat) = qa (is:ie, k, ice_wat) / ps_dt
+ q (is:ie, j, kr, rainwat) = qa (is:ie, k, rainwat) / ps_dt
+ q (is:ie, j, kr, snowwat) = qa (is:ie, k, snowwat) / ps_dt
+ q (is:ie, j, kr, graupel) = qa (is:ie, k, graupel) / ps_dt
+ endif
+ delp (is:ie, j, kr) = delp (is:ie, j, kr) * ps_dt
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ if (thermostruct%use_cond) then
+ q_con (is:ie, j, kr) = q_liq + q_sol
+ endif
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ if (thermostruct%moist_kappa) then
+ cappa (is:ie, j, kr) = rdgas / (rdgas + c_moist / (1. + r_vir * q (is:ie, j, kr, sphum)))
+ endif
+ pt (is:ie, j, kr) = pt (is:ie, j, kr) + (ta (is:ie, k) * &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol))) - &
+ pt (is:ie, j, kr)) * cp_air / c_moist
+ dte8 (is:ie, k) = te8 (is:ie, k) - (c_moist * pt (is:ie, j, kr) / &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol))) + &
+ (hlv - rvgas * tice - (cv_vap - c_liq) * tice) * q (is:ie, j, kr, sphum) - &
+ (hlf - (c_liq - c_ice) * tice) * q_sol) * delp (is:ie, j, kr) / grav
+ ua (is:ie, j, kr) = uu (is:ie, k)
+ va (is:ie, j, kr) = vv (is:ie, k)
+ k2 = 0.5 * (ua (is:ie, j, kr) ** 2 + va (is:ie, j, kr) ** 2 + w (is:ie, j, kr) ** 2) * delp (is:ie, j, kr)
+ pt (is:ie, j, kr) = pt (is:ie, j, kr) + (k1 - k2) / c_moist / delp (is:ie, j, kr) * &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol)))
+ enddo
+
+ ! update non-microphyiscs tracers due to mass change
+ if (adj_mass_vmr .gt. 0) then
+ do m = 1, nq
+ if (conv_vmr_mmr (m)) then
+ q (is:ie, j, 1:km, m) = q (is:ie, j, 1:km, m) * adj_vmr (is:ie, 1:km)
+ endif
+ enddo
+ endif
+
+ ! compute wind tendency at A grid fori D grid wind update
+ u_dt (is:ie, j, 1:km) = (ua (is:ie, j, 1:km) - u_dt (is:ie, j, 1:km)) / abs (mdt)
+ v_dt (is:ie, j, 1:km) = (va (is:ie, j, 1:km) - v_dt (is:ie, j, 1:km)) / abs (mdt)
+
+ ! update pkz
+ if (.not. hydrostatic) then
+ if (thermostruct%moist_kappa) then
+ pkz (is:ie, j, 1:km) = exp (cappa (is:ie, j, 1:km) * &
+ log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ else
+ pkz (is:ie, j, 1:km) = exp (akap * log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_end (is:ie, 1:km) = 0.0
+ tw_end (is:ie, 1:km) = 0.0
+ te_b_end (is:ie) = 0.0
+ tw_b_end (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = sum (dte8 (i, 1:km))
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, inline_cnv%prec (i, j) / abs (mdt) * 1.e3 * 86400, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_end (i, 1:km), tw_end (i, 1:km), &
+ te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
+ enddo
+ endif
+
+ ! total energy after parameterization, add total energy change to te0_2d
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = te (is:ie, j, 1:km) + &
+ cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ do k = 1, km
+ te0_2d (is:ie, j) = te0_2d (is:ie, j) + te (is:ie, j, k)
+ enddo
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ do i = is, ie
+ !if (abs (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i)) .gt. te_err) then
+ ! print*, "CNV-INTM TE: ", &
+ ! !(sum (te_beg (i, :)) + te_b_beg (i)), &
+ ! !(sum (te_end (i, :)) + te_b_end (i)), &
+ ! (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i))
+ !endif
+ inline_cnv%intm_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_cnv%intm_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !if (abs (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i)) .gt. tw_err) then
+ ! print*, "CNV-INTM TW: ", &
+ ! !(sum (tw_beg (i, :)) + tw_b_beg (i)), &
+ ! !(sum (tw_end (i, :)) + tw_b_end (i)), &
+ ! (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i))
+ !endif
+ inline_cnv%intm_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_cnv%intm_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
+ !print*, "CNV-INTM LOSS (%) : ", te_loss (i) / (sum (te_beg (i, :)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ if (inline_cnv_flag .eq. 2) then
+ deallocate (fscav)
+ endif
+
+ deallocate (rn)
+ deallocate (tmp)
+
+ deallocate (dz)
+ deallocate (zm)
+ deallocate (dp)
+ deallocate (pm)
+ deallocate (pi)
+
+ deallocate (ta)
+ deallocate (qv)
+ deallocate (qr)
+ deallocate (uu)
+ deallocate (vv)
+ deallocate (ww)
+
+ if (inline_cnv_flag .eq. 1) deallocate (ql)
+ if (inline_cnv_flag .eq. 2) deallocate (qa)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ ! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ call timing_on('COMM_TOTAL')
+ 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
+ call timing_off('COMM_TOTAL')
+
+ ! 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)
+
+ ! 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
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Inline Convection
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Inline Gravity Wave Drag >>>
+ !-----------------------------------------------------------------------
+
+ if ((.not. do_adiabatic_init) .and. do_inline_gwd) then
+
+ allocate (dz (is:ie, 1:km))
+ allocate (zm (is:ie, 1:km))
+ allocate (zi (is:ie, 1:km+1))
+ allocate (dp (is:ie, 1:km))
+ allocate (pm (is:ie, 1:km))
+ allocate (pi (is:ie, 1:km+1))
+ allocate (pmk (is:ie, 1:km))
+
+ allocate (ta (is:ie, 1:km))
+ allocate (qv (is:ie, 1:km))
+ allocate (uu (is:ie, 1:km))
+ allocate (vv (is:ie, 1:km))
+
+ allocate (u_dt (isd:ied, jsd:jed, km))
+ allocate (v_dt (isd:ied, jsd:jed, km))
+
+ allocate (tz (1:km))
+ allocate (wz (1: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, 4, bd)
+
+ ! save delp
+ if (consv .gt. consv_min) then
+ allocate (dp0 (isd:ied, jsd:jed, km))
+ dp0 = delp
+ endif
+
+!$OMP parallel do default (none) shared (is, ie, js, je, isd, jsd, km, ua, va, w, &
+!$OMP te, delp, hydrostatic, pt, delz, q_con, &
+!$OMP rainwat, liq_wat, ice_wat, snowwat, graupel, &
+!$OMP sphum, pkz, consv, te0_2d, gridstruct, q, &
+!$OMP mdt, cappa, rrg, akap, r_vir, inline_gwd, &
+!$OMP ptop, inline_pbl, inline_cnv, u_dt, v_dt, &
+!$OMP safety_check, do_fast_phys, &
+!$OMP conv_vmr_mmr, nq, consv_checker, &
+!$OMP te_err, tw_err, thermostruct) &
+!$OMP private (gsize, dz, pi, pmk, zi, q_liq, q_sol, pe, &
+!$OMP zm, dp, pm, qv, ta, uu, vv, qliq, qsol, &
+!$OMP cvm, kr, c_moist, peln, &
+!$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))
+
+ ! save ua, va for wind tendency calculation
+ u_dt (is:ie, j, 1:km) = ua (is:ie, j, 1:km)
+ v_dt (is:ie, j, 1:km) = va (is:ie, j, 1:km)
+
+ ! total energy before parameterization
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = - cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_beg (is:ie, 1:km) = 0.0
+ tw_beg (is:ie, 1:km) = 0.0
+ te_b_beg (is:ie) = 0.0
+ tw_b_beg (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_beg (i, 1:km), tw_beg (i, 1: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 index flip over
+ zi (is:ie, 1) = 0.0
+ pi (is:ie, 1) = pe (is:ie, km+1)
+ do k = 1, km
+ kr = km - k + 1
+ dp (is:ie, k) = delp (is:ie, j, kr)
+ pi (is:ie, k+1) = pe (is:ie, kr)
+ if (.not. hydrostatic) then
+ pm (is:ie, k) = dp (is:ie, k) / delz (is:ie, j, kr) * &
+ rrg * pt (is:ie, j, kr)
+ dz (is:ie, k) = delz (is:ie, j, kr)
+ ! ensure subgrid monotonicity of pressure
+ do i = is, ie
+ pm (i, k) = min (pm (i, k), pi (i, k) - 0.01 * pm (i, k))
+ pm (i, k) = max (pm (i, k), pi (i, k+1) + 0.01 * pm (i, k))
+ enddo
+ else
+ pm (is:ie, k) = dp (is:ie, k) / (peln (is:ie, kr+1) - peln (is:ie, kr))
+ dz (is:ie, k) = (peln (is:ie, kr+1) - peln (is:ie, kr)) * &
+ rrg * pt (is:ie, j, kr)
+ endif
+ pmk (is:ie, k) = exp (kappa * log (pm (is:ie, k) * 1.e-5))
+ zi (is:ie, k+1) = zi (is:ie, k) - dz (is:ie, k) * grav
+ if (k .eq. 1) then
+ zm (is:ie, k) = - 0.5 * dz (is:ie, k) * grav
+ else
+ zm (is:ie, k) = zm (is:ie, k-1) - 0.5 * (dz (is:ie, k-1) + dz (is:ie, k)) * grav
+ endif
+ qv (is:ie, k) = q (is:ie, j, kr, sphum)
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ ta (is:ie, k) = pt (is:ie, j, kr) / ((1. + r_vir * q (is:ie, j, kr, sphum)) * &
+ (1. - (q_liq + q_sol)))
+ uu (is:ie, k) = ua (is:ie, j, kr)
+ vv (is:ie, k) = va (is:ie, j, kr)
+ enddo
+
+ ! check if pressure or height cross over
+ if (safety_check) then
+ do k = 1, km
+ do i = is, ie
+ if (k .lt. km) then
+ if (pm (i, k) .le. pm (i, k+1)) then
+ print*, "Warning: inline gwd pressure layer cross over", k, pm (i, k), pm (i, k+1)
+ endif
+ if (zm (i, k) .ge. zm (i, k+1)) then
+ print*, "Warning: inline gwd height layer cross over", k, zm (i, k), zm (i, k+1)
+ endif
+ endif
+ if (pi (i, k) .le. pi (i, k+1)) then
+ print*, "Warning: inline gwd pressure interface cross over", k, pi (i, k), pi (i, k+1)
+ endif
+ if (zi (i, k) .ge. zi (i, k+1)) then
+ print*, "Warning: inline gwd height interface cross over", k, zi (i, k), zi (i, k+1)
+ endif
+ enddo
+ enddo
+ endif
+
+ if (.not. do_fast_phys) then
+
+ ! orographic gravity wave drag and mountain blocking main program
+ call sa_gwd_oro (ie-is+1, km, uu, vv, ta, qv, abs (mdt), gsize, &
+ inline_pbl%kpbl (is:ie, j), pi, dp, pm, pmk, zi, zm, &
+ inline_gwd%hprime (is:ie, j), inline_gwd%oc (is:ie, j), inline_gwd%oa (is:ie, j, :), &
+ inline_gwd%ol (is:ie, j, :), inline_gwd%theta (is:ie, j), inline_gwd%sigma (is:ie, j), &
+ inline_gwd%gamma (is:ie, j), inline_gwd%elvmax (is:ie, j))
+
+ endif
+
+ ! convective gravity wave drag main program
+ call sa_gwd_cnv (ie-is+1, km, uu, vv, ta, qv, abs (mdt), gsize, inline_cnv%cumabs (is:ie, j), &
+ pm, pi, dp, inline_cnv%ktop (is:ie, j), inline_cnv%kbot (is:ie, j), inline_cnv%kcnv (is:ie, j))
+
+ ! update u, v, T, q, and delp, vertical index flip over
+ do k = 1, km
+ kr = km - k + 1
+ q_liq = q (is:ie, j, kr, liq_wat) + q (is:ie, j, kr, rainwat)
+ q_sol = q (is:ie, j, kr, ice_wat) + q (is:ie, j, kr, snowwat) + q (is:ie, j, kr, graupel)
+ if (thermostruct%use_cond) then
+ q_con (is:ie, j, kr) = q_liq + q_sol
+ endif
+ c_moist = (1 - (q (is:ie, j, kr, sphum) + q_liq + q_sol)) * cv_air + &
+ q (is:ie, j, kr, sphum) * cv_vap + q_liq * c_liq + q_sol * c_ice
+ if (thermostruct%moist_kappa) then
+ cappa (is:ie, j, kr) = rdgas / (rdgas + c_moist / (1. + r_vir * q (is:ie, j, kr, sphum)))
+ endif
+ pt (is:ie, j, kr) = pt (is:ie, j, kr) + (ta (is:ie, k) * &
+ ((1. + r_vir * q (is:ie, j, kr, sphum)) * (1. - (q_liq + q_sol))) - &
+ pt (is:ie, j, kr)) * cp_air / c_moist
+ ua (is:ie, j, kr) = uu (is:ie, k)
+ va (is:ie, j, kr) = vv (is:ie, k)
+ enddo
+
+ ! compute wind tendency at A grid fori D grid wind update
+ u_dt (is:ie, j, 1:km) = (ua (is:ie, j, 1:km) - u_dt (is:ie, j, 1:km)) / abs (mdt)
+ v_dt (is:ie, j, 1:km) = (va (is:ie, j, 1:km) - v_dt (is:ie, j, 1:km)) / abs (mdt)
+
+ ! update pkz
+ if (.not. hydrostatic) then
+ if (thermostruct%moist_kappa) then
+ pkz (is:ie, j, 1:km) = exp (cappa (is:ie, j, 1:km) * &
+ log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ else
+ pkz (is:ie, j, 1:km) = exp (akap * log (rrg * delp (is:ie, j, 1:km) / &
+ delz (is:ie, j, 1:km) * pt (is:ie, j, 1:km)))
+ endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ te_end (is:ie, 1:km) = 0.0
+ tw_end (is:ie, 1:km) = 0.0
+ te_b_end (is:ie) = 0.0
+ tw_b_end (is:ie) = 0.0
+ do i = is, ie
+ tz = pt (i, j, 1:km) / ((1. + r_vir * q (i, j, 1:km, sphum)) * (1. - (qliq (i, 1:km) + qsol (i, 1:km))))
+ if (hydrostatic) then
+ wz = 0.0
+ else
+ wz = w (i, j, 1:km)
+ endif
+ dte (i) = 0.0
+ call mtetw (1, km, q (i, j, 1:km, sphum), q (i, j, 1:km, liq_wat), &
+ q (i, j, 1:km, rainwat), q (i, j, 1:km, ice_wat), q (i, j, 1:km, snowwat), &
+ q (i, j, 1:km, graupel), tz, ua (i, j, 1:km), va (i, j, 1:km), wz, &
+ delp (i, j, 1:km), dte (i), 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, abs (mdt), te_end (i, 1:km), tw_end (i, 1:km), &
+ te_b_end (i), tw_b_end (i), .true., hydrostatic, te_loss (i))
+ enddo
+ endif
+
+ ! total energy after parameterization, add total energy change to te0_2d
+ if (consv .gt. consv_min) then
+ qliq = q (is:ie, j, 1:km, liq_wat) + q (is:ie, j, 1:km, rainwat)
+ qsol = q (is:ie, j, 1:km, ice_wat) + q (is:ie, j, 1:km, snowwat) + q (is:ie, j, 1:km, graupel)
+ cvm = (1 - (q (is:ie, j, 1:km, sphum) + qliq + qsol)) * cv_air + &
+ q (is:ie, j, 1:km, sphum) * cv_vap + qliq * c_liq + qsol * c_ice
+ te (is:ie, j, 1:km) = te (is:ie, j, 1:km) + &
+ cvm * pt (is:ie, j, 1:km) / ((1. + r_vir * q (is:ie, j, 1:km, sphum)) * &
+ (1. - (qliq + qsol))) * delp (is:ie, j, 1:km)
+ do k = 1, km
+ te0_2d (is:ie, j) = te0_2d (is:ie, j) + te (is:ie, j, k)
+ enddo
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ do i = is, ie
+ !if (abs (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i)) .gt. te_err) then
+ ! print*, "GWD-INTM TE: ", &
+ ! !(sum (te_beg (i, :)) + te_b_beg (i)), &
+ ! !(sum (te_end (i, :)) + te_b_end (i)), &
+ ! (sum (te_end (i, :)) + te_b_end (i) - sum (te_beg (i, :)) - te_b_beg (i)) / &
+ ! (sum (te_beg (i, :)) + te_b_beg (i))
+ !endif
+ inline_gwd%intm_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_gwd%intm_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !if (abs (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i)) .gt. tw_err) then
+ ! print*, "GWD-INTM TW: ", &
+ ! !(sum (tw_beg (i, :)) + tw_b_beg (i)), &
+ ! !(sum (tw_end (i, :)) + tw_b_end (i)), &
+ ! (sum (tw_end (i, :)) + tw_b_end (i) - sum (tw_beg (i, :)) - tw_b_beg (i)) / &
+ ! (sum (tw_beg (i, :)) + tw_b_beg (i))
+ !endif
+ inline_gwd%intm_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_gwd%intm_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
+ !print*, "GWD-INTM LOSS (%) : ", te_loss (i) / (sum (te_beg (i, :)) + te_b_beg (i)) * 100.0
+ enddo
+ endif
+
+ enddo
+
+ deallocate (dz)
+ deallocate (zm)
+ deallocate (dp)
+ deallocate (pm)
+ deallocate (pi)
+ deallocate (pmk)
+
+ deallocate (ta)
+ deallocate (qv)
+ deallocate (uu)
+ deallocate (vv)
+
+ deallocate (tz)
+ deallocate (wz)
+
+ ! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ call timing_on('COMM_TOTAL')
+ 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
+ call timing_off('COMM_TOTAL')
+
+ ! 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)
+
+ ! 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
+
+ endif
+
+ !-----------------------------------------------------------------------
+ ! <<< Inline Gravity Wave Drag
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Inline Microphysics >>>
+ !-----------------------------------------------------------------------
+
+ if ((.not. do_adiabatic_init) .and. do_inline_mp .and. nwat .eq. 6) then
+
+ 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, 4, 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, k_con, k_cappa, thermostruct) &
+!$OMP private (q2, q3, gsize, dz, wa, pe, peln, adj_vmr, qliq, qsol, &
+!$OMP tz, wz, dte, te_beg, tw_beg, te_b_beg, tw_b_beg, &
+!$OMP te_end, tw_end, te_b_end, tw_b_end, te_loss)
+
+ 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
+
+ ! 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), 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, &
+ q_con (is:ie, j, k_con:), cappa (is:ie, j, k_cappa:), &
+ consv .gt. consv_min, adj_vmr (is:ie, kmp:km), te (is:ie, j, kmp:km), dte (is:ie), &
+ inline_mp%prefluxw(is:ie, j, kmp:km), &
+ inline_mp%prefluxr(is:ie, j, kmp:km), inline_mp%prefluxi(is:ie, j, kmp:km), &
+ inline_mp%prefluxs(is:ie, j, kmp:km), inline_mp%prefluxg(is:ie, j, kmp:km), &
+ inline_mp%mppcw (is:ie, j), inline_mp%mppew (is:ie, j), inline_mp%mppe1 (is:ie, j), &
+ inline_mp%mpper (is:ie, j), inline_mp%mppdi (is:ie, j), inline_mp%mppd1 (is:ie, j), &
+ inline_mp%mppds (is:ie, j), inline_mp%mppdg (is:ie, j), inline_mp%mppsi (is:ie, j), &
+ inline_mp%mpps1 (is:ie, j), inline_mp%mppss (is:ie, j), inline_mp%mppsg (is:ie, j), &
+ inline_mp%mppfw (is:ie, j), inline_mp%mppfr (is:ie, j), inline_mp%mppmi (is:ie, j), &
+ inline_mp%mppms (is:ie, j), inline_mp%mppmg (is:ie, j), inline_mp%mppm1 (is:ie, j), &
+ inline_mp%mppm2 (is:ie, j), inline_mp%mppm3 (is:ie, j), inline_mp%mppar (is:ie, j), &
+ inline_mp%mppas (is:ie, j), inline_mp%mppag (is:ie, j), inline_mp%mpprs (is:ie, j), &
+ inline_mp%mpprg (is:ie, j), inline_mp%mppxr (is:ie, j), inline_mp%mppxs (is:ie, j), &
+ inline_mp%mppxg (is:ie, j), last_step, do_inline_mp, &
+ thermostruct%use_cond, thermostruct%moist_kappa)
+
+ ! update non-microphyiscs tracers due to mass change
+ if (adj_mass_vmr .gt. 0) then
+ 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
+ if (thermostruct%moist_kappa) then
+ pkz (is:ie, j, kmp:km) = exp (cappa (is:ie, j, kmp:km) * &
+ log (rrg * delp (is:ie, j, kmp:km) / &
+ delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
+ else
+ pkz (is:ie, j, kmp:km) = exp (akap * log (rrg * delp (is:ie, j, kmp:km) / &
+ delz (is:ie, j, kmp:km) * pt (is:ie, j, kmp:km)))
+ endif
+ endif
+
+ ! total energy checker
+ if (consv_checker) then
+ qliq (is:ie, kmp:km) = q (is:ie, j, kmp:km, liq_wat) + q (is:ie, j, kmp:km, rainwat)
+ 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), 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*, "MP-INTM TE: ", &
+ ! !(sum (te_beg (i, kmp:km)) + te_b_beg (i)), &
+ ! !(sum (te_end (i, kmp:km)) + te_b_end (i)), &
+ ! (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
+ inline_mp%intm_te_a_chg (i, j) = sum (te_end (i, :)) - sum (te_beg (i, :))
+ inline_mp%intm_te_b_chg (i, j) = te_b_end (i) - te_b_beg (i)
+ !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*, "MP-INTM TW: ", &
+ ! !(sum (tw_beg (i, kmp:km)) + tw_b_beg (i)), &
+ ! !(sum (tw_end (i, kmp:km)) + tw_b_end (i)), &
+ ! (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
+ inline_mp%intm_tw_a_chg (i, j) = sum (tw_end (i, :)) - sum (tw_beg (i, :))
+ inline_mp%intm_tw_b_chg (i, j) = tw_b_end (i) - tw_b_beg (i)
+ !print*, "MP-INTM LOSS (%) : ", te_loss (i) / (sum (te_beg (i, kmp:km)) + te_b_beg (i)) * 100.0
enddo
endif
@@ -731,6 +2276,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
deallocate (wa)
! Note: (ua, va) are *lat-lon* wind tendenies on cell centers
+ call timing_on('COMM_TOTAL')
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.)
@@ -738,6 +2284,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
call mpp_update_domains (u_dt, domain, complete=.false.)
call mpp_update_domains (v_dt, domain, complete=.true.)
endif
+ call timing_off('COMM_TOTAL')
! update D grid wind
call update_dwinds_phys (is, ie, js, je, isd, ied, jsd, jed, abs (mdt), u_dt, v_dt, u, v, &
@@ -806,7 +2353,7 @@ subroutine intermediate_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy,
endif
!-----------------------------------------------------------------------
- ! <<< Inline GFDL MP
+ ! <<< Inline Microphysics
!-----------------------------------------------------------------------
end subroutine intermediate_phys
diff --git a/model/sa_aamf.F90 b/model/sa_aamf.F90
new file mode 100644
index 000000000..200158fa4
--- /dev/null
+++ b/model/sa_aamf.F90
@@ -0,0 +1,6498 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! Scale-Aware Aerosol-Aware Mass-Flux (SA-AAMP) Convection Scheme
+! This code was originally from GFSv16. It was later rewritten as an inline scheme.
+! Developers: Jongil Han, Linjiong Zhou, and the GFDL FV3 Team
+! References: Han and Pan (2011), Han et al. (2017), Han and Bretherton (2019)
+! =======================================================================
+
+module sa_aamf_mod
+
+ use fms_mod, only: check_nml_error
+ use gfdl_mp_mod, only: mqs
+
+ implicit none
+
+ private
+
+ ! -----------------------------------------------------------------------
+ ! public subroutines, functions, and variables
+ ! -----------------------------------------------------------------------
+
+ public :: sa_aamf_init
+ public :: sa_aamf_deep
+ public :: sa_aamf_shal
+
+ ! -----------------------------------------------------------------------
+ ! physics constants
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), 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 :: 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 :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS
+ real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K)
+
+ real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS
+
+ real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS
+
+ real, parameter :: qcmin = 1.0e-15 ! min value for cloud condensates (kg/kg)
+
+ ! -----------------------------------------------------------------------
+ ! namelist parameters
+ ! -----------------------------------------------------------------------
+
+ ! mass flux deep convection
+
+ real :: clam_deep = 0.1 ! c_e for deep convection (Han and Pan, 2011, eq(6))
+ real :: c0s_deep = 0.002 ! conversion parameter of detrainment from liquid water into convetive precipitaiton
+ real :: c1_deep = 0.002 ! conversion parameter of detrainment from liquid water into grid-scale cloud water
+ real :: pgcon_deep = 0.55 ! control the reduction in momentum transport
+ ! 0.7 : Gregory et al. (1997, QJRMS)
+ ! 0.55: Zhang & Wu (2003, JAS)
+ real :: asolfac_deep = 0.89 ! aerosol-aware parameter based on Lim & Hong (2012)
+ ! asolfac_deep= cx / c0s_deep(=.002)
+ ! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s_deep)
+ ! Nccn: CCN number concentration in cm^(-3)
+ ! Until a realistic Nccn is provided, typical Nccns are assumed
+ ! as Nccn=100 for sea and Nccn=7000 for land
+ real :: evfact_deep = 0.3 ! evaporation factor
+ real :: evfactl_deep = 0.3 ! evaporation factor over land
+ real :: betal_deep = 0.05 ! downdraft heat flux contribution over land
+ real :: betas_deep = 0.05 ! downdraft heat flux contribution over ocean
+ real :: dxcrtas_deep = 8.e3 ! the threshold value (unit: m) for the quasi-equilibrium assumption of Arakawa-Schubert
+ real :: cthk_deep = 200. ! min cloud top for deep convection
+ real :: betaw_deep = 0.03 ! ratio between cloud base mass flux and mean updraft (eq 6 in Han et al 2017)
+
+ ! mass flux shallow convection
+
+ real :: clam_shal = 0.3 ! c_e for shallow convection (Han and Pan, 2011, eq(6))
+ real :: c0s_shal = 0.002 ! conversion parameter of detrainment from liquid water into convetive precipitaiton
+ real :: c1_shal = 5.e-4 ! conversion parameter of detrainment from liquid water into grid-scale cloud water
+ real :: pgcon_shal = 0.55 ! control the reduction in momentum transport
+ ! 0.7 : Gregory et al. (1997, QJRMS)
+ ! 0.55: Zhang & Wu (2003, JAS)
+ real :: asolfac_shal = 0.89 ! aerosol-aware parameter based on Lim & Hong (2012)
+ ! asolfac_shal= cx / c0s_shal(=.002)
+ ! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s_shal)
+ ! Nccn: CCN number concentration in cm^(-3)
+ ! Until a realistic Nccn is provided, typical Nccns are assumed
+ ! as Nccn=100 for sea and Nccn=7000 for land
+ real :: evfact_shal = 0.3 ! rain evaporation efficiency over the ocean
+ real :: evfactl_shal = 0.3 ! rain evaporation efficiency over the land
+ real :: cthk_shal = 200. ! max cloud top for shallow convection
+ real :: top_shal = 0.7 ! max cloud height for shallow convection (P/Ps < top_shal)
+ real :: betaw_shal = 0.03 ! ratio between cloud base mass flux and mean updraft (eq 6 in Han et al 2017)
+ real :: dxcrt_shal = 15.e3 ! critical resolution for calculating scale-aware cloud base mass flux
+
+ ! for both convections
+
+ logical :: use_tke_conv = .false. ! flag for adjusting entrainment/detrainment rates in conv
+ logical :: use_shear_conv = .false. ! flag for considering shear effect for wu/wd in conv
+ logical :: limit_shal_conv = .false. ! flag for constraining shal conv based on diagnosed cloud depth/top
+
+
+ ! -----------------------------------------------------------------------
+ ! namelist
+ ! -----------------------------------------------------------------------
+
+ namelist / sa_aamf_nml / &
+ clam_deep, c0s_deep, c1_deep, pgcon_deep, asolfac_deep, evfact_deep, evfactl_deep, &
+ betal_deep, betas_deep, dxcrtas_deep, cthk_deep, betaw_deep, clam_shal, c0s_shal, &
+ c1_shal, pgcon_shal, asolfac_shal, evfact_shal, evfactl_shal, cthk_shal, top_shal, &
+ betaw_shal, dxcrt_shal, use_tke_conv, use_shear_conv, limit_shal_conv
+
+contains
+
+! =======================================================================
+! SAMP initialization
+! =======================================================================
+
+subroutine sa_aamf_init (input_nml_file, logunit)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: logunit
+
+ character (len = *), intent (in) :: input_nml_file (:)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: ios, ierr
+
+ ! -----------------------------------------------------------------------
+ ! read namelist
+ ! -----------------------------------------------------------------------
+
+ read (input_nml_file, nml = sa_aamf_nml, iostat = ios)
+ ierr = check_nml_error (ios, 'sa_aamf_nml')
+
+ ! -----------------------------------------------------------------------
+ ! write namelist to log file
+ ! -----------------------------------------------------------------------
+
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "sa_aamf_mod"
+ write (logunit, nml = sa_aamf_nml)
+
+end subroutine sa_aamf_init
+
+! =======================================================================
+! Scale-Aware Aerosol-Aware Mass-Flux Deep Convection
+
+! The Scale-Aware Mass-Flux (SAMF) deep convection scheme is an updated version of the previous
+! Simplified Arakawa-Schubert (SAS) scheme with scale and aerosol awareness and parameterizes the
+! effect of deep convection on the environment (represented by the model state variables) in the
+! following way.
+!
+! First, a simple cloud model is used to determine the change in model state variables due to one
+! entraining/detraining cloud type, per unit cloud-base mass flux. Next, the total change in state
+! variables is retrieved by determining the actual cloud base mass flux using the quasi-equilibrium
+! assumption (for grid sizes larger than a threshold value [currently set to 8 km]) or a mean
+! updraft velocity (for grid sizes smaller than the threshold value). With a scale-aware
+! parameterization, the cloud mass flux decreases with increasing grid resolution. A simple
+! aerosol-aware parameterization is employed, where rain conversion in the convective updraft is
+! modified by aerosol number concentration. The name SAS is replaced with SAMF as for the smaller
+! grid sizes, the parameterization does not use Arakawa-Schubert's quasi-equilibrium assumption any
+! longer where the cloud work function (interpreted as entrainment-moderated Convective Available
+! Potential Energy [CAPE]) by the large scale dynamics is in balance with the consumption of the
+! cloud work function by the convection.
+!
+! The SAS scheme uses the working concepts put forth in Arakawa and Schubert (1974) but includes
+! modifications and simplifications from Grell (1993) such as saturated downdrafts and only one
+! cloud type (the deepest possible), rather than a spectrum based on cloud top heights or assumed
+! entrainment rates. The scheme was implemented for the GFS in 1995 by Pan and Wu, with further
+! modifications discussed in Han and Pan (2011), including the calculation of cloud top, a greater
+! CFL-criterion-based maximum cloud base mass flux, updated cloud model entrainment and detrainment,
+! improved convective transport of horizontal momentum, a more general triggering function, and
+! the inclusion of convective overshooting.
+!
+! The SAMF scheme updates the SAS scheme with scale- and aerosol-aware parameterizations from
+! Han et al. (2017) based on the studies by Arakawa and Wu (2013) and Grell and Freitas (2014) for
+! scale awareness and by Lim (2011) for aerosol awareness. The ratio of advective time to
+! convective turnover time is also taken into account for the scale-aware parameterization.
+! Along with the scale- and aerosol-aware parameterizations, more changes are made to the SAMF
+! scheme. The cloud base mass-flux computation is modified to use convective turnover time as the
+! convective adjustment time scale. The rain conversion rate is modified to decrease with
+! decreasing air temperature above the freezing level. Convective inhibition in the sub-cloud layer
+! is used as an additional trigger condition. Convective cloudiness is enhanced by considering
+! suspended cloud condensate in the updraft. The lateral entrainment is also enhanced to more
+! strongly suppress convection in a drier environment.
+!
+! In further update for FY19 GFS implementation, interaction with Turbulent Kinetic Energy (TKE),
+! which is a prognostic variable used in a scale-aware TKE-based moist EDMF vertical turbulent
+! mixing scheme, is included. Entrainment rates in updrafts and downdrafts are proportional to sub-
+! cloud mean TKE. TKE is transported by cumulus convection. TKE contribution from cumulus
+! convection is deduced from cumulus mass flux. On the other hand, tracers such as ozone and
+! aerosol are also transported by cumulus convection.
+!
+! Occasional model crashes have been occurred when stochastic physics is on, due to too much
+! convective cooling and heating tendencies near the cumulus top which are amplified by stochastic
+! physics. To reduce too much convective cooling at the cloud top, the convection schemes have been
+! modified for the rain conversion rate, entrainment and detrainment rates, overshooting layers,
+! and maximum allowable cloudbase mass flux (as of JUNE 2018) .
+!
+! For grid sizes larger than threshold value, as in Grell (1993) , the SAMF deep convection scheme
+! can be described in terms of three types of "controls": static, dynamic, and feedback. The static
+! control component consists of the simple entraining/detraining updraft/downdraft cloud model and
+! is used to determine the cloud properties, convective precipitation, as well as the convective
+! cloud top height. The dynamic control is the determination of the potential energy available for
+! convection to "consume", or how primed the large-scale environment is for convection to occur due
+! to changes by the dyanmics of the host model. The feedback control is the determination of how the
+! parameterized convection changes the large-scale environment (the host model state variables)
+! given the changes to the state variables per unit cloud base mass flux calculated in the static
+! control portion and the deduced cloud base mass flux determined from the dynamic control.
+!
+! For grid sizes smaller than threshold value, the cloud base mass flux in the SAMF scheme is
+! determined by the cumulus updraft velocity averaged ove the whole cloud depth (Han et al., 2017),
+! which in turn, determines changes of the large-scale environment due to the cumulus convection.
+!
+! \param[in] IM number of used points
+! \param[in] KM vertical layer dimension
+! \param[in] DELT physics time step in seconds
+! \param[in] NTK index for tke
+! \param[in] NTR total number of tracers including tke
+! \param[in] DELP pressure difference between level k and k + 1 (pa)
+! \param[in] PRSLP mean layer presure (pa)
+! \param[in] PSP surface pressure (pa)
+! \param[in] PHIL layer geopotential (\f$m^2 / s^2\f$)
+! \param[in] QTR tracer array including cloud condensate (\f$kg / kg\f$)
+! \param[inout] QL cloud water or ice (kg / kg)
+! \param[inout] Q1 updated tracers (kg / kg)
+! \param[inout] T1 updated temperature (k)
+! \param[inout] U1 updated zonal wind (\f$m s^{ - 1}\f$)
+! \param[inout] V1 updated meridional wind (\f$m s^{ - 1}\f$)
+! \param[out] RN convective rain (m)
+! \param[out] KBOT index for cloud base
+! \param[out] KTOP index for cloud top
+! \param[out] KCNV flag to denote deep convection (0 = no, 1 = yes)
+! \param[in] ISLIMSK sea / land / ice mask (= 0 / 1 / 2)
+! \param[in] GSIZE size of grid box (\f$m\f$)
+! \param[in] DOT layer mean vertical velocity (pa / s)
+! \param[in] NCLOUD number of cloud species
+! \param[out] UD_MF updraft mass flux multiplied by time step (\f$kg / m^2\f$)
+! \param[out] DD_MF downdraft mass flux multiplied by time step (\f$kg / m^2\f$)
+! \param[out] DT_MF ud_mf at cloud top (\f$kg / m^2\f$)
+! \param[out] CNVW convective cloud water (kg / kg)
+! \param[out] CNVC convective cloud cover (unitless)
+!
+! General Algorithm
+! # Compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm.
+! # Perform calculations related to the updraft of the entraining/detraining cloud model ("static control") .
+! # Perform calculations related to the downdraft of the entraining/detraining cloud model ("static control") .
+!
+! # For grid sizes larger than the threshold value (currently 8 km) :
+! 1) Using the updated temperature and moisture profiles that were modified by the convection on a short time-scale,
+! recalculate the total cloud work function to determine the change in the cloud work function due to convection,
+! or the stabilizing effect of the cumulus.
+! 2) For the "dynamic control", using a reference cloud work function, estimate the change in cloud work function
+! due to the large-scale dynamics. following the quasi-equilibrium assumption, calculate the cloud base mass flux
+! required to keep the large-scale convective destabilization in balance with the stabilization effect of the convection.
+!
+! # For grid sizes smaller than the threshold value (currently 8 km) :
+! 1) Compute the cloud base mass flux using the cumulus updraft velocity averaged ove the whole cloud depth.
+! # For scale awareness, the updraft fraction (sigma) is obtained as a function of cloud base entrainment.
+! Then, the final cloud base mass flux is obtained by the original mass flux multiplied by the (1sigma) 2
+! # For the "feedback control", calculate updated values of the state variables by multiplying the cloud base
+! mass flux and the tendencies calculated per unit cloud base mass flux from the static control.
+! =======================================================================
+
+subroutine sa_aamf_deep (im, km, delt, itc, ntc, ntw, nti, ntk, ntr, delp, &
+ prslp, psp, phil, qtr, q1, t1, u1, v1, qr, fscav, rn, kbot, ktop, &
+ kcnv, islimsk, gsize, dot, ncloud, ud_mf, dd_mf, dt_mf, cnvw, cnvc)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, itc, ntc, ntw, nti, ntk, ntr, ncloud, islimsk (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: psp (im), delp (im, km), &
+ prslp (im, km), gsize (im), dot (im, km), phil (im, km)
+ real, intent (in) :: fscav (ntc)
+
+ integer, intent (inout) :: kcnv (im)
+
+ real, intent (inout) :: qtr (im, km, ntr + 2), &
+ q1 (im, km), t1 (im, km), u1 (im, km), v1 (im, km)
+
+ integer, intent (out) :: kbot (im), ktop (im)
+
+ real, intent (out) :: rn (im), qr (im, km)
+ real, intent (out), optional :: cnvw (im, km), cnvc (im, km), &
+ ud_mf (im, km), dd_mf (im, km), dt_mf (im, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, indx, jmn, k, kk, km1, n
+
+ real :: clamd, tkemx, tkemn, dtke, &
+ dbeta, betamx, betamn, &
+ cxlame, cxlamd, &
+ xlamde, xlamdd, &
+ crtlame, crtlamd
+
+ ! real :: detad
+
+ real :: adw, aup, aafac, beta, d0, &
+ dellat, delta, desdt, dg, &
+ dh, dhh, dp, &
+ dq, dqsdp, dqsdt, dt, &
+ dt2, dtmax, dtmin, &
+ dxcrtuf, &
+ dv1h, dv2h, dv3h, &
+ dv1q, dv2q, dv3q, &
+ dz, dz1, e1, edtmax, &
+ edtmaxl, edtmaxs, el2orc, elocp, &
+ es, etah, &
+ dthk, &
+ evef, fact1, &
+ fact2, factor, &
+ g, gamma, pprime, cm, &
+ qlk, qrch, qs, &
+ rain, rfact, shear, tfac, &
+ val, val1, val2, &
+ w1, w1l, w1s, w2, &
+ w2l, w2s, w3, w3l, &
+ w3s, w4, w4l, w4s, &
+ rho, &
+ xdby, xpw, xpwd, &
+ xqrch, tem, tem1, tem2, &
+ ptem, ptem1, ptem2
+
+ integer :: kb (im), kbcon (im), kbcon1 (im), &
+ ktcon (im), ktcon1 (im), ktconn (im), &
+ jmin (im), lmin (im), kbmax (im), &
+ kbm (im), kmax (im)
+
+ ! real :: acrt (im), acrtfct (im),
+
+ real :: aa1 (im), tkemean (im), clamt (im), &
+ umean (im), tauadv (im), &
+ delhbar (im), delq (im), delq2 (im), &
+ delqbar (im), delqev (im), deltbar (im), &
+ deltv (im), dtconv (im), edt (im), &
+ edto (im), edtx (im), fld (im), &
+ hcdo (im, km), hmax (im), hmin (im), &
+ ucdo (im, km), vcdo (im, km), aa2 (im), &
+ ecdo (im, km, ntr), &
+ pdot (im), po (im, km), &
+ pwavo (im), pwevo (im), mbdt (im), &
+ qcdo (im, km), qcond (im), qevap (im), &
+ rntot (im), vshear (im), xaa0 (im), &
+ xk (im), xlamd (im), cina (im), &
+ xmb (im), xmbmax (im), xpwav (im), &
+ xpwev (im), delebar (im, ntr), &
+ ! xlamx (im), &
+ delubar (im), delvbar (im), &
+ xlamdet (im), xlamddt (im), &
+ cxlamet (im), cxlamdt (im)
+
+ real :: c0 (im)
+
+ real :: cinpcr, cinpcrmx, cinpcrmn, &
+ cinacr, cinacrmx, cinacrmn
+
+ ! parameters for updraft velocity calculation
+ real :: bet1, cd1, f1, gam1, &
+ bb1, bb2, wucb, csmf, tkcrt, cmxfac
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (d0 = .001)
+
+ ! asolfac_deep: aerosol - aware parameter based on lim & hong (2012)
+ ! asolfac_deep = cx / c0s_deep (= .002)
+ ! cx = min ([ - 0.7 ln (nccn) + 24] * 1.e-4, c0s_deep)
+ ! nccn: ccn number concentration in cm^ (- 3)
+ ! until a realistic nccn is provided, typical nccns are assumed
+ ! as nccn = 100 for sea and nccn = 1000 for land
+
+ parameter (cm = 1.0, delta = zvir)
+ parameter (fact1 = (cp_vap - c_liq) / rvgas, fact2 = hlv / rvgas - fact1 * tice)
+ parameter (clamd = 0.03, tkemx = 0.65, tkemn = 0.05)
+ parameter (dtke = tkemx - tkemn)
+ parameter (dbeta = 0.1)
+ parameter (dthk = 25.)
+ parameter (cinpcrmx = 180., cinpcrmn = 120.)
+ parameter (cinacrmx = - 120., cinacrmn = - 80.)
+ parameter (bet1 = 1.875, cd1 = .506, f1 = 2.0, gam1 = .5)
+ parameter (dxcrtuf = 15.e3)
+ parameter (bb1 = 4.0, bb2 = 0.8, csmf = 0.2)
+ parameter (tkcrt = 2., cmxfac = 15.)
+
+ ! local variables and arrays
+ real :: pfld (im, km), to (im, km), qo (im, km), &
+ uo (im, km), vo (im, km), qeso (im, km), &
+ ctr (im, km, ntr), ctro (im, km, ntr)
+
+ ! for aerosol transport
+ real :: qaero (im, km, ntc)
+
+ ! for updraft velocity calculation
+ real :: wu2 (im, km), buo (im, km), drag (im, km), wush (im, km)
+ real :: wc (im), scaldfunc (im), sigmagfm (im)
+
+ real :: qlko_ktcon (im), dellal (im, km), tvo (im, km), &
+ dbyo (im, km), zo (im, km), &
+ xlamue (im, km), xlamud (im, km), &
+ fent1 (im, km), fent2 (im, km), frh (im, km), &
+ heo (im, km), heso (im, km), &
+ qrcd (im, km), dellah (im, km), dellaq (im, km), &
+ dellae (im, km, ntr), &
+ dellau (im, km), dellav (im, km), hcko (im, km), &
+ ucko (im, km), vcko (im, km), qcko (im, km), &
+ ecko (im, km, ntr), &
+ eta (im, km), etad (im, km), zi (im, km), &
+ qrcko (im, km), qrcdo (im, km), &
+ pwo (im, km), pwdo (im, km), c0t (im, km), &
+ tx1 (im), sumx (im), cnvwt (im, km)
+ ! rhbar (im)
+
+ logical :: do_aerosols, totflg, cnvflg (im), asqecflg (im), flg (im)
+
+ ! asqecflg: flag for the quasi - equilibrium assumption of arakawa - schubert
+
+ ! real :: pcrit (15), acritt (15), acrit (15)
+ ! save pcrit, acritt
+ ! data pcrit / 850., 800., 750., 700., 650., 600., 550., 500., 450., 400., &
+ ! 350., 300., 250., 200., 150. /
+ ! data acritt / .0633, .0445, .0553, .0664, .075, .1082, .1521, .2216, &
+ ! .3151, .3677, .41, .5255, .7663, 1.1686, 1.6851 /
+ ! gdas derived acrit
+ ! data acritt / .203, .515, .521, .566, .625, .665, .659, .688, &
+ ! .743, .813, .886, .947, 1.138, 1.377, 1.896 /
+
+ real :: tf, tcr, tcrf
+ parameter (tf = 233.16, tcr = 263.16, tcrf = 1.0 / (tcr - tf))
+
+ ! -----------------------------------------------------------------------
+ ! determine whether to perform aerosol transport
+ ! -----------------------------------------------------------------------
+
+ do_aerosols = (itc > 0) .and. (ntc > 0) .and. (ntr > 0)
+ if (do_aerosols) do_aerosols = (ntr >= itc + ntc - 3)
+
+ ! -----------------------------------------------------------------------
+ ! compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm.
+ ! convert input pressure terms to centibar units.
+ ! convert input pa terms to cb terms -- moorthi
+ ! -----------------------------------------------------------------------
+
+ km1 = km - 1
+
+ ! -----------------------------------------------------------------------
+ ! initialize column - integrated and other single - value - per - column variable arrays.
+ ! initialize arrays
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ cnvflg (i) = .true.
+ rn (i) = 0.
+ mbdt (i) = 10.
+ kbot (i) = km + 1
+ ktop (i) = 0
+ kbcon (i) = km
+ ktcon (i) = 1
+ ktconn (i) = 1
+ dtconv (i) = 3600.
+ pdot (i) = 0.
+ lmin (i) = 1
+ jmin (i) = 1
+ qlko_ktcon (i) = 0.
+ edt (i) = 0.
+ edto (i) = 0.
+ edtx (i) = 0.
+ ! acrt (i) = 0.
+ ! acrtfct (i) = 1.
+ aa1 (i) = 0.
+ aa2 (i) = 0.
+ xaa0 (i) = 0.
+ cina (i) = 0.
+ pwavo (i) = 0.
+ pwevo (i) = 0.
+ xpwav (i) = 0.
+ xpwev (i) = 0.
+ vshear (i) = 0.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine aerosol - aware rain conversion parameter over land
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (islimsk (i) == 1) then
+ c0 (i) = c0s_deep * asolfac_deep
+ else
+ c0 (i) = c0s_deep
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine rain conversion parameter above the freezing level which exponentially
+ ! decreases with decreasing temperature from han et al.'s (2017) equation 8.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (t1 (i, k) > 273.16) then
+ c0t (i, k) = c0 (i)
+ else
+ tem = d0 * (t1 (i, k) - 273.16)
+ tem1 = exp (tem)
+ c0t (i, k) = c0 (i) * tem1
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! initialize convective cloud water and cloud cover to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw)) cnvw (i, k) = 0.
+ if (present (cnvc)) cnvc (i, k) = 0.
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ qr (i, k) = 0.
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! initialize updraft and downdraft mass fluxes to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf)) ud_mf (i, k) = 0.
+ if (present (dd_mf)) dd_mf (i, k) = 0.
+ if (present (dt_mf)) dt_mf (i, k) = 0.
+ enddo
+ enddo
+
+ ! do k = 1, 15
+ ! acrit (k) = acritt (k) * (975. - pcrit (k))
+ ! enddo
+
+ dt2 = delt
+ ! val = 1200.
+ val = 600.
+ dtmin = max (dt2, val)
+ ! val = 5400.
+ val = 10800.
+ dtmax = max (dt2, val)
+
+ ! -----------------------------------------------------------------------
+ ! model tunable parameters are all here
+ ! -----------------------------------------------------------------------
+
+ edtmaxl = .3
+ edtmaxs = .3
+ ! clam_deep = .1
+ aafac = .05
+ ! betal_deep = .15
+ ! betas_deep = .15
+ ! betal_deep = .05
+ ! betas_deep = .05
+ ! evef = 0.07
+ ! evfact_deep = 0.3
+ ! evfactl_deep = 0.3
+
+ crtlame = 1.0e-4
+ crtlamd = 1.0e-4
+
+ ! cxlame = 1.0e-3
+ cxlame = 1.0e-4
+ cxlamd = 1.0e-4
+ xlamde = 1.0e-4
+ xlamdd = 1.0e-4
+
+ ! pgcon_deep = 0.7 ! gregory et al. (1997, qjrms)
+ ! pgcon_deep = 0.55 ! zhang & wu (2003, jas)
+
+ w1l = - 8.e-3
+ w2l = - 4.e-2
+ w3l = - 5.e-3
+ w4l = - 5.e-4
+ w1s = - 2.e-4
+ w2s = - 2.e-3
+ w3s = - 1.e-3
+ w4s = - 2.e-5
+
+ ! -----------------------------------------------------------------------
+ ! define top layer for search of the downdraft originating layer
+ ! and the maximum thetae for updraft
+ ! determine maximum indices for the parcel starting point (kbm), lfc (kbmax), and cloud top (kmax) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ kbmax (i) = km
+ kbm (i) = km
+ kmax (i) = km
+ tx1 (i) = 1.0 / psp (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (prslp (i, k) * tx1 (i) > 0.04) kmax (i) = k + 1
+ if (prslp (i, k) * tx1 (i) > 0.45) kbmax (i) = k + 1
+ if (prslp (i, k) * tx1 (i) > 0.70) kbm (i) = k + 1
+ enddo
+ enddo
+
+ do i = 1, im
+ kmax (i) = min (km, kmax (i))
+ kbmax (i) = min (kbmax (i), kmax (i))
+ kbm (i) = min (kbm (i), kmax (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hydrostatic height assume zero terr and initially assume
+ ! updraft entrainment rate as an inverse function of height
+ ! calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ zo (i, k) = phil (i, k) / g
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate interface height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ zi (i, k) = 0.5 * (zo (i, k) + zo (i, k + 1))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convert surface pressure to mb from cb
+ ! convert prslp from centibar to millibar, set normalized mass fluxes to 1, cloud properties to 0, and save model state variables (after advection / turbulence) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ pfld (i, k) = prslp (i, k) * 0.01
+ eta (i, k) = 1.
+ fent1 (i, k) = 1.
+ fent2 (i, k) = 1.
+ frh (i, k) = 0.
+ hcko (i, k) = 0.
+ qcko (i, k) = 0.
+ qrcko (i, k) = 0.
+ ucko (i, k) = 0.
+ vcko (i, k) = 0.
+ etad (i, k) = 1.
+ hcdo (i, k) = 0.
+ qcdo (i, k) = 0.
+ ucdo (i, k) = 0.
+ vcdo (i, k) = 0.
+ qrcd (i, k) = 0.
+ qrcdo (i, k) = 0.
+ dbyo (i, k) = 0.
+ pwo (i, k) = 0.
+ pwdo (i, k) = 0.
+ dellal (i, k) = 0.
+ to (i, k) = t1 (i, k)
+ qo (i, k) = q1 (i, k)
+ uo (i, k) = u1 (i, k)
+ vo (i, k) = v1 (i, k)
+ ! uo (i, k) = u1 (i, k) * rcs (i)
+ ! vo (i, k) = v1 (i, k) * rcs (i)
+ wu2 (i, k) = 0.
+ buo (i, k) = 0.
+ drag (i, k) = 0.
+ cnvwt (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! initialize tracer variables
+ ! -----------------------------------------------------------------------
+
+ kk = 0
+ do n = 1, ntr + 2
+ if (n .eq. ntw .or. n .eq. nti) cycle
+ kk = kk + 1
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ ctr (i, k, kk) = qtr (i, k, n)
+ ctro (i, k, kk) = qtr (i, k, n)
+ ecko (i, k, kk) = 0.
+ ecdo (i, k, kk) = 0.
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! column variables
+ ! p is pressure of the layer (mb)
+ ! t is temperature at t - dt (k) ..tn
+ ! q is mixing ratio at t - dt (kg / kg) ..qn
+ ! to is temperature at t + dt (k) ... this is after advection and turbulan
+ ! qo is mixing ratio at t + dt (kg / kg) ..q1
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate saturation specific humidity and enforce minimum moisture values.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ ! tvo (i, k) = to (i, k) + delta * to (i, k) * qo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute moist static energy
+ ! calculate moist static energy (heo) and saturation moist static energy (heso) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ ! tem = g * zo (i, k) + cp_air * to (i, k)
+ tem = phil (i, k) + cp_air * to (i, k)
+ heo (i, k) = tem + hlv * qo (i, k)
+ heso (i, k) = tem + hlv * qeso (i, k)
+ ! heo (i, k) = min (heo (i, k), heso (i, k))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine level with largest moist static energy
+ ! this is the level where updraft starts
+ ! perform calculations related to the updraft of the entraining / detraining cloud model ("static control") .
+ ! search below index "kbm" for the level of maximum moist static energy.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ hmax (i) = heo (i, 1)
+ kb (i) = 1
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (k <= kbm (i)) then
+ if (heo (i, k) > hmax (i)) then
+ kb (i) = k
+ hmax (i) = heo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the temperature, specific humidity, and pressure at interface levels.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k <= kmax (i) - 1) then
+ dz = .5 * (zo (i, k + 1) - zo (i, k))
+ dp = .5 * (pfld (i, k + 1) - pfld (i, k))
+ es = 0.01 * mqs (to (i, k + 1)) ! mqs is in pa
+ pprime = pfld (i, k + 1) + epsm1 * es
+ qs = eps * es / pprime
+ dqsdp = - qs / pprime
+ desdt = es * (fact1 / to (i, k + 1) + fact2 / (to (i, k + 1) ** 2))
+ dqsdt = qs * pfld (i, k + 1) * desdt / (es * pprime)
+ gamma = el2orc * qeso (i, k + 1) / (to (i, k + 1) ** 2)
+ dt = (g * dz + hlv * dqsdp * dp) / (cp_air * (1. + gamma))
+ dq = dqsdt * dt + dqsdp * dp
+ to (i, k) = to (i, k + 1) + dt
+ qo (i, k) = qo (i, k + 1) + dq
+ po (i, k) = .5 * (pfld (i, k) + pfld (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. enforce minimum specific humidity and calculate \f$ (1 - rh) \f$.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k <= kmax (i) - 1) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (po (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ frh (i, k) = 1. - min (qo (i, k) / qeso (i, k), 1.)
+ heo (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qeso (i, k)
+ uo (i, k) = .5 * (uo (i, k) + uo (i, k + 1))
+ vo (i, k) = .5 * (vo (i, k) + vo (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 1, km1
+ do i = 1, im
+ if (k <= kmax (i) - 1) then
+ ctro (i, k, n) = .5 * (ctro (i, k, n) + ctro (i, k + 1, n))
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! look for the level of free convection as cloud base
+ ! search below the index "kbmax" for the level of free convection (lfc) where the condition \f$h_b > h^ * \f$ is first met, where \f$h_b, h^ * \f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. set "kbcon" to the index of the lfc.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .true.
+ kbcon (i) = kmax (i)
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (flg (i) .and. k <= kbmax (i)) then
+ if (k > kb (i) .and. heo (i, kb (i)) > heso (i, k)) then
+ kbcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if no lfc, return to the calling routine without modifying state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (kbcon (i) == kmax (i)) cnvflg (i) = .false.
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine the vertical pressure velocity at the lfc. after han and pan (2011), determine the maximum pressure thickness between a parcel's starting level and the lfc. if a parcel doesn't reach the lfc within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! pdot (i) = 10. * dot (i, kbcon (i))
+ pdot (i) = 0.01 * dot (i, kbcon (i)) ! now dot is in pa / s
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if pressure depth between parcel source level
+ ! and cloud base is larger than a critical value, cinpcr
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ ptem = 1. - tem
+ ptem1 = .5 * (cinpcrmx - cinpcrmn)
+ cinpcr = cinpcrmx - ptem * ptem1
+ tem1 = pfld (i, kb (i)) - pfld (i, kbcon (i))
+ if (tem1 > cinpcr) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! turbulent entrainment rate assumed to be proportional
+ ! to subcloud mean tke
+ ! -----------------------------------------------------------------------
+
+ if (ntk > 0) then
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ tkemean (i) = 0.
+ endif
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kb (i) .and. k < kbcon (i)) then
+ dz = zo (i, k + 1) - zo (i, k)
+ tem = 0.5 * (qtr (i, k, ntk) + qtr (i, k + 1, ntk))
+ tkemean (i) = tkemean (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ tkemean (i) = tkemean (i) / sumx (i)
+ if (tkemean (i) > tkemx) then
+ clamt (i) = clam_deep + clamd
+ else if (tkemean (i) < tkemn) then
+ clamt (i) = clam_deep - clamd
+ else
+ tem = tkemx - tkemean (i)
+ tem1 = 1. - 2. * tem / dtke
+ clamt (i) = clam_deep + clamd * tem1
+ endif
+ endif
+ enddo
+ ! kgao 12 / 08 / 2023: adjust ent / det rates based on tke
+ if (use_tke_conv) then
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamdet (i) = xlamde
+ xlamddt (i) = xlamdd
+ cxlamet (i) = cxlame
+ cxlamdt (i) = cxlamd
+ if (tkemean (i) > tkcrt) then
+ tem = 1. + tkemean (i) / tkcrt
+ tem1 = min (tem, cmxfac)
+ clamt (i) = tem1 * clam_deep
+ xlamdet (i) = tem1 * xlamdet (i)
+ xlamddt (i) = tem1 * xlamddt (i)
+ cxlamet (i) = tem1 * cxlamet (i)
+ cxlamdt (i) = tem1 * cxlamdt (i)
+ endif
+ endif
+ enddo
+ endif
+ else
+ do i = 1, im
+ if (cnvflg (i)) then
+ clamt (i) = clam_deep
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! also initially assume updraft entrainment rate
+ ! is an inverse function of height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamue (i, k) = clamt (i) / zi (i, k)
+ xlamue (i, k) = max (xlamue (i, k), crtlame)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! assume that updraft entrainment rate above cloud base is
+ ! same as that at cloud base
+ ! -----------------------------------------------------------------------
+
+ ! calculate the entrainment rate according to han and pan (2011), equation 8, after bechtold et al. (2008), equation 2 given by:
+ ! \f[
+ ! \epsilon = \epsilon_0f_0 + d_1\left (1 - rh\right) f_1
+ ! \f]
+ ! where \f$\epsilon_0\f$ is the cloud base entrainment rate, \f$d_1\f$ is a tunable constant, and \f$f_0 = \left (\frac{q_s}{q_{s, b}}\right) ^2\f$ and \f$f_1 = \left (\frac{q_s}{q_{s, b}}\right) ^3\f$ where \f$q_s\f$ and \f$q_{s, b}\f$ are the saturation specific humidities at a given level and cloud base, respectively. the detrainment rate in the cloud is assumed to be equal to the entrainment rate at cloud base.
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! xlamx (i) = xlamue (i, kbcon (i))
+ ! endif
+ ! enddo
+ ! do k = 2, km1
+ ! do i = 1, im
+ ! if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ ! xlamue (i, k) = xlamx (i)
+ ! endif
+ ! enddo
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify detrainment rate for the updrafts
+ ! (the updraft detrainment rate is set constant and equal to the entrainment rate at cloud base.)
+ ! the updraft detrainment rate is vertically constant and proportional to clamt
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k < kmax (i)) then
+ ! xlamud (i, k) = xlamx (i)
+ ! xlamud (i, k) = crtlamd
+ xlamud (i, k) = 0.001 * clamt (i)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! functions rapidly decreasing with height, mimicking a cloud ensemble
+ ! entrainment functions decreasing with height (fent),
+ ! mimicking a cloud ensemble
+ ! (bechtold et al., 2008)
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ tem = qeso (i, k) / qeso (i, kbcon (i))
+ fent1 (i, k) = tem ** 2
+ fent2 (i, k) = tem ** 3
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final entrainment and detrainment rates as the sum of turbulent part and
+ ! organized one depending on the environmental relative humidity
+ ! (bechtold et al., 2008; derbyshire et al., 2011)
+ ! -----------------------------------------------------------------------
+
+ ! kgao 12 / 21 / 2023
+ if (use_tke_conv) then
+ ! new code
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ tem = cxlamet (i) * frh (i, k) * fent2 (i, k)
+ xlamue (i, k) = xlamue (i, k) * fent1 (i, k) + tem
+ tem1 = cxlamdt (i) * frh (i, k)
+ xlamud (i, k) = xlamud (i, k) + tem1
+ endif
+ enddo
+ enddo
+ else
+ ! ori code
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ tem = cxlame * frh (i, k) * fent2 (i, k)
+ xlamue (i, k) = xlamue (i, k) * fent1 (i, k) + tem
+ tem1 = cxlamd * frh (i, k)
+ xlamud (i, k) = xlamud (i, k) + tem1
+ endif
+ enddo
+ enddo
+ endif ! end of use_tke_conv
+
+ ! -----------------------------------------------------------------------
+ ! determine updraft mass flux for the subcloud layers
+ ! calculate the normalized mass flux for subcloud and in - cloud layers according to pan and wu (1995) equation 1:
+ ! \f[
+ ! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d
+ ! \f]
+ ! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < kbcon (i) .and. k >= kb (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ tem = 0.5 * (xlamud (i, k) + xlamud (i, k + 1))
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k + 1)) - tem
+ eta (i, k) = eta (i, k + 1) / (1. + ptem * dz)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute mass flux above cloud base
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k > kbcon (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamud (i, k) + xlamud (i, k - 1))
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) - tem
+ eta (i, k) = eta (i, k - 1) * (1 + ptem * dz)
+ if (eta (i, k) <= 0.) then
+ kmax (i) = k
+ ktconn (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft cloud properties
+ ! set cloud properties equal to the state variables at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = kb (i)
+ hcko (i, indx) = heo (i, indx)
+ ucko (i, indx) = uo (i, indx)
+ vcko (i, indx) = vo (i, indx)
+ pwavo (i) = 0.
+ endif
+ enddo
+
+ ! for tracers
+ do n = 1, ntr
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = kb (i)
+ ecko (i, indx, n) = ctro (i, indx, n)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud property is modified by the entrainment process
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! cloud property is modified by the entrainment process
+ ! cm is an enhancement factor in entrainment rates for momentum
+ ! calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. discretization follows appendix b of grell (1993). following han and pan (2006), the convective momentum transport is reduced by the convection - induced pressure gradient force by the constant "pgcon_deep", currently set to 0.55 after zhang and wu (2003).
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ hcko (i, k) = ((1. - tem1) * hcko (i, k - 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k - 1))) / factor
+ dbyo (i, k) = hcko (i, k) - heso (i, k)
+
+ tem = 0.5 * cm * tem
+ factor = 1. + tem
+ ptem = tem + pgcon_deep
+ ptem1 = tem - pgcon_deep
+ ucko (i, k) = ((1. - tem) * ucko (i, k - 1) + ptem * uo (i, k) &
+ + ptem1 * uo (i, k - 1)) / factor
+ vcko (i, k) = ((1. - tem) * vcko (i, k - 1) + ptem * vo (i, k) &
+ + ptem1 * vo (i, k - 1)) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.25 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ factor = 1. + tem
+ ecko (i, k, n) = ((1. - tem) * ecko (i, k - 1, n) + tem * &
+ (ctro (i, k, n) + ctro (i, k - 1, n))) / factor
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! taking account into convection inhibition due to existence of
+ ! dry layers below cloud base
+ ! with entrainment, recalculate the lfc as the first level where buoyancy is positive. the difference in pressure levels between lfcs calculated with / without entrainment must be less than a threshold (currently 25 hpa) . otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. this is the subcloud dryness trigger modification discussed in han and pan (2011).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ kbcon1 (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kmax (i)) then
+ if (k >= kbcon (i) .and. dbyo (i, k) > 0.) then
+ kbcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kbcon1 (i) == kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = pfld (i, kbcon (i)) - pfld (i, kbcon1 (i))
+ if (tem > dthk) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! calculate convective inhibition
+ ! calculate additional trigger condition of the convective inhibition (cin) according to han et al.'s (2017) equation 13.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kbcon1 (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ dz1 * g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if the cin is less than a critical value (cinacr) which is inversely proportional to the large - scale vertical velocity.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ tem = 1. - tem
+ tem1 = .5 * (cinacrmx - cinacrmn)
+ cinacr = cinacrmx - tem * tem1
+
+ ! cinacr = cinacrmx
+ if (cina (i) < cinacr) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine first guess cloud top as the level of zero buoyancy
+ ! calculate the cloud top as the first level where parcel buoyancy becomes negative. if the thickness of the calculated convection is less than a threshold (currently 200 hpa), then convection is inhibited, and the scheme returns to the calling routine.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ ktcon (i) = 1
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kmax (i)) then
+ if (k > kbcon1 (i) .and. dbyo (i, k) < 0.) then
+ ktcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (ktcon (i) == 1 .and. ktconn (i) > 1) then
+ ktcon (i) = ktconn (i)
+ endif
+ tem = pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ if (tem < cthk_deep) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! search for downdraft originating level above theta - e minimum
+ ! to originate the downdraft, search for the level above the minimum in moist static energy. return to the calling routine without modification if this level is determined to be outside of the convective cloud layers.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ hmin (i) = heo (i, kbcon1 (i))
+ lmin (i) = kbmax (i)
+ jmin (i) = kbmax (i)
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kbmax (i)) then
+ if (k > kbcon1 (i) .and. heo (i, k) < hmin (i)) then
+ lmin (i) = k + 1
+ hmin (i) = heo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! make sure that jmin (i) is within the cloud
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ jmin (i) = min (lmin (i), ktcon (i) - 1)
+ jmin (i) = max (jmin (i), kbcon1 (i) + 1)
+ if (jmin (i) >= ktcon (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify upper limit of mass flux at cloud base
+ ! calculate the maximum value of the cloud base mass flux using the cfl - criterion - based formula of han and pan (2011), equation 7.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! xmbmax (i) = .1
+
+ k = kbcon (i)
+ dp = delp (i, k)
+ xmbmax (i) = dp / (2. * g * dt2)
+ ! xmbmax (i) = dp / (g * dt2)
+
+ ! mbdt (i) = 0.1 * dp / g
+
+ ! tem = dp / (g * dt2)
+ ! xmbmax (i) = min (tem, xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property and precipitation
+ ! set cloud moisture property equal to the enviromental moisture at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! aa1 (i) = 0.
+ qcko (i, kb (i)) = qo (i, kb (i))
+ qrcko (i, kb (i)) = qo (i, kb (i))
+ ! rhbar (i) = 0.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the moisture content of the entraining / detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation a.14 in grell (1993). their difference is the amount of convective cloud water (qlk = rain + condensate) . determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo) . calculate and save the negative cloud work function (aa1) due to water loading. the liquid water in the updraft layer is assumed to be detrained from the layers above the level of the minimum moist static energy into the grid - scale cloud water (dellal) .
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! rhbar (i) = rhbar (i) + qo (i, k) / qeso (i, k)
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i) .and. dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0 .and. k > jmin (i)) then
+ ptem = c0t (i, k) + c1_deep
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_deep * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ ! aa1 (i) = aa1 (i) - dz * g * qlk * etah
+ ! aa1 (i) = aa1 (i) - dz * g * qlk
+ buo (i, k) = buo (i, k) - g * qlk
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ pwavo (i) = pwavo (i) + pwo (i, k)
+ ! cnvwt (i, k) = (etah * qlk + pwo (i, k)) * g / dp
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy and drag for updraft velocity
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i)) then
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ buo (i, k) = buo (i, k) + (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ buo (i, k) = buo (i, k) + g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ drag (i, k) = max (xlamue (i, k), xlamud (i, k))
+ ! kgao 12 / 18 / 2023: considers shear effect
+ tem = ((uo (i, k) - uo (i, k - 1)) / dz) ** 2
+ tem = tem + ((vo (i, k) - vo (i, k - 1)) / dz) ** 2
+ wush (i, k) = csmf * sqrt (tem)
+ endif
+
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! indx = ktcon (i) - kb (i) - 1
+ ! rhbar (i) = rhbar (i) / float (indx)
+ ! endif
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! do k = 2, km1
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (k >= kbcon (i) .and. k < ktcon (i)) then
+ ! dz1 = zo (i, k + 1) - zo (i, k)
+ ! gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ ! rfact = 1. + delta * cp_air * gamma &
+ ! * to (i, k) / hlv
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ ! dz1 * (g / (cp_air * to (i, k))) &
+ ! * dbyo (i, k) / (1. + gamma) &
+ ! * rfact
+ ! val = 0.
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate the cloud work function according to pan and wu (1995) equation 4:
+ ! \f[
+ ! a_u = \int_{z_0}^{z_t}\frac{g}{c_pt (z) }\frac{\eta}{1 + \gamma}[h (z) - h^ * (z) ]dz
+ ! \f]
+ ! (discretized according to grell (1993) equation b.10 using b.2 and b.3 of arakawa and schubert (1974) and assuming \f$\eta = 1\f$) where \f$a_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{l}{c_p}\left (\frac{\partial \overline{q_s}}{\partial t}\right) _p\f$ and other quantities are previously defined.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ ! aa1 (i) = aa1 (i) + buo (i, k) * dz1 * eta (i, k)
+ aa1 (i) = aa1 (i) + buo (i, k) * dz1
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i) .and. aa1 (i) <= 0.) cnvflg (i) = .false.
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! estimate the onvective overshooting as the level
+ ! where the [aafac * cloud work function] becomes zero,
+ ! which is the final cloud top
+ ! continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to han and pan (2011). convective overshooting stops when \f$ ca_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa2 (i) = aafac * aa1 (i)
+ endif
+ enddo
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ ktcon1 (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k >= ktcon (i) .and. k < kmax (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ aa2 (i) = aa2 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ ! val = 0.
+ ! aa2 (i) = aa2 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ if (aa2 (i) < 0.) then
+ ktcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property, detraining cloud water
+ ! and precipitation in overshooting layers
+ ! for the overshooting convection, calculate the moisture content of the entraining / detraining parcel as before. partition convective cloud water and precipitation and detrain convective cloud water above the mimimum in moist static energy.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= ktcon (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0) then
+ ptem = c0t (i, k) + c1_deep
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_deep * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ pwavo (i) = pwavo (i) + pwo (i, k)
+ ! cnvwt (i, k) = (etah * qlk + pwo (i, k)) * g / dp
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity square (wu2)
+ ! calculate updraft velocity square (wu2) according to han et al.'s (2017) equation 7.
+ ! -----------------------------------------------------------------------
+
+ ! bb1 = 2. * (1. + bet1 * cd1)
+ ! bb2 = 2. / (f1 * (1. + gam1))
+ !
+ ! bb1 = 3.9
+ ! bb2 = 0.67
+ !
+ ! bb1 = 2.0
+ ! bb2 = 4.0
+
+ ! bb1 = 4.0
+ ! bb2 = 0.8
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! k = kbcon1 (i)
+ ! tem = po (i, k) / (rdgas * to (i, k))
+ ! wucb = - 0.01 * dot (i, k) / (tem * g)
+ ! if (wucb > 0.) then
+ ! wu2 (i, k) = wucb * wucb
+ ! else
+ ! wu2 (i, k) = 0.
+ ! endif
+ ! endif
+ ! enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.25 * bb1 * (drag (i, k) + drag (i, k - 1)) * dz
+ tem1 = 0.5 * bb2 * (buo (i, k) + buo (i, k - 1)) * dz
+ ! kgao 12 / 18 / 2023
+ if (use_shear_conv) then
+ tem2 = wush (i, k) * sqrt (wu2 (i, k - 1))
+ tem2 = (tem1 - tem2) * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem2) / ptem1
+ else
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ endif
+ wu2 (i, k) = max (wu2 (i, k), 0.)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity average over the whole cumulus
+ ! calculate the mean updraft velocity within the cloud (wc) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ wc (i) = 0.
+ sumx (i) = 0.
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (sqrt (wu2 (i, k)) + sqrt (wu2 (i, k - 1)))
+ wc (i) = wc (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sumx (i) == 0.) then
+ cnvflg (i) = .false.
+ else
+ wc (i) = wc (i) / sumx (i)
+ endif
+ val = 1.e-4
+ if (wc (i) < val) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! exchange ktcon with ktcon1
+ ! swap the indices of the convective cloud top (ktcon) and the overshooting convection top (ktcon1) to use the same cloud top level in the calculations of \f$a^ + \f$ and \f$a^ * \f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = ktcon (i)
+ ktcon (i) = ktcon1 (i)
+ ktcon1 (i) = kk
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! this section is ready for cloud water
+ ! separate the total updraft cloud water at cloud top into vapor and condensate.
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ ! -----------------------------------------------------------------------
+ ! compute liquid and vapor separation at cloud top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = ktcon (i) - 1
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ dq = qcko (i, k) - qrch
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ qlko_ktcon (i) = dq
+ qcko (i, k) = qrch
+ endif
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! downdraft calculations
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! compute precipitation efficiency in terms of windshear
+ ! perform calculations related to the downdraft of the entraining / detraining cloud model ("static control") .
+ ! first, in order to calculate the downdraft mass flux (as a fraction of the updraft mass flux), calculate the wind shear and precipitation efficiency according to equation 58 in fritsch and chappell (1980):
+ ! \f[
+ ! e = 1.591 - 0.639\frac{\delta v}{\delta z} + 0.0953\left (\frac{\delta v}{\delta z}\right) ^2 - 0.00496\left (\frac{\delta v}{\delta z}\right) ^3
+ ! \f]
+ ! where \f$\delta v\f$ is the integrated horizontal shear over the cloud depth, \f$\delta z\f$, (the ratio is converted to units of \f$10^{ - 3} s^{ - 1}\f$) . the variable "edto" is \f$1 - e\f$ and is constrained to the range \f$[0, 0.9]\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ shear = sqrt ((uo (i, k) - uo (i, k - 1)) ** 2 &
+ + (vo (i, k) - vo (i, k - 1)) ** 2)
+ vshear (i) = vshear (i) + shear
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 1.e3 * vshear (i) / (zi (i, ktcon (i)) - zi (i, kb (i)))
+ e1 = 1.591 - .639 * vshear (i) &
+ + .0953 * (vshear (i) ** 2) - .00496 * (vshear (i) ** 3)
+ edt (i) = 1. - e1
+ val = .9
+ edt (i) = min (edt (i), val)
+ val = .0
+ edt (i) = max (edt (i), val)
+ edto (i) = edt (i)
+ edtx (i) = edt (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine detrainment rate between 1 and kbcon
+ ! next, calculate the variable detrainment rate between the surface and the lfc according to:
+ ! \f[
+ ! \lambda_d = \frac{1 - \beta^{\frac{1}{k_{lfc}}}}{\overline{\delta z}}
+ ! \f]
+ ! \f$\lambda_d\f$ is the detrainment rate, \f$\beta\f$ is a constant currently set to 0.05, implying that only 5% of downdraft mass flux at lfc reaches the ground surface due to detrainment, \f$k_{lfc}\f$ is the vertical index of the lfc level, and \f$\overline{\delta z}\f$ is the average vertical grid spacing below the lfc.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ endif
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= 1 .and. k < kbcon (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ betamn = betas_deep
+ if (islimsk (i) == 1) betamn = betal_deep
+ if (ntk > 0) then
+ betamx = betamn + dbeta
+ if (tkemean (i) > tkemx) then
+ beta = betamn
+ else if (tkemean (i) < tkemn) then
+ beta = betamx
+ else
+ tem = (betamx - betamn) * (tkemean (i) - tkemn)
+ beta = betamx - tem / dtke
+ endif
+ else
+ beta = betamn
+ endif
+ dz = (sumx (i) + zi (i, 1)) / float (kbcon (i))
+ tem = 1. / float (kbcon (i))
+ xlamd (i) = (1. - beta ** tem) / dz
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine downdraft mass flux
+ ! calculate the normalized downdraft mass flux from equation 1 of pan and wu (1995). downdraft entrainment and detrainment rates are constants from the downdraft origination to the lfc.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ if (k < jmin (i) .and. k >= kbcon (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ ptem = xlamddt (i) - xlamdet (i)
+ else
+ ptem = xlamdd - xlamde
+ endif
+ etad (i, k) = etad (i, k + 1) * (1. - ptem * dz)
+ else if (k < kbcon (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ ptem = xlamd (i) + xlamddt (i) - xlamdet (i)
+ else
+ ptem = xlamd (i) + xlamdd - xlamde
+ endif
+ etad (i, k) = etad (i, k + 1) * (1. - ptem * dz)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft moisture properties
+ ! set initial cloud downdraft properties equal to the state variables at the downdraft origination level.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ jmn = jmin (i)
+ hcdo (i, jmn) = heo (i, jmn)
+ qcdo (i, jmn) = qo (i, jmn)
+ qrcdo (i, jmn) = qo (i, jmn)
+ ucdo (i, jmn) = uo (i, jmn)
+ vcdo (i, jmn) = vo (i, jmn)
+ pwevo (i) = 0.
+ endif
+ enddo
+
+ ! for tracers
+ do n = 1, ntr
+ do i = 1, im
+ if (cnvflg (i)) then
+ jmn = jmin (i)
+ ecdo (i, jmn, n) = ctro (i, jmn, n)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the cloud properties as a parcel descends, modified by entrainment and detrainment. discretization follows appendix b of grell (1993).
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ if (k >= kbcon (i)) then
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * xlamddt (i) * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ endif
+ else
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * (xlamd (i) + xlamddt (i)) * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ endif
+ factor = 1. + tem - tem1
+ hcdo (i, k) = ((1. - tem1) * hcdo (i, k + 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k + 1))) / factor
+ dbyo (i, k) = hcdo (i, k) - heso (i, k)
+
+ tem = 0.5 * cm * tem
+ factor = 1. + tem
+ ptem = tem - pgcon_deep
+ ptem1 = tem + pgcon_deep
+ ucdo (i, k) = ((1. - tem) * ucdo (i, k + 1) + ptem * uo (i, k + 1) &
+ + ptem1 * uo (i, k)) / factor
+ vcdo (i, k) = ((1. - tem) * vcdo (i, k + 1) + ptem * vo (i, k + 1) &
+ + ptem1 * vo (i, k)) / factor
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ tem = 0.5 * xlamdet (i) * dz
+ else
+ tem = 0.5 * xlamde * dz
+ endif
+ factor = 1. + tem
+ ecdo (i, k, n) = ((1. - tem) * ecdo (i, k + 1, n) + tem * &
+ (ctro (i, k, n) + ctro (i, k + 1, n))) / factor
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute the amount of moisture that is necessary to keep the downdraft saturated.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrcdo (i, k) = qeso (i, k) + &
+ (1. / hlv) * (gamma / (1. + gamma)) * dbyo (i, k)
+ ! detad = etad (i, k + 1) - etad (i, k)
+
+ dz = zi (i, k + 1) - zi (i, k)
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ if (k >= kbcon (i)) then
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * xlamddt (i) * dz
+ else
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * (xlamd (i) + xlamddt (i)) * dz
+ endif
+ else
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ endif
+ factor = 1. + tem - tem1
+ qcdo (i, k) = ((1. - tem1) * qrcdo (i, k + 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k + 1))) / factor
+
+ ! pwdo (i, k) = etad (i, k + 1) * qcdo (i, k + 1) - &
+ ! etad (i, k) * qrcdo (i, k)
+ ! pwdo (i, k) = pwdo (i, k) - detad * &
+ ! .5 * (qrcdo (i, k) + qrcdo (i, k + 1))
+
+ pwdo (i, k) = etad (i, k) * (qcdo (i, k) - qrcdo (i, k))
+ pwevo (i) = pwevo (i) + pwdo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final downdraft strength dependent on precip
+ ! efficiency (edt), normalized condensate (pwav), and
+ ! evaporate (pwev)
+ ! update the precipitation efficiency (edto) based on the ratio of normalized cloud condensate (pwavo) to normalized cloud evaporate (pwevo) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ edtmax = edtmaxl
+ if (islimsk (i) == 0) edtmax = edtmaxs
+ if (cnvflg (i)) then
+ if (pwevo (i) < 0.) then
+ edto (i) = - edto (i) * pwavo (i) / pwevo (i)
+ edto (i) = min (edto (i), edtmax)
+ else
+ edto (i) = 0.
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft cloudwork functions
+ ! calculate downdraft cloud work function (\f$a_d\f$) according to equation a.42 (discretized by b.11) in grell (1993). add it to the updraft cloud work function, \f$a_u\f$.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ gamma = el2orc * qeso (i, k) / to (i, k) ** 2
+ dhh = hcdo (i, k)
+ dt = to (i, k)
+ dg = gamma
+ dh = heso (i, k)
+ dz = - 1. * (zo (i, k + 1) - zo (i, k))
+ ! aa1 (i) = aa1 (i) + edto (i) * dz * etad (i, k)
+ aa1 (i) = aa1 (i) + edto (i) * dz &
+ * (g / (cp_air * dt)) * ((dhh - dh) / (1. + dg)) &
+ * (1. + delta * cp_air * dg * dt / hlv)
+ val = 0.
+ ! aa1 (i) = aa1 (i) + edto (i) * dz * etad (i, k)
+ aa1 (i) = aa1 (i) + edto (i) * dz &
+ * g * delta * max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! check for negative total cloud work function; if found, return to calling routine without modifying state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i) .and. aa1 (i) <= 0.) then
+ cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! what would the change be, that a cloud with unit mass
+ ! will do to the environment?
+ ! calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux near the surface using equations b.18 and b.19 from grell (1993), for all layers below cloud top from equations b.14 and b.15, and for the cloud top from b.16 and b.17.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ dellah (i, k) = 0.
+ dellaq (i, k) = 0.
+ dellau (i, k) = 0.
+ dellav (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ dellae (i, k, n) = 0.
+ endif
+ enddo
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ dp = delp (i, 1)
+ dellah (i, 1) = edto (i) * etad (i, 1) * (hcdo (i, 1) &
+ - heo (i, 1)) * g / dp
+ dellaq (i, 1) = edto (i) * etad (i, 1) * (qrcdo (i, 1) &
+ - qo (i, 1)) * g / dp
+ dellau (i, 1) = edto (i) * etad (i, 1) * (ucdo (i, 1) &
+ - uo (i, 1)) * g / dp
+ dellav (i, 1) = edto (i) * etad (i, 1) * (vcdo (i, 1) &
+ - vo (i, 1)) * g / dp
+ endif
+ enddo
+
+ do n = 1, ntr
+ do i = 1, im
+ if (cnvflg (i)) then
+ dp = delp (i, 1)
+ dellae (i, 1, n) = edto (i) * etad (i, 1) * (ecdo (i, 1, n) &
+ - ctro (i, 1, n)) * g / dp
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! changed due to subsidence and entrainment
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k > jmin (i)) adw = 0.
+ dp = delp (i, k)
+ dz = zi (i, k) - zi (i, k - 1)
+
+ dv1h = heo (i, k)
+ dv2h = .5 * (heo (i, k) + heo (i, k - 1))
+ dv3h = heo (i, k - 1)
+ dv1q = qo (i, k)
+ dv2q = .5 * (qo (i, k) + qo (i, k - 1))
+ dv3q = qo (i, k - 1)
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1))
+ tem1 = 0.5 * (xlamud (i, k) + xlamud (i, k - 1))
+
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ if (k <= kbcon (i)) then
+ ptem = xlamdet (i)
+ ptem1 = xlamd (i) + xlamddt (i)
+ else
+ ptem = xlamdet (i)
+ ptem1 = xlamddt (i)
+ endif
+ else
+ if (k <= kbcon (i)) then
+ ptem = xlamde
+ ptem1 = xlamd (i) + xlamdd
+ else
+ ptem = xlamde
+ ptem1 = xlamdd
+ endif
+ endif
+
+ dellah (i, k) = dellah (i, k) + &
+ ((aup * eta (i, k) - adw * edto (i) * etad (i, k)) * dv1h &
+ - (aup * eta (i, k - 1) - adw * edto (i) * etad (i, k - 1)) * dv3h &
+ - (aup * tem * eta (i, k - 1) + adw * edto (i) * ptem * etad (i, k)) * dv2h * dz &
+ + aup * tem1 * eta (i, k - 1) * .5 * (hcko (i, k) + hcko (i, k - 1)) * dz &
+ + adw * edto (i) * ptem1 * etad (i, k) * .5 * (hcdo (i, k) + hcdo (i, k - 1)) * dz &
+ ) * g / dp
+
+ dellaq (i, k) = dellaq (i, k) + &
+ ((aup * eta (i, k) - adw * edto (i) * etad (i, k)) * dv1q &
+ - (aup * eta (i, k - 1) - adw * edto (i) * etad (i, k - 1)) * dv3q &
+ - (aup * tem * eta (i, k - 1) + adw * edto (i) * ptem * etad (i, k)) * dv2q * dz &
+ + aup * tem1 * eta (i, k - 1) * .5 * (qrcko (i, k) + qcko (i, k - 1)) * dz &
+ + adw * edto (i) * ptem1 * etad (i, k) * .5 * (qrcdo (i, k) + qcdo (i, k - 1)) * dz &
+ ) * g / dp
+
+ tem1 = eta (i, k) * (uo (i, k) - ucko (i, k))
+ tem2 = eta (i, k - 1) * (uo (i, k - 1) - ucko (i, k - 1))
+ ptem1 = etad (i, k) * (uo (i, k) - ucdo (i, k))
+ ptem2 = etad (i, k - 1) * (uo (i, k - 1) - ucdo (i, k - 1))
+ dellau (i, k) = dellau (i, k) + &
+ (aup * (tem1 - tem2) - adw * edto (i) * (ptem1 - ptem2)) * g / dp
+
+ tem1 = eta (i, k) * (vo (i, k) - vcko (i, k))
+ tem2 = eta (i, k - 1) * (vo (i, k - 1) - vcko (i, k - 1))
+ ptem1 = etad (i, k) * (vo (i, k) - vcdo (i, k))
+ ptem2 = etad (i, k - 1) * (vo (i, k - 1) - vcdo (i, k - 1))
+ dellav (i, k) = dellav (i, k) + &
+ (aup * (tem1 - tem2) - adw * edto (i) * (ptem1 - ptem2)) * g / dp
+
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k > jmin (i)) adw = 0.
+ dp = delp (i, k)
+ tem1 = eta (i, k) * (ctro (i, k, n) - ecko (i, k, n))
+ tem2 = eta (i, k - 1) * (ctro (i, k - 1, n) - ecko (i, k - 1, n))
+ ptem1 = etad (i, k) * (ctro (i, k, n) - ecdo (i, k, n))
+ ptem2 = etad (i, k - 1) * (ctro (i, k - 1, n) - ecdo (i, k - 1, n))
+ dellae (i, k, n) = dellae (i, k, n) + &
+ (aup * (tem1 - tem2) - adw * edto (i) * (ptem1 - ptem2)) * g / dp
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = ktcon (i)
+ dp = delp (i, indx)
+ dv1h = heo (i, indx - 1)
+ dellah (i, indx) = eta (i, indx - 1) * &
+ (hcko (i, indx - 1) - dv1h) * g / dp
+ dv1q = qo (i, indx - 1)
+ dellaq (i, indx) = eta (i, indx - 1) * &
+ (qcko (i, indx - 1) - dv1q) * g / dp
+ dellau (i, indx) = eta (i, indx - 1) * &
+ (ucko (i, indx - 1) - uo (i, indx - 1)) * g / dp
+ dellav (i, indx) = eta (i, indx - 1) * &
+ (vcko (i, indx - 1) - vo (i, indx - 1)) * g / dp
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! -----------------------------------------------------------------------
+
+ dellal (i, indx) = eta (i, indx - 1) * &
+ qlko_ktcon (i) * g / dp
+ endif
+ enddo
+
+ do n = 1, ntr
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = ktcon (i)
+ dp = delp (i, indx)
+ dellae (i, indx, n) = eta (i, indx - 1) * &
+ (ecko (i, indx - 1, n) - ctro (i, indx - 1, n)) * g / dp
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final changed variable per unit mass flux
+ ! if grid size is less than a threshold value (dxcrtas_deep: currently 8km), the quasi - equilibrium assumption of arakawa - schubert is not used any longer.
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! if grid size is less than a threshold value (dxcrtas_deep),
+ ! the quasi - equilibrium assumption of arakawa - schubert is not
+ ! used any longer.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ asqecflg (i) = cnvflg (i)
+ if (asqecflg (i) .and. gsize (i) < dxcrtas_deep) then
+ asqecflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if grid size is larger than the threshold value (i.e., asqecflg = .true.), the quasi - equilibrium assumption is used to obtain the cloud base mass flux. to begin with, calculate the change in the temperature and moisture profiles per unit cloud base mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i)) then
+ if (k > ktcon (i)) then
+ qo (i, k) = q1 (i, k)
+ to (i, k) = t1 (i, k)
+ endif
+ if (k <= ktcon (i)) then
+ qo (i, k) = dellaq (i, k) * mbdt (i) + q1 (i, k)
+ dellat = (dellah (i, k) - hlv * dellaq (i, k)) / cp_air
+ to (i, k) = dellat * mbdt (i) + t1 (i, k)
+ val = 1.e-10
+ qo (i, k) = max (qo (i, k), val)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! the above changed environment is now used to calulate the
+ ! effect the arbitrary cloud (with unit mass flux)
+ ! would have on the stability,
+ ! which then is used to calculate the real mass flux,
+ ! necessary to keep this change in balance with the large - scale
+ ! destabilization.
+ ! environmental conditions again, first heights
+ ! using the updated temperature and moisture profiles that were modified by the convection on a short time - scale, recalculate the total cloud work function to determine the change in the cloud work function due to convection, or the stabilizing effect of the cumulus.
+ ! using notation from pan and wu (1995), the previously calculated cloud work function is denoted by \f$a^ + \f$. now, it is necessary to use the entraining / detraining cloud model ("static control") to determine the cloud work function of the environment after the stabilization of the arbitrary convective element (per unit cloud base mass flux) has been applied, denoted by \f$a^ * \f$.
+ ! recalculate saturation specific humidity.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ ! tvo (i, k) = to (i, k) + delta * to (i, k) * qo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! moist static energy
+ ! recalculate moist static energy and saturation moist static energy.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i) - 1) then
+ dz = .5 * (zo (i, k + 1) - zo (i, k))
+ dp = .5 * (pfld (i, k + 1) - pfld (i, k))
+ es = 0.01 * mqs (to (i, k + 1)) ! mqs is in pa
+ pprime = pfld (i, k + 1) + epsm1 * es
+ qs = eps * es / pprime
+ dqsdp = - qs / pprime
+ desdt = es * (fact1 / to (i, k + 1) + fact2 / (to (i, k + 1) ** 2))
+ dqsdt = qs * pfld (i, k + 1) * desdt / (es * pprime)
+ gamma = el2orc * qeso (i, k + 1) / (to (i, k + 1) ** 2)
+ dt = (g * dz + hlv * dqsdp * dp) / (cp_air * (1. + gamma))
+ dq = dqsdt * dt + dqsdp * dp
+ to (i, k) = to (i, k + 1) + dt
+ qo (i, k) = qo (i, k + 1) + dq
+ po (i, k) = .5 * (pfld (i, k) + pfld (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i) - 1) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (po (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ heo (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qeso (i, k)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ k = kmax (i)
+ heo (i, k) = g * zo (i, k) + cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = g * zo (i, k) + cp_air * to (i, k) + hlv * qeso (i, k)
+ ! heo (i, k) = min (heo (i, k), heso (i, k))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! static control
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! moisture and cloud work functions
+ ! as before, recalculate the updraft cloud work function.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ xaa0 (i) = 0.
+ xpwav (i) = 0.
+ endif
+ enddo
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ indx = kb (i)
+ hcko (i, indx) = heo (i, indx)
+ qcko (i, indx) = qo (i, indx)
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (asqecflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ hcko (i, k) = ((1. - tem1) * hcko (i, k - 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k - 1))) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (asqecflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ xdby = hcko (i, k) - heso (i, k)
+ xqrch = qeso (i, k) &
+ + gamma * xdby / (hlv * (1. + gamma))
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+
+ dq = eta (i, k) * (qcko (i, k) - xqrch)
+
+ if (k >= kbcon (i) .and. dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ if (ncloud > 0 .and. k > jmin (i)) then
+ ptem = c0t (i, k) + c1_deep
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ if (k < ktcon1 (i)) then
+ ! xaa0 (i) = xaa0 (i) - dz * g * qlk * etah
+ xaa0 (i) = xaa0 (i) - dz * g * qlk
+ endif
+ qcko (i, k) = qlk + xqrch
+ xpw = etah * c0t (i, k) * dz * qlk
+ xpwav (i) = xpwav (i) + xpw
+ endif
+ endif
+ if (k >= kbcon (i) .and. k < ktcon1 (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ xaa0 (i) = xaa0 (i) &
+ ! + dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ + dz1 * (g / (cp_air * to (i, k))) &
+ * xdby / (1. + gamma) &
+ * rfact
+ val = 0.
+ xaa0 (i) = xaa0 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ dz1 * g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft calculations
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! downdraft moisture properties
+ ! as before, recalculate the downdraft cloud work function.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ jmn = jmin (i)
+ hcdo (i, jmn) = heo (i, jmn)
+ qcdo (i, jmn) = qo (i, jmn)
+ qrcd (i, jmn) = qo (i, jmn)
+ xpwev (i) = 0.
+ endif
+ enddo
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (asqecflg (i) .and. k < jmin (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ if (k >= kbcon (i)) then
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * xlamddt (i) * dz
+ else
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * (xlamd (i) + xlamddt (i)) * dz
+ endif
+ else
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ endif
+ factor = 1. + tem - tem1
+ hcdo (i, k) = ((1. - tem1) * hcdo (i, k + 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k + 1))) / factor
+ endif
+ enddo
+ enddo
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (asqecflg (i) .and. k < jmin (i)) then
+ dq = qeso (i, k)
+ dt = to (i, k)
+ gamma = el2orc * dq / dt ** 2
+ dh = hcdo (i, k) - heso (i, k)
+ qrcd (i, k) = dq + (1. / hlv) * (gamma / (1. + gamma)) * dh
+ ! detad = etad (i, k + 1) - etad (i, k)
+
+ dz = zi (i, k + 1) - zi (i, k)
+ ! kgao 12 / 18 / 2023
+ if (use_tke_conv) then
+ if (k >= kbcon (i)) then
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * xlamddt (i) * dz
+ else
+ tem = xlamdet (i) * dz
+ tem1 = 0.5 * (xlamd (i) + xlamddt (i)) * dz
+ endif
+ else
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ endif
+ factor = 1. + tem - tem1
+ qcdo (i, k) = ((1. - tem1) * qrcd (i, k + 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k + 1))) / factor
+
+ ! xpwd = etad (i, k + 1) * qcdo (i, k + 1) - &
+ ! etad (i, k) * qrcd (i, k)
+ ! xpwd = xpwd - detad * &
+ ! .5 * (qrcd (i, k) + qrcd (i, k + 1))
+
+ xpwd = etad (i, k) * (qcdo (i, k) - qrcd (i, k))
+ xpwev (i) = xpwev (i) + xpwd
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ edtmax = edtmaxl
+ if (islimsk (i) == 0) edtmax = edtmaxs
+ if (asqecflg (i)) then
+ if (xpwev (i) >= 0.) then
+ edtx (i) = 0.
+ else
+ edtx (i) = - edtx (i) * xpwav (i) / xpwev (i)
+ edtx (i) = min (edtx (i), edtmax)
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft cloudwork functions
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (asqecflg (i) .and. k < jmin (i)) then
+ gamma = el2orc * qeso (i, k) / to (i, k) ** 2
+ dhh = hcdo (i, k)
+ dt = to (i, k)
+ dg = gamma
+ dh = heso (i, k)
+ dz = - 1. * (zo (i, k + 1) - zo (i, k))
+ ! xaa0 (i) = xaa0 (i) + edtx (i) * dz * etad (i, k)
+ xaa0 (i) = xaa0 (i) + edtx (i) * dz &
+ * (g / (cp_air * dt)) * ((dhh - dh) / (1. + dg)) &
+ * (1. + delta * cp_air * dg * dt / hlv)
+ val = 0.
+ ! xaa0 (i) = xaa0 (i) + edtx (i) * dz * etad (i, k)
+ xaa0 (i) = xaa0 (i) + edtx (i) * dz &
+ * g * delta * max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate critical cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (pfld (i, ktcon (i)) < pcrit (15)) then
+ ! acrt (i) = acrit (15) * (975. - pfld (i, ktcon (i))) &
+ ! / (975. - pcrit (15))
+ ! else if (pfld (i, ktcon (i)) > pcrit (1)) then
+ ! acrt (i) = acrit (1)
+ ! else
+ ! k = int ((850. - pfld (i, ktcon (i))) / 50.) + 2
+ ! k = min (k, 15)
+ ! k = max (k, 2)
+ ! acrt (i) = acrit (k) + (acrit (k - 1) - acrit (k)) * &
+ ! (pfld (i, ktcon (i)) - pcrit (k)) / (pcrit (k - 1) - pcrit (k))
+ ! endif
+ ! endif
+ ! enddo
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (islimsk (i) == 1) then
+ ! w1 = w1l
+ ! w2 = w2l
+ ! w3 = w3l
+ ! w4 = w4l
+ ! else
+ ! w1 = w1s
+ ! w2 = w2s
+ ! w3 = w3s
+ ! w4 = w4s
+ ! endif
+
+ ! -----------------------------------------------------------------------
+ ! modify critical cloud workfunction by cloud base vertical velocity
+ ! -----------------------------------------------------------------------
+
+ ! if (pdot (i) <= w4) then
+ ! acrtfct (i) = (pdot (i) - w4) / (w3 - w4)
+ ! elseif (pdot (i) >= - w4) then
+ ! acrtfct (i) = - (pdot (i) + w4) / (w4 - w3)
+ ! else
+ ! acrtfct (i) = 0.
+ ! endif
+ ! val1 = - 1.
+ ! acrtfct (i) = max (acrtfct (i), val1)
+ ! val2 = 1.
+ ! acrtfct (i) = min (acrtfct (i), val2)
+ ! acrtfct (i) = 1. - acrtfct (i)
+
+ ! -----------------------------------------------------------------------
+ ! modify acrtfct (i) by colume mean rh if rhbar (i) is greater than 80 percent
+ ! -----------------------------------------------------------------------
+
+ ! if (rhbar (i) >= .8) then
+ ! acrtfct (i) = acrtfct (i) * (.9 - min (rhbar (i), .9)) * 10.
+ ! endif
+
+ ! -----------------------------------------------------------------------
+ ! modify adjustment time scale by cloud base vertical velocity
+ ! -----------------------------------------------------------------------
+
+ ! dtconv (i) = dt2 + max ((1800. - dt2), 0.) * &
+ ! (pdot (i) - w2) / (w1 - w2)
+ ! dtconv (i) = max (dtconv (i), dt2)
+ ! dtconv (i) = 1800. * (pdot (i) - w2) / (w1 - w2)
+
+ ! dtconv (i) = max (dtconv (i), dtmin)
+ ! dtconv (i) = min (dtconv (i), dtmax)
+
+ ! endif
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute convective turn - over time
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! following bechtold et al. (2008), the convective adjustment time (dtconv) is set to be proportional to the convective turnover time, which is computed using the mean updraft velocity (wc) and the cloud depth. it is also proportional to the grid size (gsize) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = zi (i, ktcon1 (i)) - zi (i, kbcon1 (i))
+ dtconv (i) = tem / wc (i)
+ tfac = 1. + gsize (i) / 75000.
+ dtconv (i) = tfac * dtconv (i)
+ dtconv (i) = max (dtconv (i), dtmin)
+ dtconv (i) = min (dtconv (i), dtmax)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate advective time scale (tauadv) using a mean cloud layer wind speed.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ umean (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon1 (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = sqrt (u1 (i, k) * u1 (i, k) + v1 (i, k) * v1 (i, k))
+ umean (i) = umean (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ umean (i) = umean (i) / sumx (i)
+ umean (i) = max (umean (i), 1.)
+ tauadv (i) = gsize (i) / umean (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! from han et al.'s (2017) equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi - equilibrium assumption of arakawa - schubert is not valid any longer.
+ ! as discussed in han et al. (2017), when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. in this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv.
+ ! compute cloud base mass flux as a function of the mean
+ ! updraft velcoity for the grid sizes where
+ ! the quasi - equilibrium assumption of arakawa - schubert is not
+ ! valid any longer.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i) .and. .not.asqecflg (i)) then
+ k = kbcon (i)
+ rho = po (i, k) * 100. / (rdgas * to (i, k))
+ tfac = tauadv (i) / dtconv (i)
+ tfac = min (tfac, 1.)
+ xmb (i) = tfac * betaw_deep * rho * wc (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud base mass flux using
+ ! the quasi - equilibrium assumption of arakawa - schubert
+ ! for the cases where the quasi - equilibrium assumption of arakawa - schubert is valid, first calculate the large scale destabilization as in equation 5 of pan and wu (1995):
+ ! \f[
+ ! \frac{\partial a}{\partial t}_{ls} = \frac{a^ + - ca^0}{\delta t_{ls}}
+ ! \f]
+ ! here \f$a^0\f$ is set to zero following han et al.'s (2017), implying that the instability is completely eliminated after the convective adjustment time, \f$\delta t_{ls}\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ ! fld (i) = (aa1 (i) - acrt (i) * acrtfct (i)) / dtconv (i)
+ fld (i) = aa1 (i) / dtconv (i)
+ if (fld (i) <= 0.) then
+ asqecflg (i) = .false.
+ cnvflg (i) = .false.
+ endif
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! calculate the stabilization effect of the convection (per unit cloud base mass flux) as in equation 6 of pan and wu (1995):
+ ! \f[
+ ! \frac{\partial a}{\partial t}_{cu} = \frac{a^ * - a^ + }{\delta t_{cu}}
+ ! \f]
+ ! \f$\delta t_{cu}\f$ is the short timescale of the convection.
+ ! -----------------------------------------------------------------------
+
+ if (asqecflg (i)) then
+ ! xaa0 (i) = max (xaa0 (i), 0.)
+ xk (i) = (xaa0 (i) - aa1 (i)) / mbdt (i)
+ if (xk (i) >= 0.) then
+ asqecflg (i) = .false.
+ cnvflg (i) = .false.
+ endif
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! kernel, cloud base mass flux
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! the cloud base mass flux (xmb) is then calculated from equation 7 of pan and wu (1995)
+ ! \f[
+ ! m_c = \frac{ - \frac{\partial a}{\partial t}_{ls}}{\frac{\partial a}{\partial t}_{cu}}
+ ! \f]
+ ! -----------------------------------------------------------------------
+ ! again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv.
+ ! -----------------------------------------------------------------------
+
+ if (asqecflg (i)) then
+ tfac = tauadv (i) / dtconv (i)
+ tfac = min (tfac, 1.)
+ xmb (i) = - tfac * fld (i) / xk (i)
+ ! xmb (i) = min (xmb (i), xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the large scale destabilization is less than zero, or the stabilization by the convection is greater than zero, then the scheme returns to the calling routine without modifying the state variables.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! modified grell & freitas' (2014) updraft fraction which uses
+ ! actual entrainment rate at cloud base
+ ! for scale - aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see han et al.'s (2017) equation 4 and 5), following the study by grell and freitas (2014).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = min (max (xlamue (i, kbcon (i)), 7.e-5), 3.e-4)
+ tem = 0.2 / tem
+ tem1 = 3.14 * tem * tem
+ sigmagfm (i) = tem1 / (gsize (i) ** 2.0)
+ sigmagfm (i) = max (sigmagfm (i), 0.001)
+ sigmagfm (i) = min (sigmagfm (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute scale - aware function based on arakawa & wu (2013)
+ ! then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by arakawa and wu (2013) (also see han et al.'s (2017) equation 1 and 2) . the final cloud base mass flux with scale - aware parameterization is obtained from the mass flux when sigmagfm < < 1, multiplied by the reduction factor (han et al.'s (2017) equation 2) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (gsize (i) < dxcrtuf) then
+ scaldfunc (i) = (1. - sigmagfm (i)) * (1. - sigmagfm (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ xmb (i) = xmb (i) * scaldfunc (i)
+ xmb (i) = min (xmb (i), xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! transport aerosols if present
+ ! -----------------------------------------------------------------------
+
+ if (do_aerosols) &
+ call sa_aamf_deep_aero (im, km, itc, ntc, ntr, delt, &
+ xlamde, xlamdd, cnvflg, jmin, kb, kmax, kbcon, ktcon, fscav, &
+ edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, &
+ qtr, qaero)
+
+ ! -----------------------------------------------------------------------
+ ! restore to, qo, uo, vo to t1, q1, u1, v1 in case convection stops
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ to (i, k) = t1 (i, k)
+ qo (i, k) = q1 (i, k)
+ uo (i, k) = u1 (i, k)
+ vo (i, k) = v1 (i, k)
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ ctro (i, k, n) = ctr (i, k, n)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! feedback: simply the changes from the cloud with unit mass flux
+ ! multiplied by the mass flux necessary to keep the
+ ! equilibrium with the larger - scale.
+ ! for the "feedback" control, calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control.
+ ! calculate the temperature tendency from the moist static energy and specific humidity tendencies.
+ ! update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux - normalized tendencies by the cloud base mass flux.
+ ! accumulate column - integrated tendencies.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ delhbar (i) = 0.
+ delqbar (i) = 0.
+ deltbar (i) = 0.
+ delubar (i) = 0.
+ delvbar (i) = 0.
+ qcond (i) = 0.
+ enddo
+
+ do n = 1, ntr
+ do i = 1, im
+ delebar (i, n) = 0.
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k <= ktcon (i)) then
+ dellat = (dellah (i, k) - hlv * dellaq (i, k)) / cp_air
+ t1 (i, k) = t1 (i, k) + dellat * xmb (i) * dt2
+ q1 (i, k) = q1 (i, k) + dellaq (i, k) * xmb (i) * dt2
+ ! tem = 1. / rcs (i)
+ ! u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2 * tem
+ ! v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2 * tem
+ u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2
+ v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2
+ dp = delp (i, k)
+ delhbar (i) = delhbar (i) + dellah (i, k) * xmb (i) * dp / g
+ delqbar (i) = delqbar (i) + dellaq (i, k) * xmb (i) * dp / g
+ deltbar (i) = deltbar (i) + dellat * xmb (i) * dp / g
+ delubar (i) = delubar (i) + dellau (i, k) * xmb (i) * dp / g
+ delvbar (i) = delvbar (i) + dellav (i, k) * xmb (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ kk = 0
+ do n = 1, ntr + 2
+ if (n .eq. ntw .or. n .eq. nti) cycle
+ kk = kk + 1
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k <= ktcon (i)) then
+ ctr (i, k, kk) = ctr (i, k, kk) + dellae (i, k, kk) * xmb (i) * dt2
+ delebar (i, kk) = delebar (i, kk) + dellae (i, k, kk) * xmb (i) * dp / g
+ qtr (i, k, n) = ctr (i, k, kk)
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity using the updated temperature.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k <= ktcon (i)) then
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! add up column - integrated convective precipitation by multiplying the normalized value by the cloud base mass flux.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ rntot (i) = 0.
+ delqev (i) = 0.
+ delq2 (i) = 0.
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k >= jmin (i)) adw = 0.
+ rain = aup * pwo (i, k) + adw * edto (i) * pwdo (i, k)
+ rntot (i) = rntot (i) + rain * xmb (i) * .001 * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine the evaporation of the convective precipitation and update the integrated convective precipitation.
+ ! update state temperature and moisture to account for evaporation of convective precipitation.
+ ! update column - integrated tendencies to account for evaporation of convective precipitation.
+ ! -----------------------------------------------------------------------
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (k <= kmax (i)) then
+ deltv (i) = 0.
+ delq (i) = 0.
+ qevap (i) = 0.
+ if (cnvflg (i) .and. k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k >= jmin (i)) adw = 0.
+ rain = aup * pwo (i, k) + adw * edto (i) * pwdo (i, k)
+ rn (i) = rn (i) + rain * xmb (i) * .001 * dt2
+ qr (i, k) = qr (i, k) + rain * xmb (i) * .001 * dt2
+ endif
+ if (flg (i) .and. k < ktcon (i)) then
+ evef = edt (i) * evfact_deep
+ if (islimsk (i) == 1) evef = edt (i) * evfactl_deep
+ ! if (islimsk (i) == 1) evef = .07
+ ! if (islimsk (i) == 1) evef = 0.
+ qcond (i) = evef * (q1 (i, k) - qeso (i, k)) &
+ / (1. + el2orc * qeso (i, k) / t1 (i, k) ** 2)
+ dp = delp (i, k)
+ if (rn (i) > 0. .and. qcond (i) < 0.) then
+ qevap (i) = - qcond (i) * (1. - exp (- .32 * sqrt (dt2 * rn (i))))
+ qevap (i) = min (qevap (i), rn (i) * 1000. * g / dp)
+ delq2 (i) = delqev (i) + .001 * qevap (i) * dp / g
+ endif
+ if (rn (i) > 0. .and. qcond (i) < 0. .and. delq2 (i) > rntot (i)) then
+ qevap (i) = 1000. * g * (rntot (i) - delqev (i)) / dp
+ flg (i) = .false.
+ endif
+ if (rn (i) > 0. .and. qevap (i) > 0.) then
+ q1 (i, k) = q1 (i, k) + qevap (i)
+ t1 (i, k) = t1 (i, k) - elocp * qevap (i)
+ rn (i) = rn (i) - .001 * qevap (i) * dp / g
+ qr (i, k) = qr (i, k) - .001 * qevap (i) * dp / g
+ deltv (i) = - elocp * qevap (i) / dt2
+ delq (i) = + qevap (i) / dt2
+ delqev (i) = delqev (i) + .001 * dp * qevap (i) / g
+ endif
+ delqbar (i) = delqbar (i) + delq (i) * dp / g
+ deltbar (i) = deltbar (i) + deltv (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! if (me == 31 .and. cnvflg (i)) then
+ ! if (cnvflg (i)) then
+ ! print *, ' deep delhbar, delqbar, deltbar = ', &
+ ! delhbar (i), hlv * delqbar (i), cp_air * deltbar (i)
+ ! print *, ' deep delubar, delvbar = ', delubar (i), delvbar (i)
+ ! print *, ' precip = ', hlv * rn (i) * 1000. / dt2
+ ! print *, 'pdif = ', pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ ! endif
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! precipitation rate converted to actual precip
+ ! in unit of m instead of kg
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ ! -----------------------------------------------------------------------
+ ! in the event of upper level rain evaporation and lower level downdraft
+ ! moistening, rn can become negative, in this case, we back out of the
+ ! heating and the moistening
+ ! -----------------------------------------------------------------------
+
+ if (rn (i) < 0. .and. .not.flg (i)) rn (i) = 0.
+ if (rn (i) <= 0.) then
+ rn (i) = 0.
+ else
+ ktop (i) = ktcon (i)
+ kbot (i) = kbcon (i)
+ kcnv (i) = 1
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud water
+ ! calculate convective cloud water.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvw (i, k) = cnvwt (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud cover
+ ! calculate convective cloud cover, which is used when pdf - based cloud fraction is used (i.e., pdfcld = .true.) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvc) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvc (i, k) = 0.04 * log (1. + 675. * eta (i, k) * xmb (i))
+ cnvc (i, k) = min (cnvc (i, k), 0.6)
+ cnvc (i, k) = max (cnvc (i, k), 0.0)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! separate detrained cloud water into liquid and ice species as a function of temperature only.
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) > 0.) then
+ ! if (k > kb (i) .and. k <= ktcon (i)) then
+ if (k >= kbcon (i) .and. k <= ktcon (i)) then
+ tem = dellal (i, k) * xmb (i) * dt2
+ qtr (i, k, ntw) = qtr (i, k, ntw) + tem
+ endif
+ endif
+ enddo
+ enddo
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! if convective precipitation is zero or negative, reset the updated state variables back to their original values (negating convective changes) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) <= 0.) then
+ if (k <= kmax (i)) then
+ t1 (i, k) = to (i, k)
+ q1 (i, k) = qo (i, k)
+ u1 (i, k) = uo (i, k)
+ v1 (i, k) = vo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ kk = 0
+ do n = 1, ntr + 2
+ if (n .eq. ntw .or. n .eq. nti) cycle
+ kk = kk + 1
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) <= 0.) then
+ if (k <= kmax (i)) then
+ ctr (i, k, kk) = ctro (i, k, kk)
+ qtr (i, k, n) = ctr (i, k, kk)
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! store aerosol concentrations if present
+ ! -----------------------------------------------------------------------
+
+ if (do_aerosols) then
+ do n = 1, ntc
+ kk = n + itc - 1
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) > 0.) then
+ if (k <= kmax (i)) qtr (i, k, kk) = qaero (i, k, n)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! calculate and retain the updraft and downdraft mass fluxes for dust transport by cumulus convection.
+ ! calculate the updraft convective mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= kb (i) .and. k < ktop (i)) then
+ ud_mf (i, k) = eta (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! save the updraft convective mass flux at cloud top.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (present (dt_mf) .and. present (ud_mf) .and. cnvflg (i) .and. rn (i) > 0.) then
+ k = ktop (i) - 1
+ dt_mf (i, k) = ud_mf (i, k)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the downdraft convective mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (dd_mf) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= 1 .and. k <= jmin (i)) then
+ dd_mf (i, k) = edto (i) * etad (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! include tke contribution from deep convection
+ ! -----------------------------------------------------------------------
+
+ if (ntk > 0) then
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) > 0.) then
+ if (k > kb (i) .and. k < ktop (i)) then
+ tem = 0.5 * (eta (i, k - 1) + eta (i, k)) * xmb (i)
+ tem1 = pfld (i, k) * 100. / (rdgas * t1 (i, k))
+ sigmagfm (i) = max (sigmagfm (i), betaw_deep)
+ ptem = tem / (sigmagfm (i) * tem1)
+ qtr (i, k, ntk) = qtr (i, k, ntk) + 0.5 * sigmagfm (i) * ptem * ptem
+ endif
+ endif
+ enddo
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) > 0.) then
+ if (k > 1 .and. k <= jmin (i)) then
+ tem = 0.5 * edto (i) * (etad (i, k - 1) + etad (i, k)) * xmb (i)
+ tem1 = pfld (i, k) * 100. / (rdgas * t1 (i, k))
+ sigmagfm (i) = max (sigmagfm (i), betaw_deep)
+ ptem = tem / (sigmagfm (i) * tem1)
+ qtr (i, k, ntk) = qtr (i, k, ntk) + 0.5 * sigmagfm (i) * ptem * ptem
+ endif
+ endif
+ enddo
+ enddo
+
+ endif
+
+end subroutine sa_aamf_deep
+
+! =======================================================================
+! Scale-Aware Aerosol-Aware Mass-Flux Shallow Convection
+!
+! The Scale-Aware Mass-Flux shallow (SAMF_shal) convection scheme is an updated version of the
+! previous mass-flux shallow convection scheme with scale and aerosol awareness and parameterizes
+! the effect of shallow convection on the environment. The SAMF_shal scheme is similar to the SAMF
+! deep convection scheme but with a few key differences.
+!
+! First, no quasi-equilibrium assumption is used for any grid size and the shallow cloud base mass
+! flux is parameterized using a mean updraft velocity. Further, there are no convective downdrafts,
+! the entrainment rate is greater than for deep convection, and the shallow convection is limited
+! to not extend over the level where \f$p = 0.7p_{sfc}\f$. The paramerization of scale and aerosol
+! awareness follows that of the samf deep convection scheme.
+!
+! The previous version of the shallow convection scheme (shalcnv.f) is described in Han and Pan
+! (2011) and differences between the shallow and deep convection schemes are presented in Han and
+! Pan (2011) and Han et al. (2017). Details of scale- and aerosol-aware parameterizations are
+! described in Han et al. (2017).
+!
+! In further update for FY19 GFS implementation, interaction with Turbulent Kinetic Energy (TKE),
+! which is a prognostic variable used in a scale-aware tke-based moist EDMF vertical turbulent
+! mixing scheme, is included. Entrainment rates in updrafts are proportional to sub-cloud mean TKE.
+! TKE is transported by cumulus convection. TKE contribution from cumulus convection is deduced
+! from cumulus mass flux. On the other hand, tracers such as ozone and aerosol are also transported
+! by cumulus convection.
+!
+! To reduce too much convective cooling at the cloud top, the convection schemes have been modified
+! for the rain conversion rate, entrainment and detrainment rates, overshooting layers, and maximum
+! allowable cloudbase mass flux (as of JUNE 2018) .
+!
+! contains the entire samf shallow convection scheme.
+!
+! This routine follows the SAMF deep scheme quite closely, although it can be interpreted as only
+! having the "static" and "feedback" control portions, since the "dynamic" control is not necessary
+! to find the cloud base mass flux. The algorithm is simplified from SAMF deep convection by
+! excluding convective downdrafts and being confined to operate below \f$p = 0.7p_{sfc}\f$. Also,
+! entrainment is both simpler and stronger in magnitude compared to the deep scheme.
+!
+! \param[in] IM number of used points
+! \param[in] KM vertical layer dimension
+! \param[in] DELT physics time step in seconds
+! \param[in] NTK index for tke
+! \param[in] NTR total number of tracers including tke
+! \param[in] DELP pressure difference between level k and k + 1 (pa)
+! \param[in] PRSLP mean layer presure (pa)
+! \param[in] PSP surface pressure (pa)
+! \param[in] PHIL layer geopotential (\f$m^s / s^2\f$)
+! \param[in] QTR tracer array including cloud condensate (\f$kg / kg\f$)
+! \param[inout] QL cloud water or ice (kg / kg)
+! \param[inout] Q1 updated tracers (kg / kg)
+! \param[inout] T1 updated temperature (k)
+! \param[inout] U1 updated zonal wind (\f$m s^{ - 1}\f$)
+! \param[inout] V1 updated meridional wind (\f$m s^{ - 1}\f$)
+! \param[out] RN convective rain (m)
+! \param[out] KBOT index for cloud base
+! \param[out] KTOP index for cloud top
+! \param[out] KCNV flag to denote deep convection (0 = no, 1 = yes)
+! \param[in] ISLIMSK sea / land / ice mask (= 0 / 1 / 2)
+! \param[in] DOT layer mean vertical velocity (pa / s)
+! \param[in] NCLOUD number of cloud species
+! \param[in] HPBL pbl height (m)
+! \param[in] HEAT surface sensible heat flux (k m / s)
+! \param[in] EVAP surface latent heat flux (kg / kg m / s)
+! \param[out] UD_MF updraft mass flux multiplied by time step (\f$kg / m^2\f$)
+! \param[out] DT_MF ud_mf at cloud top (\f$kg / m^2\f$)
+! \param[out] CNVW convective cloud water (kg / kg)
+! \param[out] CNVC convective cloud cover (unitless)
+!
+! General Algorithm
+! # Compute preliminary quantities needed for the static and feedback control portions of the algorithm.
+! # Perform calculations related to the updraft of the entraining / detraining cloud model ("static control") .
+! # The cloud base mass flux is obtained using the cumulus updraft velocity averaged ove the whole cloud depth.
+! # Calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux.
+! # For the "feedback control", calculate updated values of the state variables by multiplying the cloud base
+! mass flux and the tendencies calculated per unit cloud base mass flux from the static control.
+! =======================================================================
+
+subroutine sa_aamf_shal (im, km, delt, itc, ntc, ntw, nti, ntk, ntr, delp, &
+ prslp, psp, phil, qtr, q1, t1, u1, v1, qr, fscav, rn, kbot, ktop, &
+ kcnv, islimsk, gsize, dot, ncloud, hpbl, ud_mf, dt_mf, cnvw, cnvc)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, itc, ntc, ntw, nti, ntk, ntr, ncloud, islimsk (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: psp (im), delp (im, km), &
+ prslp (im, km), gsize (im), hpbl (im), dot (im, km), phil (im, km)
+ real, intent (in) :: fscav (ntc)
+
+ integer, intent (inout) :: kbot (im), ktop (im), kcnv (im)
+
+ real, intent (inout) :: qtr (im, km, ntr + 2), q1 (im, km), t1 (im, km), &
+ u1 (im, km), v1 (im, km)
+
+ real, intent (out) :: rn (im), qr (im, km)
+ real, intent (out), optional :: cnvw (im, km), cnvc (im, km), &
+ ! hchuang code change mass flux output
+ ud_mf (im, km), dt_mf (im, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, j, indx, k, kk, km1, n
+ integer :: kpbl (im)
+
+ real :: clamd, tkemx, tkemn, dtke
+
+ real :: dellat, delta, &
+ c0l, d0, &
+ desdt, dp, &
+ dq, dqsdp, dqsdt, dt, &
+ dt2, dtmax, dtmin, &
+ dv1h, dv2h, dv3h, &
+ dv1q, dv2q, dv3q, &
+ dz, dz1, e1, &
+ el2orc, elocp, aafac, cm, &
+ es, etah, h1, &
+ evef, fact1, &
+ fact2, factor, dthk, &
+ g, gamma, pprime, &
+ qlk, qrch, qs, &
+ rfact, shear, tfac, &
+ val, val1, val2, &
+ w1, w1l, w1s, w2, &
+ w2l, w2s, w3, w3l, &
+ w3s, w4, w4l, w4s, &
+ rho, tem, tem1, tem2, &
+ ptem, ptem1
+
+ integer :: kb (im), kbcon (im), kbcon1 (im), &
+ ktcon (im), ktcon1 (im), ktconn (im), &
+ kbm (im), kmax (im)
+
+ real :: aa1 (im), cina (im), &
+ tkemean (im), clamt (im), &
+ umean (im), tauadv (im), &
+ delhbar (im), delq (im), delq2 (im), &
+ delqbar (im), delqev (im), deltbar (im), &
+ deltv (im), dtconv (im), edt (im), &
+ pdot (im), po (im, km), &
+ qcond (im), qevap (im), hmax (im), &
+ rntot (im), vshear (im), &
+ xlamud (im), xmb (im), xmbmax (im), &
+ delebar (im, ntr), &
+ delubar (im), delvbar (im)
+
+ real :: c0 (im)
+
+ real :: crtlamd
+
+ real :: cinpcr, cinpcrmx, cinpcrmn, &
+ cinacr, cinacrmx, cinacrmn
+
+ ! parameters for updraft velocity calculation
+ real :: bet1, cd1, f1, gam1, &
+ bb1, bb2, tkcrt, cmxfac, csmf
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (elocp = hlv / cp_air, &
+ el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (d0 = .001)
+
+ ! asolfac_shal: aerosol - aware parameter based on lim & hong (2012)
+ ! asolfac_shal = cx / c0s_shal (= .002)
+ ! cx = min ([ - 0.7 ln (nccn) + 24] * 1.e-4, c0s_shal)
+ ! nccn: ccn number concentration in cm^ (- 3)
+ ! until a realistic nccn is provided, typical nccns are assumed
+ ! as nccn = 100 for sea and nccn = 1000 for land
+
+ parameter (cm = 1.0, delta = zvir)
+ parameter (fact1 = (cp_vap - c_liq) / rvgas, fact2 = hlv / rvgas - fact1 * tice)
+ parameter (clamd = 0.1, tkemx = 0.65, tkemn = 0.05)
+ parameter (dtke = tkemx - tkemn)
+ parameter (dthk = 25.)
+ parameter (cinpcrmx = 180., cinpcrmn = 120.)
+ parameter (cinacrmx = - 120., cinacrmn = - 80.)
+ parameter (crtlamd = 3.e-4)
+ parameter (dtmax = 10800., dtmin = 600.)
+ parameter (bet1 = 1.875, cd1 = .506, f1 = 2.0, gam1 = .5)
+ parameter (h1 = 0.33333333)
+ parameter (bb1 = 4.0, bb2 = 0.8, csmf = 0.2)
+ parameter (tkcrt = 2., cmxfac = 15.)
+
+ ! local variables and arrays
+ real :: pfld (im, km), to (im, km), qo (im, km), &
+ uo (im, km), vo (im, km), qeso (im, km), &
+ ctr (im, km, ntr), ctro (im, km, ntr)
+
+ ! for aerosol transport
+ real :: qaero (im, km, ntc)
+
+ ! for updraft velocity calculation
+ real :: wu2 (im, km), buo (im, km), drag (im, km), wush (im, km)
+ real :: wc (im), scaldfunc (im), sigmagfm (im)
+
+ ! cloud water
+ ! real :: tvo (im, km),
+ real :: qlko_ktcon (im), dellal (im, km), &
+ dbyo (im, km), zo (im, km), xlamue (im, km), &
+ heo (im, km), heso (im, km), &
+ dellah (im, km), dellaq (im, km), &
+ dellae (im, km, ntr), &
+ dellau (im, km), dellav (im, km), hcko (im, km), &
+ ucko (im, km), vcko (im, km), qcko (im, km), &
+ qrcko (im, km), eta (im, km), &
+ ecko (im, km, ntr), &
+ zi (im, km), pwo (im, km), c0t (im, km), &
+ sumx (im), tx1 (im), cnvwt (im, km)
+
+ logical :: do_aerosols, totflg, cnvflg (im), flg (im)
+
+ real :: tf, tcr, tcrf
+ parameter (tf = 233.16, tcr = 263.16, tcrf = 1.0 / (tcr - tf))
+
+ ! -----------------------------------------------------------------------
+ ! determine whether to perform aerosol transport
+ ! -----------------------------------------------------------------------
+
+ do_aerosols = (itc > 0) .and. (ntc > 0) .and. (ntr > 0)
+ if (do_aerosols) do_aerosols = (ntr >= itc + ntc - 3)
+
+ ! -----------------------------------------------------------------------
+ ! convert input pa terms to cb terms -- moorthi
+ ! compute preliminary quantities needed for the static and feedback control portions of the algorithm.
+ ! convert input pressure terms to centibar units.
+ ! -----------------------------------------------------------------------
+
+ km1 = km - 1
+
+ ! -----------------------------------------------------------------------
+ ! initialize arrays
+ ! initialize column - integrated and other single - value - per - column variable arrays.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ cnvflg (i) = .true.
+ if (kcnv (i) == 1) cnvflg (i) = .false.
+ if (cnvflg (i)) then
+ kbot (i) = km + 1
+ ktop (i) = 0
+ endif
+ rn (i) = 0.
+ kbcon (i) = km
+ ktcon (i) = 1
+ ktconn (i) = 1
+ kb (i) = km
+ pdot (i) = 0.
+ qlko_ktcon (i) = 0.
+ edt (i) = 0.
+ aa1 (i) = 0.
+ cina (i) = 0.
+ vshear (i) = 0.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! return to the calling routine if deep convection is present or the surface buoyancy flux is negative.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine aerosol - aware rain conversion parameter over land
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (islimsk (i) == 1) then
+ c0 (i) = c0s_shal * asolfac_shal
+ else
+ c0 (i) = c0s_shal
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from han et al.'s (2017) equation 8.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (t1 (i, k) > 273.16) then
+ c0t (i, k) = c0 (i)
+ else
+ tem = d0 * (t1 (i, k) - 273.16)
+ tem1 = exp (tem)
+ c0t (i, k) = c0 (i) * tem1
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! initialize convective cloud water and cloud cover to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw)) cnvw (i, k) = 0.
+ if (present (cnvc)) cnvc (i, k) = 0.
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ qr (i, k) = 0.
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! initialize updraft mass fluxes to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf)) ud_mf (i, k) = 0.
+ if (present (dt_mf)) dt_mf (i, k) = 0.
+ enddo
+ enddo
+
+ dt2 = delt
+
+ ! -----------------------------------------------------------------------
+ ! model tunable parameters are all here
+ ! -----------------------------------------------------------------------
+
+ ! clam_shal = .3
+ aafac = .05
+ ! evef = 0.07
+ ! evfact_shal = 0.3
+ ! evfactl_shal = 0.3
+
+ ! pgcon_shal = 0.7 ! gregory et al. (1997, qjrms)
+ ! pgcon_shal = 0.55 ! zhang & wu (2003, jas)
+
+ w1l = - 8.e-3
+ w2l = - 4.e-2
+ w3l = - 5.e-3
+ w4l = - 5.e-4
+ w1s = - 2.e-4
+ w2s = - 2.e-3
+ w3s = - 1.e-3
+ w4s = - 2.e-5
+
+ ! -----------------------------------------------------------------------
+ ! define top layer for search of the downdraft originating layer
+ ! and the maximum thetae for updraft
+ ! determine maximum indices for the parcel starting point (kbm) and cloud top (kmax) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ kbm (i) = km
+ kmax (i) = km
+ tx1 (i) = 1.0 / psp (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (prslp (i, k) * tx1 (i) > 0.70) kbm (i) = k + 1
+ if (prslp (i, k) * tx1 (i) > 0.60) kmax (i) = k + 1
+ enddo
+ enddo
+
+ do i = 1, im
+ kbm (i) = min (kbm (i), kmax (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hydrostatic height assume zero terr and compute
+ ! updraft entrainment rate as an inverse function of height
+ ! calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ zo (i, k) = phil (i, k) / g
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate interface height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ zi (i, k) = 0.5 * (zo (i, k) + zo (i, k + 1))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! pbl height
+ ! find the index for the pbl top using the pbl height; enforce that it is lower than the maximum parcel starting level.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ kpbl (i) = 1
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. zo (i, k) <= hpbl (i)) then
+ kpbl (i) = k
+ else
+ flg (i) = .false.
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ kpbl (i) = min (kpbl (i), kbm (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convert surface pressure to mb from cb
+ ! convert prslp from centibar to millibar, set normalized mass flux to 1, cloud properties to 0, and save model state variables (after advection / turbulence) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ pfld (i, k) = prslp (i, k) * 0.01
+ eta (i, k) = 1.
+ hcko (i, k) = 0.
+ qcko (i, k) = 0.
+ qrcko (i, k) = 0.
+ ucko (i, k) = 0.
+ vcko (i, k) = 0.
+ dbyo (i, k) = 0.
+ pwo (i, k) = 0.
+ dellal (i, k) = 0.
+ to (i, k) = t1 (i, k)
+ qo (i, k) = q1 (i, k)
+ uo (i, k) = u1 (i, k)
+ vo (i, k) = v1 (i, k)
+ ! uo (i, k) = u1 (i, k) * rcs (i)
+ ! vo (i, k) = v1 (i, k) * rcs (i)
+ wu2 (i, k) = 0.
+ buo (i, k) = 0.
+ drag (i, k) = 0.
+ cnvwt (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! initialize tracer variables
+ ! -----------------------------------------------------------------------
+
+ kk = 0
+ do n = 1, ntr + 2
+ if (n .eq. ntw .or. n .eq. nti) cycle
+ kk = kk + 1
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ ctr (i, k, kk) = qtr (i, k, n)
+ ctro (i, k, kk) = qtr (i, k, n)
+ ecko (i, k, kk) = 0.
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! column variables
+ ! p is pressure of the layer (mb)
+ ! t is temperature at t - dt (k) ..tn
+ ! q is mixing ratio at t - dt (kg / kg) ..qn
+ ! to is temperature at t + dt (k) ... this is after advection and turbulan
+ ! qo is mixing ratio at t + dt (kg / kg) ..q1
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate saturation specific humidity and enforce minimum moisture values.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ ! tvo (i, k) = to (i, k) + delta * to (i, k) * qo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute moist static energy
+ ! calculate moist static energy (heo) and saturation moist static energy (heso) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ ! tem = g * zo (i, k) + cp_air * to (i, k)
+ tem = phil (i, k) + cp_air * to (i, k)
+ heo (i, k) = tem + hlv * qo (i, k)
+ heso (i, k) = tem + hlv * qeso (i, k)
+ ! heo (i, k) = min (heo (i, k), heso (i, k))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine level with largest moist static energy within pbl
+ ! this is the level where updraft starts
+ ! perform calculations related to the updraft of the entraining / detraining cloud model ("static control") .
+ ! search in the pbl for the level of maximum moist static energy to start the ascending parcel.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ hmax (i) = heo (i, 1)
+ kb (i) = 1
+ endif
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ if (heo (i, k) > hmax (i)) then
+ kb (i) = k
+ hmax (i) = heo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the temperature, water vapor mixing ratio, and pressure at interface levels.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ dz = .5 * (zo (i, k + 1) - zo (i, k))
+ dp = .5 * (pfld (i, k + 1) - pfld (i, k))
+ es = 0.01 * mqs (to (i, k + 1)) ! mqs is in pa
+ pprime = pfld (i, k + 1) + epsm1 * es
+ qs = eps * es / pprime
+ dqsdp = - qs / pprime
+ desdt = es * (fact1 / to (i, k + 1) + fact2 / (to (i, k + 1) ** 2))
+ dqsdt = qs * pfld (i, k + 1) * desdt / (es * pprime)
+ gamma = el2orc * qeso (i, k + 1) / (to (i, k + 1) ** 2)
+ dt = (g * dz + hlv * dqsdp * dp) / (cp_air * (1. + gamma))
+ dq = dqsdt * dt + dqsdp * dp
+ to (i, k) = to (i, k + 1) + dt
+ qo (i, k) = qo (i, k + 1) + dq
+ po (i, k) = .5 * (pfld (i, k) + pfld (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. enforce minimum specific humidity.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (po (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ heo (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qeso (i, k)
+ uo (i, k) = .5 * (uo (i, k) + uo (i, k + 1))
+ vo (i, k) = .5 * (vo (i, k) + vo (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ ctro (i, k, n) = .5 * (ctro (i, k, n) + ctro (i, k + 1, n))
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! look for the level of free convection as cloud base
+ ! search below the index "kbm" for the level of free convection (lfc) where the condition \f$h_b > h^ * \f$ is first met, where \f$h_b, h^ * \f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. set "kbcon" to the index of the lfc.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ if (flg (i)) kbcon (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kbm (i)) then
+ if (k > kb (i) .and. heo (i, kb (i)) > heso (i, k)) then
+ kbcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kbcon (i) == kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if no lfc, return to the calling routine without modifying state variables.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine the vertical pressure velocity at the lfc. after han and pan (2011), determine the maximum pressure thickness between a parcel's starting level and the lfc. if a parcel doesn't reach the lfc within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! pdot (i) = 10. * dot (i, kbcon (i))
+ pdot (i) = 0.01 * dot (i, kbcon (i)) ! now dot is in pa / s
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if pressure depth between parcel source level
+ ! and cloud base is larger than a critical value, cinpcr
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ ptem = 1. - tem
+ ptem1 = .5 * (cinpcrmx - cinpcrmn)
+ cinpcr = cinpcrmx - ptem * ptem1
+ tem1 = pfld (i, kb (i)) - pfld (i, kbcon (i))
+ if (tem1 > cinpcr) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! turbulent entrainment rate assumed to be proportional
+ ! to subcloud mean tke
+ ! -----------------------------------------------------------------------
+
+ if (ntk > 0) then
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ tkemean (i) = 0.
+ endif
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kb (i) .and. k < kbcon (i)) then
+ dz = zo (i, k + 1) - zo (i, k)
+ tem = 0.5 * (qtr (i, k, ntk) + qtr (i, k + 1, ntk))
+ tkemean (i) = tkemean (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ tkemean (i) = tkemean (i) / sumx (i)
+ if (tkemean (i) > tkemx) then
+ clamt (i) = clam_shal + clamd
+ else if (tkemean (i) < tkemn) then
+ clamt (i) = clam_shal - clamd
+ else
+ tem = tkemx - tkemean (i)
+ tem1 = 1. - 2. * tem / dtke
+ clamt (i) = clam_shal + clamd * tem1
+ endif
+ endif
+ enddo
+ ! kgao 12 / 18 / 2023 - adjust entrainment rate based on tke
+ if (use_tke_conv) then
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (tkemean (i) > tkcrt) then
+ tem = 1. + tkemean (i) / tkcrt
+ tem1 = min (tem, cmxfac)
+ clamt (i) = tem1 * clam_shal
+ endif
+ endif
+ enddo
+ endif
+ else
+ do i = 1, im
+ if (cnvflg (i)) then
+ clamt (i) = clam_shal
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! assume updraft entrainment rate
+ ! is an inverse function of height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamue (i, k) = clamt (i) / zi (i, k)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamue (i, km) = xlamue (i, km1)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify the detrainment rate for the updrafts
+ ! (the updraft detrainment rate is set constant and equal to the entrainment rate at cloud base.)
+ ! the updraft detrainment rate is vertically constant and proportional to clamt
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! xlamud (i) = xlamue (i, kbcon (i))
+ ! xlamud (i) = crtlamd
+ xlamud (i) = 0.001 * clamt (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine updraft mass flux for the subcloud layers
+ ! calculate the normalized mass flux for subcloud and in - cloud layers according to pan and wu (1995) equation 1:
+ ! \f[
+ ! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d
+ ! \f]
+ ! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate. the normalized mass flux increases upward below the cloud base and decreases upward above.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < kbcon (i) .and. k >= kb (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k + 1)) - xlamud (i)
+ eta (i, k) = eta (i, k + 1) / (1. + ptem * dz)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute mass flux above cloud base
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k > kbcon (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) - xlamud (i)
+ eta (i, k) = eta (i, k - 1) * (1 + ptem * dz)
+ if (eta (i, k) <= 0.) then
+ kmax (i) = k
+ ktconn (i) = k
+ kbm (i) = min (kbm (i), kmax (i))
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft cloud property
+ ! set cloud properties equal to the state variables at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = kb (i)
+ hcko (i, indx) = heo (i, indx)
+ ucko (i, indx) = uo (i, indx)
+ vcko (i, indx) = vo (i, indx)
+ endif
+ enddo
+
+ ! for tracers
+ do n = 1, ntr
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = kb (i)
+ ecko (i, indx, n) = ctro (i, indx, n)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cm is an enhancement factor in entrainment rates for momentum
+ ! calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. discretization follows appendix b of grell (1993). following han and pan (2006), the convective momentum transport is reduced by the convection - induced pressure gradient force by the constant "pgcon_shal", currently set to 0.55 after zhang and wu (2003).
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.5 * xlamud (i) * dz
+ factor = 1. + tem - tem1
+ hcko (i, k) = ((1. - tem1) * hcko (i, k - 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k - 1))) / factor
+ dbyo (i, k) = hcko (i, k) - heso (i, k)
+
+ tem = 0.5 * cm * tem
+ factor = 1. + tem
+ ptem = tem + pgcon_shal
+ ptem1 = tem - pgcon_shal
+ ucko (i, k) = ((1. - tem) * ucko (i, k - 1) + ptem * uo (i, k) &
+ + ptem1 * uo (i, k - 1)) / factor
+ vcko (i, k) = ((1. - tem) * vcko (i, k - 1) + ptem * vo (i, k) &
+ + ptem1 * vo (i, k - 1)) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.25 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ factor = 1. + tem
+ ecko (i, k, n) = ((1. - tem) * ecko (i, k - 1, n) + tem * &
+ (ctro (i, k, n) + ctro (i, k - 1, n))) / factor
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! taking account into convection inhibition due to existence of
+ ! dry layers below cloud base
+ ! with entrainment, recalculate the lfc as the first level where buoyancy is positive. the difference in pressure levels between lfcs calculated with / without entrainment must be less than a threshold (currently 25 hpa) . otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. this is the subcloud dryness trigger modification discussed in han and pan (2011).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ kbcon1 (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kbm (i)) then
+ if (k >= kbcon (i) .and. dbyo (i, k) > 0.) then
+ kbcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kbcon1 (i) == kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = pfld (i, kbcon (i)) - pfld (i, kbcon1 (i))
+ if (tem > dthk) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! calculate convective inhibition
+ ! calculate additional trigger condition of the convective inhibition (cin) according to han et al.'s (2017) equation 13.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kbcon1 (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ dz1 * g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if the cin is less than a critical value (cinacr) which is inversely proportional to the large - scale vertical velocity.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ tem = 1. - tem
+ tem1 = .5 * (cinacrmx - cinacrmn)
+ cinacr = cinacrmx - tem * tem1
+
+ ! cinacr = cinacrmx
+ if (cina (i) < cinacr) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine first guess cloud top as the level of zero buoyancy
+ ! limited to the level of p / ps = 0.7
+ ! calculate the cloud top as the first level where parcel buoyancy becomes negative; the maximum possible value is at \f$p = 0.7p_{sfc}\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ if (flg (i)) ktcon (i) = kbm (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kbm (i)) then
+ if (k > kbcon1 (i) .and. dbyo (i, k) < 0.) then
+ ktcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ ! kg change: turn off shal conv based on diagnosed cloud depth or top
+ ! the idea here is that if the cloud is too deep or too high, it should not be
+ ! handled by shal conv
+ do i = 1, im
+ if (cnvflg (i) .and. limit_shal_conv) then
+ ! a) cloud depth criterion as in deep conv
+ tem = pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ if (tem >= cthk_shal) cnvflg (i) = .false.
+ ! b) cloud top criterion
+ if (prslp (i, ktcon (i)) * tx1 (i) < top_shal) cnvflg (i) = .false.
+ !if (ktcon (i) > kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify upper limit of mass flux at cloud base
+ ! calculate the maximum value of the cloud base mass flux using the cfl - criterion - based formula of han and pan (2011), equation 7.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! xmbmax (i) = .1
+ !
+ k = kbcon (i)
+ dp = delp (i, k)
+ xmbmax (i) = dp / (2. * g * dt2)
+ ! xmbmax (i) = dp / (g * dt2)
+ !
+ ! tem = dp / (g * dt2)
+ ! xmbmax (i) = min (tem, xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property and precipitation
+ ! set cloud moisture property equal to the enviromental moisture at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = 0.
+ qcko (i, kb (i)) = qo (i, kb (i))
+ qrcko (i, kb (i)) = qo (i, kb (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the moisture content of the entraining / detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation a.14 in grell (1993). their difference is the amount of convective cloud water (qlk = rain + condensate) . determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo) . calculate and save the negative cloud work function (aa1) due to water loading. above the level of minimum moist static energy, some of the cloud water is detrained into the grid - scale cloud water from every cloud layer with a rate of 0.0005 \f$m^{ - 1}\f$ (dellal) .
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.5 * xlamud (i) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! rhbar (i) = rhbar (i) + qo (i, k) / qeso (i, k)
+
+ ! -----------------------------------------------------------------------
+ ! below lfc check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i) .and. dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0) then
+ ptem = c0t (i, k) + c1_shal
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_shal * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ buo (i, k) = buo (i, k) - g * qlk
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy and drag for updraft velocity
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i)) then
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ buo (i, k) = buo (i, k) + (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ buo (i, k) = buo (i, k) + g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ drag (i, k) = max (xlamue (i, k), xlamud (i))
+ ! kgao 12 / 18 / 2023
+ tem = ((uo (i, k) - uo (i, k - 1)) / dz) ** 2
+ tem = tem + ((vo (i, k) - vo (i, k - 1)) / dz) ** 2
+ wush (i, k) = csmf * sqrt (tem)
+ endif
+
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! do k = 2, km1
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (k >= kbcon (i) .and. k < ktcon (i)) then
+ ! dz1 = zo (i, k + 1) - zo (i, k)
+ ! gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ ! rfact = 1. + delta * cp_air * gamma &
+ ! * to (i, k) / hlv
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ ! dz1 * (g / (cp_air * to (i, k))) &
+ ! * dbyo (i, k) / (1. + gamma) &
+ ! * rfact
+ ! val = 0.
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+ ! do i = 1, im
+ ! if (cnvflg (i) .and. aa1 (i) <= 0.) cnvflg (i) = .false.
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+
+ ! -----------------------------------------------------------------------
+ ! calculate the cloud work function according to pan and wu (1995) equation 4:
+ ! \f[
+ ! a_u = \int_{z_0}^{z_t}\frac{g}{c_pt (z) }\frac{\eta}{1 + \gamma}[h (z) - h^ * (z) ]dz
+ ! \f]
+ ! (discretized according to grell (1993) equation b.10 using b.2 and b.3 of arakawa and schubert (1974) and assuming \f$\eta = 1\f$) where \f$a_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{l}{c_p}\left (\frac{\partial \overline{q_s}}{\partial t}\right) _p\f$ and other quantities are previously defined.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ aa1 (i) = aa1 (i) + buo (i, k) * dz1
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i) .and. aa1 (i) <= 0.) cnvflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! estimate the onvective overshooting as the level
+ ! where the [aafac * cloud work function] becomes zero,
+ ! which is the final cloud top
+ ! limited to the level of p / ps = 0.7
+ ! continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to han and pan (2011). convective overshooting stops when \f$ ca_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force. overshooting is also limited to the level where \f$p = 0.7p_{sfc}\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = aafac * aa1 (i)
+ endif
+ enddo
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ ktcon1 (i) = kbm (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k >= ktcon (i) .and. k < kbm (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ ! val = 0.
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ if (aa1 (i) < 0.) then
+ ktcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property, detraining cloud water
+ ! and precipitation in overshooting layers
+ ! for the overshooting convection, calculate the moisture content of the entraining / detraining parcel as before. partition convective cloud water and precipitation and detrain convective cloud water in the overshooting layers.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= ktcon (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.5 * xlamud (i) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0) then
+ ptem = c0t (i, k) + c1_shal
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_shal * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity square (wu2)
+ ! calculate updraft velocity square (wu2) according to han et al.'s (2017) equation 7.
+ ! -----------------------------------------------------------------------
+
+ ! bb1 = 2. * (1. + bet1 * cd1)
+ ! bb2 = 2. / (f1 * (1. + gam1))
+
+ ! bb1 = 3.9
+ ! bb2 = 0.67
+
+ ! bb1 = 2.0
+ ! bb2 = 4.0
+
+ ! bb1 = 4.0
+ ! bb2 = 0.8
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! k = kbcon1 (i)
+ ! tem = po (i, k) / (rdgas * to (i, k))
+ ! wucb = - 0.01 * dot (i, k) / (tem * g)
+ ! if (wucb > 0.) then
+ ! wu2 (i, k) = wucb * wucb
+ ! else
+ ! wu2 (i, k) = 0.
+ ! endif
+ ! endif
+ ! enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.25 * bb1 * (drag (i, k) + drag (i, k - 1)) * dz
+ tem1 = 0.5 * bb2 * (buo (i, k) + buo (i, k - 1)) * dz
+ ! kgao 12 / 18 / 2023 - considers shear effect on updraft
+ if (use_shear_conv) then
+ tem2 = wush (i, k) * sqrt (wu2 (i, k - 1))
+ tem2 = (tem1 - tem2) * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem2) / ptem1
+ else
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ endif
+ wu2 (i, k) = max (wu2 (i, k), 0.)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity averaged over the whole cumulus
+ ! calculate the mean updraft velocity within the cloud (wc) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ wc (i) = 0.
+ sumx (i) = 0.
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (sqrt (wu2 (i, k)) + sqrt (wu2 (i, k - 1)))
+ wc (i) = wc (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sumx (i) == 0.) then
+ cnvflg (i) = .false.
+ else
+ wc (i) = wc (i) / sumx (i)
+ endif
+ val = 1.e-4
+ if (wc (i) < val) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! exchange ktcon with ktcon1
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = ktcon (i)
+ ktcon (i) = ktcon1 (i)
+ ktcon1 (i) = kk
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! this section is ready for cloud water
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ ! -----------------------------------------------------------------------
+ ! compute liquid and vapor separation at cloud top
+ ! separate the total updraft cloud water at cloud top into vapor and condensate.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = ktcon (i) - 1
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ dq = qcko (i, k) - qrch
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ qlko_ktcon (i) = dq
+ qcko (i, k) = qrch
+ endif
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute precipitation efficiency in terms of windshear
+ ! calculate the wind shear and precipitation efficiency according to equation 58 in fritsch and chappell (1980):
+ ! \f[
+ ! e = 1.591 - 0.639\frac{\delta v}{\delta z} + 0.0953\left (\frac{\delta v}{\delta z}\right) ^2 - 0.00496\left (\frac{\delta v}{\delta z}\right) ^3
+ ! \f]
+ ! where \f$\delta v\f$ is the integrated horizontal shear over the cloud depth, \f$\delta z\f$, (the ratio is converted to units of \f$10^{ - 3} s^{ - 1}\f$) . the variable "edt" is \f$1 - e\f$ and is constrained to the range \f$[0, 0.9]\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ shear = sqrt ((uo (i, k) - uo (i, k - 1)) ** 2 &
+ + (vo (i, k) - vo (i, k - 1)) ** 2)
+ vshear (i) = vshear (i) + shear
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 1.e3 * vshear (i) / (zi (i, ktcon (i)) - zi (i, kb (i)))
+ e1 = 1.591 - .639 * vshear (i) &
+ + .0953 * (vshear (i) ** 2) - .00496 * (vshear (i) ** 3)
+ edt (i) = 1. - e1
+ val = .9
+ edt (i) = min (edt (i), val)
+ val = .0
+ edt (i) = max (edt (i), val)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! what would the change be, that a cloud with unit mass
+ ! will do to the environment?
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux.
+ ! calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux for all layers below cloud top from equations b.14 and b.15 from grell (1993), and for the cloud top from b.16 and b.17.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ dellah (i, k) = 0.
+ dellaq (i, k) = 0.
+ dellau (i, k) = 0.
+ dellav (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ dellae (i, k, n) = 0.
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! changed due to subsidence and entrainment
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dp = delp (i, k)
+ dz = zi (i, k) - zi (i, k - 1)
+
+ dv1h = heo (i, k)
+ dv2h = .5 * (heo (i, k) + heo (i, k - 1))
+ dv3h = heo (i, k - 1)
+ dv1q = qo (i, k)
+ dv2q = .5 * (qo (i, k) + qo (i, k - 1))
+ dv3q = qo (i, k - 1)
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1))
+ tem1 = xlamud (i)
+
+ dellah (i, k) = dellah (i, k) + &
+ (eta (i, k) * dv1h - eta (i, k - 1) * dv3h &
+ - tem * eta (i, k - 1) * dv2h * dz &
+ + tem1 * eta (i, k - 1) * .5 * (hcko (i, k) + hcko (i, k - 1)) * dz &
+ ) * g / dp
+
+ dellaq (i, k) = dellaq (i, k) + &
+ (eta (i, k) * dv1q - eta (i, k - 1) * dv3q &
+ - tem * eta (i, k - 1) * dv2q * dz &
+ + tem1 * eta (i, k - 1) * .5 * (qrcko (i, k) + qcko (i, k - 1)) * dz &
+ ) * g / dp
+
+ tem1 = eta (i, k) * (uo (i, k) - ucko (i, k))
+ tem2 = eta (i, k - 1) * (uo (i, k - 1) - ucko (i, k - 1))
+ dellau (i, k) = dellau (i, k) + (tem1 - tem2) * g / dp
+
+ tem1 = eta (i, k) * (vo (i, k) - vcko (i, k))
+ tem2 = eta (i, k - 1) * (vo (i, k - 1) - vcko (i, k - 1))
+ dellav (i, k) = dellav (i, k) + (tem1 - tem2) * g / dp
+
+ endif
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntr
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dp = delp (i, k)
+ tem1 = eta (i, k) * (ctro (i, k, n) - ecko (i, k, n))
+ tem2 = eta (i, k - 1) * (ctro (i, k - 1, n) - ecko (i, k - 1, n))
+ dellae (i, k, n) = dellae (i, k, n) + (tem1 - tem2) * g / dp
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = ktcon (i)
+ dp = delp (i, indx)
+ dv1h = heo (i, indx - 1)
+ dellah (i, indx) = eta (i, indx - 1) * &
+ (hcko (i, indx - 1) - dv1h) * g / dp
+ dv1q = qo (i, indx - 1)
+ dellaq (i, indx) = eta (i, indx - 1) * &
+ (qcko (i, indx - 1) - dv1q) * g / dp
+ dellau (i, indx) = eta (i, indx - 1) * &
+ (ucko (i, indx - 1) - uo (i, indx - 1)) * g / dp
+ dellav (i, indx) = eta (i, indx - 1) * &
+ (vcko (i, indx - 1) - vo (i, indx - 1)) * g / dp
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! -----------------------------------------------------------------------
+
+ dellal (i, indx) = eta (i, indx - 1) * &
+ qlko_ktcon (i) * g / dp
+ endif
+ enddo
+
+ do n = 1, ntr
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = ktcon (i)
+ dp = delp (i, indx)
+ dellae (i, indx, n) = eta (i, indx - 1) * &
+ (ecko (i, indx - 1, n) - ctro (i, indx - 1, n)) * g / dp
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute convective turn - over time
+ ! following bechtold et al. (2008), calculate the convective turnover time using the mean updraft velocity (wc) and the cloud depth. it is also proportional to the grid size (gsize) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = zi (i, ktcon1 (i)) - zi (i, kbcon1 (i))
+ dtconv (i) = tem / wc (i)
+ tfac = 1. + gsize (i) / 75000.
+ dtconv (i) = tfac * dtconv (i)
+ dtconv (i) = max (dtconv (i), dtmin)
+ dtconv (i) = max (dtconv (i), dt2)
+ dtconv (i) = min (dtconv (i), dtmax)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate advective time scale (tauadv) using a mean cloud layer wind speed.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ umean (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon1 (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = sqrt (u1 (i, k) * u1 (i, k) + v1 (i, k) * v1 (i, k))
+ umean (i) = umean (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ umean (i) = umean (i) / sumx (i)
+ umean (i) = max (umean (i), 1.)
+ tauadv (i) = gsize (i) / umean (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud base mass flux as a function of the mean
+ ! updraft velcoity
+ ! from han et al.'s (2017) equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity.
+ ! as discussed in han et al. (2017), when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. in this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kbcon (i)
+ rho = po (i, k) * 100. / (rdgas * to (i, k))
+ tfac = tauadv (i) / dtconv (i)
+ tfac = min (tfac, 1.)
+ xmb (i) = tfac * betaw_shal * rho * wc (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for scale - aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see han et al.'s (2017) equation 4 and 5), following the study by grell and freitas (2014).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = min (max (xlamue (i, kbcon (i)), 2.e-4), 6.e-4)
+ tem = 0.2 / tem
+ tem1 = 3.14 * tem * tem
+ sigmagfm (i) = tem1 / (gsize (i) ** 2.0)
+ sigmagfm (i) = max (sigmagfm (i), 0.001)
+ sigmagfm (i) = min (sigmagfm (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by arakawa and wu (2013) (also see han et al.'s (2017) equation 1 and 2) . the final cloud base mass flux with scale - aware parameterization is obtained from the mass flux when sigmagfm < < 1, multiplied by the reduction factor (han et al.'s (2017) equation 2) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (gsize (i) < dxcrt_shal) then
+ scaldfunc (i) = (1. - sigmagfm (i)) * (1. - sigmagfm (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ xmb (i) = xmb (i) * scaldfunc (i)
+ xmb (i) = min (xmb (i), xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! transport aerosols if present
+ ! -----------------------------------------------------------------------
+
+ if (do_aerosols) &
+ call sa_aamf_shal_aero (im, km, itc, ntc, ntr, delt, &
+ cnvflg, kb, kmax, kbcon, ktcon, fscav, &
+ xmb, c0t, eta, zi, xlamue, xlamud, delp, &
+ qtr, qaero)
+
+ ! -----------------------------------------------------------------------
+ ! for the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control.
+ ! - recalculate saturation specific humidity.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the temperature tendency from the moist static energy and specific humidity tendencies.
+ ! update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux - normalized tendencies by the cloud base mass flux.
+ ! accumulate column - integrated tendencies.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ delhbar (i) = 0.
+ delqbar (i) = 0.
+ deltbar (i) = 0.
+ delubar (i) = 0.
+ delvbar (i) = 0.
+ qcond (i) = 0.
+ enddo
+
+ do n = 1, ntr
+ do i = 1, im
+ delebar (i, n) = 0.
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ dellat = (dellah (i, k) - hlv * dellaq (i, k)) / cp_air
+ t1 (i, k) = t1 (i, k) + dellat * xmb (i) * dt2
+ q1 (i, k) = q1 (i, k) + dellaq (i, k) * xmb (i) * dt2
+ ! tem = 1. / rcs (i)
+ ! u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2 * tem
+ ! v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2 * tem
+ u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2
+ v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2
+ dp = delp (i, k)
+ delhbar (i) = delhbar (i) + dellah (i, k) * xmb (i) * dp / g
+ delqbar (i) = delqbar (i) + dellaq (i, k) * xmb (i) * dp / g
+ deltbar (i) = deltbar (i) + dellat * xmb (i) * dp / g
+ delubar (i) = delubar (i) + dellau (i, k) * xmb (i) * dp / g
+ delvbar (i) = delvbar (i) + dellav (i, k) * xmb (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ kk = 0
+ do n = 1, ntr + 2
+ if (n .eq. ntw .or. n .eq. nti) cycle
+ kk = kk + 1
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k <= ktcon (i)) then
+ ctr (i, k, kk) = ctr (i, k, kk) + dellae (i, k, kk) * xmb (i) * dt2
+ delebar (i, kk) = delebar (i, kk) + dellae (i, k, kk) * xmb (i) * dp / g
+ qtr (i, k, n) = ctr (i, k, kk)
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity using the updated temperature.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! add up column - integrated convective precipitation by multiplying the normalized value by the cloud base mass flux.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ rntot (i) = 0.
+ delqev (i) = 0.
+ delq2 (i) = 0.
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < ktcon (i) .and. k > kb (i)) then
+ rntot (i) = rntot (i) + pwo (i, k) * xmb (i) * .001 * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! evaporating rain
+ ! determine the evaporation of the convective precipitation and update the integrated convective precipitation.
+ ! update state temperature and moisture to account for evaporation of convective precipitation.
+ ! update column - integrated tendencies to account for evaporation of convective precipitation.
+ ! -----------------------------------------------------------------------
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (k <= kmax (i)) then
+ deltv (i) = 0.
+ delq (i) = 0.
+ qevap (i) = 0.
+ if (cnvflg (i)) then
+ if (k < ktcon (i) .and. k > kb (i)) then
+ rn (i) = rn (i) + pwo (i, k) * xmb (i) * .001 * dt2
+ qr (i, k) = qr (i, k) + pwo (i, k) * xmb (i) * .001 * dt2
+ endif
+ endif
+ if (flg (i) .and. k < ktcon (i)) then
+ evef = edt (i) * evfact_shal
+ if (islimsk (i) == 1) evef = edt (i) * evfactl_shal
+ ! if (islimsk (i) == 1) evef = .07
+ ! if (islimsk (i) == 1) evef = 0.
+ qcond (i) = evef * (q1 (i, k) - qeso (i, k)) &
+ / (1. + el2orc * qeso (i, k) / t1 (i, k) ** 2)
+ dp = delp (i, k)
+ if (rn (i) > 0. .and. qcond (i) < 0.) then
+ qevap (i) = - qcond (i) * (1. - exp (- .32 * sqrt (dt2 * rn (i))))
+ qevap (i) = min (qevap (i), rn (i) * 1000. * g / dp)
+ delq2 (i) = delqev (i) + .001 * qevap (i) * dp / g
+ endif
+ if (rn (i) > 0. .and. qcond (i) < 0. .and. delq2 (i) > rntot (i)) then
+ qevap (i) = 1000. * g * (rntot (i) - delqev (i)) / dp
+ flg (i) = .false.
+ endif
+ if (rn (i) > 0. .and. qevap (i) > 0.) then
+ tem = .001 * dp / g
+ tem1 = qevap (i) * tem
+ if (tem1 > rn (i)) then
+ qevap (i) = rn (i) / tem
+ rn (i) = 0.
+ else
+ rn (i) = rn (i) - tem1
+ endif
+ qr (i, k) = qr (i, k) - qevap (i) * tem
+ q1 (i, k) = q1 (i, k) + qevap (i)
+ t1 (i, k) = t1 (i, k) - elocp * qevap (i)
+ deltv (i) = - elocp * qevap (i) / dt2
+ delq (i) = + qevap (i) / dt2
+ delqev (i) = delqev (i) + .001 * dp * qevap (i) / g
+ endif
+ delqbar (i) = delqbar (i) + delq (i) * dp / g
+ deltbar (i) = deltbar (i) + deltv (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! if (me == 31 .and. cnvflg (i)) then
+ ! if (cnvflg (i)) then
+ ! print *, ' shallow delhbar, delqbar, deltbar = ', &
+ ! delhbar (i), hlv * delqbar (i), cp_air * deltbar (i)
+ ! print *, ' shallow delubar, delvbar = ', delubar (i), delvbar (i)
+ ! print *, ' precip = ', hlv * rn (i) * 1000. / dt2
+ ! print *, 'pdif = ', pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ ! endif
+ ! enddo
+ ! do n = 1, ntr
+ ! do i = 1, im
+ ! if (me == 31 .and. cnvflg (i)) then
+ ! if (cnvflg (i)) then
+ ! print *, ' tracer delebar = ', delebar (i, n)
+ ! endif
+ ! enddo
+ ! enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (rn (i) < 0. .or. .not.flg (i)) rn (i) = 0.
+ ktop (i) = ktcon (i)
+ kbot (i) = kbcon (i)
+ kcnv (i) = 2
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud water
+ ! calculate shallow convective cloud water.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw) .and. cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvw (i, k) = cnvwt (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud cover
+ ! calculate convective cloud cover, which is used when pdf - based cloud fraction is used (i.e., pdfcld = .true.) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvc) .and. cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvc (i, k) = 0.04 * log (1. + 675. * eta (i, k) * xmb (i))
+ cnvc (i, k) = min (cnvc (i, k), 0.2)
+ cnvc (i, k) = max (cnvc (i, k), 0.0)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! separate detrained cloud water into liquid and ice species as a function of temperature only.
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! if (k > kb (i) .and. k <= ktcon (i)) then
+ if (k >= kbcon (i) .and. k <= ktcon (i)) then
+ tem = dellal (i, k) * xmb (i) * dt2
+ qtr (i, k, ntw) = qtr (i, k, ntw) + tem
+ endif
+ endif
+ enddo
+ enddo
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! store aerosol concentrations if present
+ ! -----------------------------------------------------------------------
+
+ if (do_aerosols) then
+ do n = 1, ntc
+ kk = n + itc - 1
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) > 0.) then
+ if (k <= kmax (i)) qtr (i, k, kk) = qaero (i, k, n)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! calculate and retain the updraft mass flux for dust transport by cumulus convection.
+ ! calculate the updraft convective mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf) .and. cnvflg (i)) then
+ if (k >= kb (i) .and. k < ktop (i)) then
+ ud_mf (i, k) = eta (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! save the updraft convective mass flux at cloud top.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (present (dt_mf) .and. present (ud_mf) .and. cnvflg (i)) then
+ k = ktop (i) - 1
+ dt_mf (i, k) = ud_mf (i, k)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! include tke contribution from shallow convection
+ ! -----------------------------------------------------------------------
+
+ if (ntk > 0) then
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktop (i)) then
+ tem = 0.5 * (eta (i, k - 1) + eta (i, k)) * xmb (i)
+ tem1 = pfld (i, k) * 100. / (rdgas * t1 (i, k))
+ sigmagfm (i) = max (sigmagfm (i), betaw_shal)
+ ptem = tem / (sigmagfm (i) * tem1)
+ qtr (i, k, ntk) = qtr (i, k, ntk) + 0.5 * sigmagfm (i) * ptem * ptem
+ endif
+ endif
+ enddo
+ enddo
+
+ endif
+
+end subroutine sa_aamf_shal
+
+! =======================================================================
+! Aerosol Transportation in Deep Convection
+! =======================================================================
+
+subroutine sa_aamf_deep_aero (im, km, itc, ntc, ntr, delt, &
+ xlamde, xlamdd, cnvflg, jmin, kb, kmax, kbcon, ktcon, fscav, &
+ edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, &
+ qtr, qaero)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, itc, ntc, ntr
+
+ real, intent (in) :: delt, xlamde, xlamdd
+
+ logical, dimension (im), intent (in) :: cnvflg
+
+ integer, dimension (im), intent (in) :: jmin, kb, kmax, kbcon, ktcon
+
+ real, dimension (im), intent (in) :: edto,xlamd, xmb
+
+ real, dimension (ntc), intent (in) :: fscav
+
+ real, dimension (im, km), intent (in) :: c0t, eta, etad, zi, xlamue, xlamud
+
+ real, dimension (im, km), intent (in) :: delp
+
+ real, dimension (im, km, ntr + 2), intent (in) :: qtr
+
+ real, dimension (im, km, ntc), intent (out) :: qaero
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ ! general variables
+
+ integer :: i, indx, it, k, kk, km1, kp1, n
+
+ real :: adw, aup, dtime_max, dv1q, dv2q, dv3q, dtovdz, dz, factor, ptem, ptem1, qamax, tem, tem1
+
+ real, dimension (im, km) :: xmbp
+
+ ! chemical transport variables
+
+ real, dimension (im, km, ntc) :: ctro2, ecko2, ecdo2, dellae2
+
+ ! additional variables for tracers for wet deposition,
+
+ real, dimension (im, km, ntc) :: chem_c, chem_pw, wet_dep
+
+ ! if reevaporation is enabled, uncomment lines below
+
+ ! real, dimension (im, ntc) :: pwav
+ ! real, dimension (im, km) :: pwdper
+ ! real, dimension (im, km, ntr) :: chem_pwd
+
+ ! additional variables for fct
+
+ real, dimension (im, km) :: flx_lo, totlout, clipout
+
+ real, parameter :: one = 1.0
+ real, parameter :: half = 0.5
+ real, parameter :: quarter = 0.25
+ real, parameter :: zero = 0.0
+ real, parameter :: epsil = 1.e-22 ! prevent division by zero
+
+ ! -----------------------------------------------------------------------
+ ! begin
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! check if aerosols are present
+ ! -----------------------------------------------------------------------
+
+ if (ntc <= 0 .or. itc <= 0 .or. ntr <= 0) return
+ if (ntr < itc + ntc - 3) return
+
+ ! -----------------------------------------------------------------------
+ ! initialize work variables
+ ! -----------------------------------------------------------------------
+
+ km1 = km - 1
+
+ chem_c = zero
+ chem_pw = zero
+ ctro2 = zero
+ dellae2 = zero
+ ecdo2 = zero
+ ecko2 = zero
+ qaero = zero
+
+ ! -----------------------------------------------------------------------
+ ! set work arrays
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ it = n + itc - 1
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) qaero (i, k, n) = max (qcmin, qtr (i, k, it))
+ enddo
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ xmbp (i, k) = grav * xmb (i) / delp (i, k)
+ enddo
+ enddo
+
+ do n = 1, ntc
+
+ ! -----------------------------------------------------------------------
+ ! interface level
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ kp1 = k + 1
+ do i = 1, im
+ if (kp1 <= kmax (i)) ctro2 (i, k, n) = &
+ half * (qaero (i, k, n) + qaero (i, kp1, n))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! top level
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ctro2 (i, kmax (i), n) = qaero (i, kmax (i), n)
+ enddo
+ enddo
+
+ do n = 1, ntc
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= kb (i))) &
+ ecko2 (i, k, n) = ctro2 (i, k, n)
+ enddo
+ enddo
+ enddo
+
+ do n = 1, ntc
+ do i = 1, im
+ if (cnvflg (i)) ecdo2 (i, jmin (i), n) = ctro2 (i, jmin (i), n)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! do chemical tracers, first need to know how much reevaporates
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! aerosol re - evaporation is set to zero for now
+ ! uncomment and edit the following code to enable re - evaporation
+ ! chem_pwd = zero
+ ! pwdper = zero
+ ! pwav = zero
+ ! do i = 1, im
+ ! do k = 1, jmin (i)
+ ! pwdper (i, k) = - edto (i) * pwdo (i, k) / pwavo (i)
+ ! enddo
+ ! enddo
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate include mixing ratio (ecko2), how much goes into
+ ! rainwater to be rained out (chem_pw), and total scavenged,
+ ! if not reevaporated (pwav)
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if ((k > kb (i)) .and. (k < ktcon (i))) then
+ dz = zi (i, k) - zi (i, kk)
+ tem = half * (xlamue (i, k) + xlamue (i, kk)) * dz
+ tem1 = quarter * (xlamud (i, k) + xlamud (i, kk)) * dz
+ factor = one + tem - tem1
+
+ ! -----------------------------------------------------------------------
+ ! if conserved (not scavenging) then
+ ! -----------------------------------------------------------------------
+
+ ecko2 (i, k, n) = ((one - tem1) * ecko2 (i, kk, n) &
+ + half * tem * (ctro2 (i, k, n) + ctro2 (i, kk, n))) / factor
+
+ ! -----------------------------------------------------------------------
+ ! how much will be scavenged
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! this choice was used in gf, and is also described in a
+ ! successful implementation into cesm in grl (yu et al. 2019),
+ ! it uses dimesnsionless scavenging coefficients (fscav),
+ ! but includes henry coeffs with gas phase chemistry
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! fraction fscav is going into liquid
+ ! -----------------------------------------------------------------------
+
+ chem_c (i, k, n) = fscav (n) * ecko2 (i, k, n)
+
+ ! -----------------------------------------------------------------------
+ ! of that part is going into rain out (chem_pw)
+ ! -----------------------------------------------------------------------
+
+ tem = chem_c (i, k, n) / (one + c0t (i, k) * dz)
+ chem_pw (i, k, n) = c0t (i, k) * dz * tem * eta (i, kk) !etah
+ ecko2 (i, k, n) = tem + ecko2 (i, k, n) - chem_c (i, k, n)
+
+ ! -----------------------------------------------------------------------
+ ! pwav needed fo reevaporation in downdraft
+ ! if including reevaporation, please uncomment code below
+ ! pwav (i, n) = pwav (i, n) + chem_pw (i, k, n)
+ ! -----------------------------------------------------------------------
+
+ endif
+ endif
+ enddo
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ if (k >= ktcon (i)) ecko2 (i, k, n) = ctro2 (i, k, n)
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! reevaporation of some, pw and pwd terms needed later for dellae2
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = km1, 1, - 1
+ kp1 = k + 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k < jmin (i))) then
+ dz = zi (i, kp1) - zi (i, k)
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = half * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = half * (xlamd (i) + xlamdd) * dz
+ endif
+ factor = one + tem - tem1
+ ecdo2 (i, k, n) = ((one - tem1) * ecdo2 (i, kp1, n) &
+ + half * tem * (ctro2 (i, k, n) + ctro2 (i, kp1, n))) / factor
+
+ ! -----------------------------------------------------------------------
+ ! if including reevaporation, please uncomment code below
+ ! -----------------------------------------------------------------------
+
+ ! ecdo2 (i, k, n) = ecdo2 (i, k, n) + pwdper (i, kp1) * pwav (i, n)
+ ! chem_pwd (i, k, n) = max (zero, pwdper (i, kp1) * pwav (i, n))
+ endif
+ enddo
+ enddo
+ enddo
+
+ do n = 1, ntc
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ ! -----------------------------------------------------------------------
+ ! subsidence term treated in fct routine
+ ! -----------------------------------------------------------------------
+
+ dellae2 (i, 1, n) = edto (i) * etad (i, 1) * ecdo2 (i, 1, n) * xmbp (i, 1)
+ endif
+ enddo
+ enddo
+
+ do n = 1, ntc
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = ktcon (i)
+ kk = k - 1
+
+ ! -----------------------------------------------------------------------
+ ! for the subsidence term already is considered
+ ! -----------------------------------------------------------------------
+
+ dellae2 (i, k, n) = eta (i, kk) * ecko2 (i, kk, n) * xmbp (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for updraft & downdraft vertical transport
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! initialize maximum allowed timestep for upstream difference approach
+ ! -----------------------------------------------------------------------
+
+ dtime_max = delt
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (kk < ktcon (i)) dtime_max = min (dtime_max, half * delp (i, kk))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! now for every chemistry tracer
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k < ktcon (i))) then
+ dz = zi (i, k) - zi (i, kk)
+ aup = one
+ if (k <= kb (i)) aup = zero
+ adw = one
+ if (k > jmin (i)) adw = zero
+
+ dv1q = half * (ecko2 (i, k, n) + ecko2 (i, kk, n))
+ dv2q = half * (ctro2 (i, k, n) + ctro2 (i, kk, n))
+ dv3q = half * (ecdo2 (i, k, n) + ecdo2 (i, kk, n))
+
+ tem = half * (xlamue (i, k) + xlamue (i, kk))
+ tem1 = half * (xlamud (i, k) + xlamud (i, kk))
+
+ if (k <= kbcon (i)) then
+ ptem = xlamde
+ ptem1 = xlamd (i) + xlamdd
+ else
+ ptem = xlamde
+ ptem1 = xlamdd
+ endif
+ dellae2 (i, k, n) = dellae2 (i, k, n) + &
+
+ ! -----------------------------------------------------------------------
+ ! detrainment from updraft
+ ! -----------------------------------------------------------------------
+
+ (aup * tem1 * eta (i, kk) * dv1q &
+
+ ! -----------------------------------------------------------------------
+ ! entrainement into up and downdraft
+ ! -----------------------------------------------------------------------
+
+ - (aup * tem * eta (i, kk) + adw * edto (i) * ptem * etad (i, k)) * dv2q &
+
+ ! -----------------------------------------------------------------------
+ ! detrainment from downdraft
+ ! -----------------------------------------------------------------------
+
+ + (adw * edto (i) * ptem1 * etad (i, k) * dv3q)) * dz * xmbp (i, k)
+
+ wet_dep (i, k, n) = chem_pw (i, k, n) * grav / delp (i, k)
+
+ ! -----------------------------------------------------------------------
+ ! sinks from where updraft and downdraft start
+ ! -----------------------------------------------------------------------
+
+ if (k == jmin (i) + 1) then
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - edto (i) * etad (i, kk) * ctro2 (i, kk, n) * xmbp (i, k)
+ endif
+ if (k == kb (i)) then
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - eta (i, k) * ctro2 (i, k, n) * xmbp (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kb (i) == 1) then
+ k = kb (i)
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - eta (i, k) * ctro2 (i, k, n) * xmbp (i, k)
+ endif
+ endif
+ enddo
+
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for every tracer...
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ flx_lo = zero
+ totlout = zero
+ clipout = zero
+
+ ! -----------------------------------------------------------------------
+ ! compute low - order mass flux, upstream
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (kk < ktcon (i))) then
+ tem = zero
+ if (kk >= kb (i)) tem = eta (i, kk)
+ if (kk <= jmin (i)) tem = tem - edto (i) * etad (i, kk)
+
+ ! -----------------------------------------------------------------------
+ ! low - order flux, upstream
+ ! -----------------------------------------------------------------------
+
+ if (tem > zero) then
+ flx_lo (i, k) = - xmb (i) * tem * qaero (i, k, n)
+ elseif (tem < zero) then
+ flx_lo (i, k) = - xmb (i) * tem * qaero (i, kk, n)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! make sure low - ord fluxes don't violate positive - definiteness
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ kp1 = k + 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= ktcon (i))) then
+
+ ! -----------------------------------------------------------------------
+ ! time step / grid spacing
+ ! -----------------------------------------------------------------------
+
+ dtovdz = grav * dtime_max / abs (delp (i, k))
+
+ ! -----------------------------------------------------------------------
+ ! total flux out
+ ! -----------------------------------------------------------------------
+
+ totlout (i, k) = max (zero, flx_lo (i, kp1)) - min (zero, flx_lo (i, k))
+ clipout (i, k) = min (one, qaero (i, k, n) / max (epsil, totlout (i, k)) &
+ / (1.0001 * dtovdz))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recompute upstream mass fluxes
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (kk < ktcon (i))) then
+ tem = zero
+ if (kk >= kb (i)) tem = eta (i, kk)
+ if (kk <= jmin (i)) tem = tem - edto (i) * etad (i, kk)
+ if (tem > zero) then
+ flx_lo (i, k) = flx_lo (i, k) * clipout (i, k)
+ elseif (tem < zero) then
+ flx_lo (i, k) = flx_lo (i, k) * clipout (i, kk)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! a positive - definite low - order (diffusive) solution for the subsidnce fluxes
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ kp1 = k + 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= ktcon (i))) then
+ dtovdz = grav * dtime_max / abs (delp (i, k)) ! time step / grid spacing
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - (flx_lo (i, kp1) - flx_lo (i, k)) * dtovdz / dtime_max
+ endif
+ enddo
+ enddo
+
+ enddo ! ctr
+
+ ! -----------------------------------------------------------------------
+ ! convert wet deposition to total mass deposited over dt and dp
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. (k < ktcon (i))) &
+ wet_dep (i, k, n) = wet_dep (i, k, n) * xmb (i) * delt * delp (i, k)
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute final aerosol concentrations
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= min (kmax (i), ktcon (i)))) then
+ qaero (i, k, n) = qaero (i, k, n) + dellae2 (i, k, n) * delt
+ if (qaero (i, k, n) < zero) then
+
+ ! -----------------------------------------------------------------------
+ ! add negative mass to wet deposition
+ ! -----------------------------------------------------------------------
+
+ wet_dep (i, k, n) = wet_dep (i, k, n) - qaero (i, k, n) * delp (i, k)
+ qaero (i, k, n) = qcmin
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+end subroutine sa_aamf_deep_aero
+
+! =======================================================================
+! Aerosol Transportation in Shallow Convection
+! =======================================================================
+
+subroutine sa_aamf_shal_aero (im, km, itc, ntc, ntr, delt, &
+ cnvflg, kb, kmax, kbcon, ktcon, fscav, &
+ xmb, c0t, eta, zi, xlamue, xlamud, delp, &
+ qtr, qaero)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, itc, ntc, ntr
+
+ real, intent (in) :: delt
+
+ ! real, intent (in) :: xlamde, xlamdd
+
+ logical, dimension (im), intent (in) :: cnvflg
+
+ ! integer, dimension (im), intent (in) :: jmin
+
+ integer, dimension (im), intent (in) :: kb, kmax, kbcon, ktcon
+
+ real, dimension (im), intent (in) :: xmb, xlamud
+
+ real, dimension (ntc), intent (in) :: fscav
+
+ real, dimension (im, km), intent (in) :: c0t, eta, zi, xlamue
+
+ real, dimension (im, km), intent (in) :: delp
+
+ real, dimension (im, km, ntr + 2), intent (in) :: qtr
+
+ real, dimension (im, km, ntc), intent (out) :: qaero
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ ! general variables
+
+ integer :: i, indx, it, k, kk, km1, kp1, n
+
+ ! real :: adw, aup, dtime_max, dv1q, dv2q, dv3q,
+
+ real :: aup, dtime_max, dv1q, dv2q, dv3q, dtovdz, dz, factor, ptem, ptem1, qamax, tem, tem1
+
+ real, dimension (im, km) :: xmbp
+
+ ! chemical transport variables
+
+ real, dimension (im, km, ntc) :: ctro2, ecko2, dellae2
+
+ ! additional variables for tracers for wet deposition,
+
+ real, dimension (im, km, ntc) :: chem_c, chem_pw, wet_dep
+
+ ! if reevaporation is enabled, uncomment lines below
+
+ ! real, dimension (im, ntc) :: pwav
+ ! real, dimension (im, km) :: pwdper
+ ! real, dimension (im, km, ntr) :: chem_pwd
+
+ ! additional variables for fct
+
+ real, dimension (im, km) :: flx_lo, totlout, clipout
+
+ real, parameter :: one = 1.0
+ real, parameter :: half = 0.5
+ real, parameter :: quarter = 0.25
+ real, parameter :: zero = 0.0
+ real, parameter :: epsil = 1.e-22 ! prevent division by zero
+ real, parameter :: escav = 0.8 ! wet scavenging efficiency
+
+ ! -----------------------------------------------------------------------
+ ! begin
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! check if aerosols are present
+ ! -----------------------------------------------------------------------
+
+ if (ntc <= 0 .or. itc <= 0 .or. ntr <= 0) return
+ if (ntr < itc + ntc - 3) return
+
+ ! -----------------------------------------------------------------------
+ ! initialize work variables
+ ! -----------------------------------------------------------------------
+
+ km1 = km - 1
+
+ chem_c = zero
+ chem_pw = zero
+ ctro2 = zero
+ dellae2 = zero
+ !ecdo2 = zero
+ ecko2 = zero
+ qaero = zero
+
+ ! -----------------------------------------------------------------------
+ ! set work arrays
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ it = n + itc - 1
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) qaero (i, k, n) = max (qcmin, qtr (i, k, it))
+ enddo
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ xmbp (i, k) = grav * xmb (i) / delp (i, k)
+ enddo
+ enddo
+
+ do n = 1, ntc
+
+ ! -----------------------------------------------------------------------
+ ! interface level
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ kp1 = k + 1
+ do i = 1, im
+ if (kp1 <= kmax (i)) ctro2 (i, k, n) = &
+ half * (qaero (i, k, n) + qaero (i, kp1, n))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! top level
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ctro2 (i, kmax (i), n) = qaero (i, kmax (i), n)
+ enddo
+ enddo
+
+ do n = 1, ntc
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= kb (i))) &
+ ecko2 (i, k, n) = ctro2 (i, k, n)
+ enddo
+ enddo
+ enddo
+
+ !do n = 1, ntc
+ ! do i = 1, im
+ ! if (cnvflg (i)) ecdo2 (i, jmin (i), n) = ctro2 (i, jmin (i), n)
+ ! enddo
+ !enddo
+
+ ! -----------------------------------------------------------------------
+ ! do chemical tracers, first need to know how much reevaporates
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! aerosol re - evaporation is set to zero for now
+ ! uncomment and edit the following code to enable re - evaporation
+ ! chem_pwd = zero
+ ! pwdper = zero
+ ! pwav = zero
+ ! do i = 1, im
+ ! do k = 1, jmin (i)
+ ! pwdper (i, k) = - edto (i) * pwdo (i, k) / pwavo (i)
+ ! enddo
+ ! enddo
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate include mixing ratio (ecko2), how much goes into
+ ! rainwater to be rained out (chem_pw), and total scavenged,
+ ! if not reevaporated (pwav)
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if ((k > kb (i)) .and. (k < ktcon (i))) then
+ dz = zi (i, k) - zi (i, kk)
+ tem = half * (xlamue (i, k) + xlamue (i, kk)) * dz
+ ! tem1 = quarter * (xlamud (i, k) + xlamud (i, kk)) * dz
+ tem1 = quarter * (xlamud (i) + xlamud (i)) * dz
+ factor = one + tem - tem1
+
+ ! -----------------------------------------------------------------------
+ ! if conserved (not scavenging) then
+ ! -----------------------------------------------------------------------
+
+ ecko2 (i, k, n) = ((one - tem1) * ecko2 (i, kk, n) &
+ + half * tem * (ctro2 (i, k, n) + ctro2 (i, kk, n))) / factor
+
+ ! -----------------------------------------------------------------------
+ ! how much will be scavenged
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! this choice was used in gf, and is also described in a
+ ! successful implementation into cesm in grl (yu et al. 2019),
+ ! it uses dimesnsionless scavenging coefficients (fscav),
+ ! but includes henry coeffs with gas phase chemistry
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! fraction fscav is going into liquid
+ ! -----------------------------------------------------------------------
+
+ chem_c (i, k, n) = escav * fscav (n) * ecko2 (i, k, n)
+
+ ! -----------------------------------------------------------------------
+ ! of that part is going into rain out (chem_pw)
+ ! -----------------------------------------------------------------------
+
+ tem = chem_c (i, k, n) / (one + c0t (i, k) * dz)
+ chem_pw (i, k, n) = c0t (i, k) * dz * tem * eta (i, kk) !etah
+ ecko2 (i, k, n) = tem + ecko2 (i, k, n) - chem_c (i, k, n)
+
+ ! -----------------------------------------------------------------------
+ ! pwav needed fo reevaporation in downdraft
+ ! if including reevaporation, please uncomment code below
+ ! pwav (i, n) = pwav (i, n) + chem_pw (i, k, n)
+ ! -----------------------------------------------------------------------
+
+ endif
+ endif
+ enddo
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ if (k >= ktcon (i)) ecko2 (i, k, n) = ctro2 (i, k, n)
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! reevaporation of some, pw and pwd terms needed later for dellae2
+ ! -----------------------------------------------------------------------
+
+ ! do n = 1, ntc
+ ! do k = km1, 1, - 1
+ ! kp1 = k + 1
+ ! do i = 1, im
+ ! if (cnvflg (i) .and. (k < jmin (i))) then
+ ! dz = zi (i, kp1) - zi (i, k)
+ ! if (k >= kbcon (i)) then
+ ! tem = xlamde * dz
+ ! tem1 = half * xlamdd * dz
+ ! else
+ ! tem = xlamde * dz
+ ! tem1 = half * (xlamd (i) + xlamdd) * dz
+ ! endif
+ ! factor = one + tem - tem1
+ ! ecdo2 (i, k, n) = ((one - tem1) * ecdo2 (i, kp1, n) &
+ ! + half * tem * (ctro2 (i, k, n) + ctro2 (i, kp1, n))) / factor
+ ! if including reevaporation, please uncomment code below
+ ! ecdo2 (i, k, n) = ecdo2 (i, k, n) + pwdper (i, kp1) * pwav (i, n)
+ ! chem_pwd (i, k, n) = max (zero, pwdper (i, kp1) * pwav (i, n))
+ ! endif
+ ! enddo
+ ! enddo
+ ! enddo
+
+ ! do n = 1, ntc
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! subsidence term treated in fct routine
+ ! dellae2 (i, 1, n) = edto (i) * etad (i, 1) * ecdo2 (i, 1, n) * xmbp (i, 1)
+ ! endif
+ ! enddo
+ ! enddo
+
+ do n = 1, ntc
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = ktcon (i)
+ kk = k - 1
+
+ ! -----------------------------------------------------------------------
+ ! for the subsidence term already is considered
+ ! -----------------------------------------------------------------------
+
+ dellae2 (i, k, n) = eta (i, kk) * ecko2 (i, kk, n) * xmbp (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for updraft & downdraft vertical transport
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! initialize maximum allowed timestep for upstream difference approach
+ ! -----------------------------------------------------------------------
+
+ dtime_max = delt
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (kk < ktcon (i)) dtime_max = min (dtime_max, half * delp (i, kk))
+ enddo
+ enddo
+
+ ! now for every chemistry tracer
+ do n = 1, ntc
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k < ktcon (i))) then
+ dz = zi (i, k) - zi (i, kk)
+ aup = one
+ if (k <= kb (i)) aup = zero
+ ! adw = one
+ ! if (k > jmin (i)) adw = zero
+
+ dv1q = half * (ecko2 (i, k, n) + ecko2 (i, kk, n))
+ dv2q = half * (ctro2 (i, k, n) + ctro2 (i, kk, n))
+ ! dv3q = half * (ecdo2 (i, k, n) + ecdo2 (i, kk, n))
+
+ tem = half * (xlamue (i, k) + xlamue (i, kk))
+ !tem1 = half * (xlamud (i, k) + xlamud (i, kk))
+ tem1 = half * (xlamud (i) + xlamud (i))
+
+ ! if (k <= kbcon (i)) then
+ ! ptem = xlamde
+ ! ptem1 = xlamd (i) + xlamdd
+ ! else
+ ! ptem = xlamde
+ ! ptem1 = xlamdd
+ ! endif
+
+ dellae2 (i, k, n) = dellae2 (i, k, n) + &
+
+ ! -----------------------------------------------------------------------
+ ! detrainment from updraft
+ ! -----------------------------------------------------------------------
+
+ (aup * tem1 * eta (i, kk) * dv1q &
+
+ ! -----------------------------------------------------------------------
+ ! entrainement into up and downdraft
+ ! -----------------------------------------------------------------------
+
+ ! - (aup * tem * eta (i, kk) + adw * edto (i) * ptem * etad (i, k)) * dv2q &
+ - (aup * tem * eta (i, kk)) * dv2q &
+
+ ! -----------------------------------------------------------------------
+ ! detrainment from downdraft
+ ! -----------------------------------------------------------------------
+
+ ! + (adw * edto (i) * ptem1 * etad (i, k) * dv3q) &
+ ) * dz * xmbp (i, k)
+
+ wet_dep (i, k, n) = chem_pw (i, k, n) * grav / delp (i, k)
+
+ ! -----------------------------------------------------------------------
+ ! sinks from where updraft and downdraft start
+ ! -----------------------------------------------------------------------
+
+ ! if (k == jmin (i) + 1) then
+ ! dellae2 (i, k, n) = dellae2 (i, k, n) &
+ ! - edto (i) * etad (i, kk) * ctro2 (i, kk, n) * xmbp (i, k)
+ ! endif
+
+ if (k == kb (i)) then
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - eta (i, k) * ctro2 (i, k, n) * xmbp (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kb (i) == 1) then
+ k = kb (i)
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - eta (i, k) * ctro2 (i, k, n) * xmbp (i, k)
+ endif
+ endif
+ enddo
+
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for every tracer...
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ flx_lo = zero
+ totlout = zero
+ clipout = zero
+
+ ! -----------------------------------------------------------------------
+ ! compute low - order mass flux, upstream
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (kk < ktcon (i))) then
+ tem = zero
+ if (kk >= kb (i)) tem = eta (i, kk)
+ ! if (kk <= jmin (i)) tem = tem - edto (i) * etad (i, kk)
+
+ ! -----------------------------------------------------------------------
+ ! low - order flux, upstream
+ ! -----------------------------------------------------------------------
+
+ if (tem > zero) then
+ flx_lo (i, k) = - xmb (i) * tem * qaero (i, k, n)
+ elseif (tem < zero) then
+ flx_lo (i, k) = - xmb (i) * tem * qaero (i, kk, n)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! make sure low - ord fluxes don't violate positive - definiteness
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ kp1 = k + 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= ktcon (i))) then
+
+ ! -----------------------------------------------------------------------
+ ! time step / grid spacing
+ ! -----------------------------------------------------------------------
+
+ dtovdz = grav * dtime_max / abs (delp (i, k))
+
+ ! -----------------------------------------------------------------------
+ ! total flux out
+ ! -----------------------------------------------------------------------
+
+ totlout (i, k) = max (zero, flx_lo (i, kp1)) - min (zero, flx_lo (i, k))
+ clipout (i, k) = min (one, qaero (i, k, n) / max (epsil, totlout (i, k)) &
+ / (1.0001 * dtovdz))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recompute upstream mass fluxes
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ kk = k - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (kk < ktcon (i))) then
+ tem = zero
+ if (kk >= kb (i)) tem = eta (i, kk)
+ ! if (kk <= jmin (i)) tem = tem - edto (i) * etad (i, kk)
+ if (tem > zero) then
+ flx_lo (i, k) = flx_lo (i, k) * clipout (i, k)
+ elseif (tem < zero) then
+ flx_lo (i, k) = flx_lo (i, k) * clipout (i, kk)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! a positive - definite low - order (diffusive) solution for the subsidnce fluxes
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ kp1 = k + 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= ktcon (i))) then
+ dtovdz = grav * dtime_max / abs (delp (i, k)) ! time step / grid spacing
+ dellae2 (i, k, n) = dellae2 (i, k, n) &
+ - (flx_lo (i, kp1) - flx_lo (i, k)) * dtovdz / dtime_max
+ endif
+ enddo
+ enddo
+
+ enddo ! ctr
+
+ ! -----------------------------------------------------------------------
+ ! convert wet deposition to total mass deposited over dt and dp
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. (k < ktcon (i))) &
+ wet_dep (i, k, n) = wet_dep (i, k, n) * xmb (i) * delt * delp (i, k)
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute final aerosol concentrations
+ ! -----------------------------------------------------------------------
+
+ do n = 1, ntc
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. (k <= min (kmax (i), ktcon (i)))) then
+ qaero (i, k, n) = qaero (i, k, n) + dellae2 (i, k, n) * delt
+ if (qaero (i, k, n) < zero) then
+
+ ! -----------------------------------------------------------------------
+ ! add negative mass to wet deposition
+ ! -----------------------------------------------------------------------
+
+ wet_dep (i, k, n) = wet_dep (i, k, n) - qaero (i, k, n) * delp (i, k)
+ qaero (i, k, n) = qcmin
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+end subroutine sa_aamf_shal_aero
+
+end module sa_aamf_mod
diff --git a/model/sa_gwd.F90 b/model/sa_gwd.F90
new file mode 100644
index 000000000..4344fa120
--- /dev/null
+++ b/model/sa_gwd.F90
@@ -0,0 +1,2757 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! Scale-Aware Gravity Wave Drag (SA-GWD) Package
+! This package includes orographic gravity wave drag, mountain blokcing,
+! and convective gravity wave drag
+! Developer:
+! References:
+! =======================================================================
+
+module sa_gwd_mod
+
+ use fms_mod, only: check_nml_error
+
+ implicit none
+
+ private
+
+ ! -----------------------------------------------------------------------
+ ! public subroutines, functions, and variables
+ ! -----------------------------------------------------------------------
+
+ public :: sa_gwd_init
+ public :: sa_gwd_oro
+ public :: sa_gwd_cnv
+
+ ! -----------------------------------------------------------------------
+ ! physics constants
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS
+
+ real, parameter :: rerth = 6.3712e6 ! radius of earth (m)
+
+ real, parameter :: pi = 4.0 * atan (1.0) ! ratio of circle circumference to diameter
+
+ 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 :: 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 :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS
+ real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K)
+
+ real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS
+
+ real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS
+
+ ! -----------------------------------------------------------------------
+ ! namelist parameters
+ ! -----------------------------------------------------------------------
+
+ integer :: nmtvr = 14 ! number of topographic variables such as variance etc
+
+ real :: cdmbgwd (2) = (/2.0, 0.25/) ! multiplication factors for cdmb and gwd
+ real :: p_crit = 0. ! Optional level above which GWD stress decays with height
+ real :: cgwf (2) = (/0.5, 0.05/) !< multiplication factor for convective GWD
+
+ ! -----------------------------------------------------------------------
+ ! namelist
+ ! -----------------------------------------------------------------------
+
+ namelist / sa_gwd_nml / nmtvr, cdmbgwd, p_crit, cgwf
+
+contains
+
+! =======================================================================
+! GWD initialization
+! =======================================================================
+
+subroutine sa_gwd_init (input_nml_file, logunit)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: logunit
+
+ character (len = *), intent (in) :: input_nml_file (:)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: ios, ierr
+
+ ! -----------------------------------------------------------------------
+ ! read namelist
+ ! -----------------------------------------------------------------------
+
+ read (input_nml_file, nml = sa_gwd_nml, iostat = ios)
+ ierr = check_nml_error (ios, 'sa_gwd_nml')
+
+ ! -----------------------------------------------------------------------
+ ! write namelist to log file
+ ! -----------------------------------------------------------------------
+
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "gwd_mod"
+ write (logunit, nml = sa_gwd_nml)
+
+end subroutine sa_gwd_init
+
+! =======================================================================
+! This subroutine is the parameterization of orographic gravity wave
+! drag and mountain blocking.
+!
+! At present, global models must be run with horizontal resolutions
+! that cannot typically resolve atmospheric phenomena shorter than
+! ~10-100 km or greater for weather prediction and ~100-1000 km or
+! greater for climate predicition. Many atmospheric processes have
+! shorter horizontal scales than these "subgrid-scale" processes
+! interact with and affect the larger-scale atmosphere in important
+! ways.
+!
+! Atmospheric gravity waves are one such unresolved processes. These
+! waves are generated by lower atmospheric sources. E.g., flow over
+! irregularities at the Earth's surface such as mountains and valleys,
+! uneven distribution of diabatic heat sources asscociated with
+! convective systems, and highly dynamic atmospheric processes such
+! as jet streams and fronts. The dissipation of these waves produces
+! synoptic-scale body forces on the atmospheric flow, known as
+! "gravity wave drag" (GWD), which affects both short-term evolution
+! of weather systems and long-term climate. However, the spatial
+! scales of these waves (in the range of ~5-500 km horizontally) are
+! too short to be fully captured in models, and so GWD must be
+! parameterized. In addition, the role of GWD in driving the global
+! middle atmosphere circulation and thus global mean wind/temperature
+! structures is well established. Thus, GWD parametrizations are now
+! critical components of virtually all large-scale atmospheric models.
+! GFS physics includes parameterizations of gravity waves from two
+! important sources: mountains and convection.
+!
+! Atmospheric flow is significantly influenced by orography creating
+! lift and frictional forces. The representation of orography and its
+! influence in numerical weather prediction models are necessarily
+! divided into the resolvable scales of motion and treated by
+! primitive equations, the remaining sub-grid scales to be treated by
+! parameterization. In terms of large scale NWP models, mountain
+! blocking of wind flow around sub-grid scale orograph is a process
+! that retards motion at various model vertical levels near or in the
+! boundary layer. Flow around the mountain encounters larger
+! frictional forces by being in contact with the mountain surfaces
+! for longer time as well as the interaction of the atmospheric
+! environment with vortex shedding which occurs in numerous
+! observations. Lott and Miller (1997) \cite lott_and_miller_1997,
+! incorporated the dividing streamline and mountain blocking in
+! conjunction with sub-grid scale vertically propagating gravity wave
+! parameterization in the context of NWP. The dividing streamline is
+! seen as a source of gravity waves to the atmosphere above and
+! nonlinear subgrid low-level mountain drag effect below.
+!
+! In a review paper on gravity waves in the middle atmosphere, Fritts
+! (1984) \cite fritts_1984 showed that a large portion of observed
+! gravity wave momentum flux has higher frequencies than those of
+! stationary mountain waves. This phenomenon was explained by cumulus
+! convection, which is an additional source of tropospheric gravity
+! waves, and is particularly important in summertime. When the surface
+! wind and stability are weak, the magnitude of the surface drag and
+! the resultant influence of orographically-induced gravity wave drag
+! on the large-scale flow are relatively small compared with those in
+! wintertime (Palmer et al. 1986 \cite palmer_et_al_1986). In this
+! situation, the relative importance of cumulus convection as a source
+! of gravity waves is larger. in addition, in the tropical regions
+! where persistent convection exists, deep cumulus clouds impinging on
+! the stable stratosphere can generate gravity waves that influence
+! the large-scale flow.
+!
+!-----------------------------------------------------------------------
+! Outlines GWD parameterization in GFS:
+!
+! - Gravity-wave drag is simulated as described by Alpert et al.
+! (1988) \cite alpert_et_al_1988. The parameterization includes
+! determination of the momentum flux due to gravity waves at the
+! surface, as well as upper levels. The surface stress is a nonlinear
+! function of the surface wind speed and the local froude number,
+! following Pierrehumbert (1987) \cite pierrehumbert_1987. Vertical
+! variations in the momentum flux occur when the local richardson
+! number is less than 0.25 (the stress vanishes), or when wave
+! breaking occurs (local froude number becomes critical); in the
+! latter case, the momentum flux is reduced according to the
+! Lindzen (1981) \cite lindzen_1981 wave saturation hypothesis.
+! Modifications are made to avoid instability when the critical layer
+! is near the surface, since the time scale for gravity-wave drag is
+! shorter than the model time step.
+!
+! - The treatment of the GWD in the lower troposphere is enhanced
+! according to Kim and Arakawa (1995) \cite kim_and_arakawa_1995.
+! Orographic Std Dev (HPRIME), Convexity (OC), Asymmetry (OA4) and Lx
+! (CLX4) are input topographic statistics needed (see Appendix in Kim
+! and Arakawa (1995) \cite kim_and_arakawa_1995).
+!
+! - Mountain blocking influences are incorporated following the Lott
+! and Miller (1997) \cite lott_and_miller_1997 parameterization with
+! minor changes, including their dividing streamline concept. The
+! model subgrid scale orography is represented by four parameters,
+! after Baines and Palmer (1990) \cite baines_and_palmer_1990, the
+! standard deviation (HPRIME), the anisotropy (GAMMA), the slope
+! (SIGMA) and the geographical orientation of the orography (THETA).
+! These are calculated off-line as a function of model resolution in
+! the fortran code ml01rg2.f, with script mlb2.sh (see Appendix:
+! specification of subgrid-scale orography in Lott and Miller (1997)
+! \cite lott_and_miller_1997).
+!
+! - The orographic GWD parameterizations automatically scales
+! with model resolution. For example, the T574L64 version of GFS uses
+! four times stronger mountain blocking and one half the strength of
+! gravity wave drag than the T383L64 version.
+!
+! - The parameterization of stationary convectively-forced GWD follows
+! the development of Chun and Baik (1998) \cite chun_and_baik_1998,
+! which was tested in GCMs by Chun et al. (2001, 2004)
+! \cite chun_et_al_2001 \cite chun_et_al_2004 was implemented in GFS
+! by Ake Johansson (2008) and the work of the GCWMB staff. Modest
+! positive effects from using the parameterization are seen in the
+! tropical upper troposphere and lower stratosphere.
+!
+!-----------------------------------------------------------------------
+! intra_gwdps Intraphysics Communication
+!
+! - Routine gwdps (\ref orographic) is called from gbphys after call
+! to moninedmf
+! - Routine gwdc (\ref convective) is called from gbphys after call
+! to sascnvn
+!
+! The time tendencies of zonal and meridional wind are altered to
+! include the effect of mountain induced gravity wave drag from
+! subgrid scale orography including convective breaking, shear
+! breaking and the presence of critical levels.
+!
+!-----------------------------------------------------------------------
+! \param[in] IM horizontal number of used pts
+! \param[in] KM vertical layer dimension
+! \param[in, out] VTGWD non-linear tendency for v wind component
+! \param[in, out] UTGWD non-linear tendency for u wind component
+! \param[in, out] TTGWD non-linear tendency for temperature (not used)
+! \param[in] U1 zonal wind component of model layer wind (m/s)
+! \param[in] V1 meridional wind component of model layer wind (m/s)
+! \param[in] T1 model layer mean temperature (K)
+! \param[in] Q1 model layer mean specific humidity
+! \param[in] KPBL index for the PBL top layer
+! \param[in] PRSI pressure at layer interfaces
+! \param[in] DEL positive increment of p/psfc across layer
+! \param[in] PRSL mean layer pressure
+! \param[in] PRSLK exner function at layer
+! \param[in] PHII interface geopotential (\f$m^2/s^2\f$)
+! \param[in] PHIL layer geopotential (\f$m^2/s^2\f$)
+! \param[in] DELT physics time step in seconds
+! \param[in] HPRIME orographic standard deviation (m) (mtnvar (:, 1))
+! \param[in] OC orographic convexity (mtnvar (:, 2))
+! \param[in] OA4 orographic asymmetry (mtnvar (:, 3:6))
+! \param[in] CLX4 Lx, the fractional area covered by the subgrid-scale
+! orography higher than a critical height for a grid box
+! with the interval \f$ \triangle x \f$ (mtnvar (:, 7:10))
+! \param[in] THETA the angle of the mtn with that to the east (x) axis (mtnvar (:, 11))
+! \param[in] SIGMA orographic slope (mtnvar (:, 13))
+! \param[in] GAMMA orographic anisotropy (mtnvar (:, 12))
+! \param[in] ELVMAX orographic maximum (mtnvar (:, 14))
+! \param[out] DUSFC u component of surface stress
+! \param[out] DVSFC v component of surface stress
+! \param[in] IMX number of longitude points
+! \param[in] NMTVR number of topographic variables such as variance etc
+! used in the GWD parameterization, current operational, nmtvr = 14
+! \param[in] CDMBGWD multiplication factors for cdmb and gwd
+!
+!-----------------------------------------------------------------------
+! Implementation Versions
+!-----------------------------------------------------------------------
+! -- not in this code -- history of GWDP at NCEP --
+!
+! Version 3 modified for gravity waves, location: .fr30 (v3gwd) * j *
+! 3.1 includes variable saturation flux profile cf isigst
+! 3.g includes ps combined w / ph (GLAS and GFDL)
+! also included is ri smooth over a thick lower layer
+! also included is decrease in de-acc at top by 1 / 2
+! the NMC GWD incorporating both GLAS (P&S) and GFDL (MIGWD)
+! mountain induced gravity wave drag
+! code from .fr30 (v3monnx) for monin3
+! this version (06 Mar 1987)
+! this version (26 Apr 1987) 3.g
+! this version (01 May 1987) 3.9
+! change to fortran 77 (Feb 1989) --- Hann-Ming Henry Juang
+! 20070601 elvmax bug fix (* j *)
+!
+!-----------------------------------------------------------------------
+! Version 4 -- this code
+!
+! Modified to implement the enhanced low tropospheric gravity
+! wave drag developed by Kim and Arakawa (JAS, 1995) .
+!
+! Orographic Std Dev (HPRIME), Convexity (OC), Asymmetry (OA4)
+! and Lx (CLX4) are input topographic statistics needed.
+!
+! Programmed and debugged by Hong, Alpert and Kim --- Jan 1996.
+! Debugged again by Moorthi and Iredell --- May 1998.
+!
+! Further cleanup, optimization and modification by Moorthi --- May 98, Mar 99.
+!
+! Modified for usgs orography data (NCEP office note 424)
+! and with several bugs fixed by Moorthi and Hong --- Jul 1999.
+!
+! Modified & implemented into NRL NOGAPS by Young and Joon Kim --- Jul 2000.
+!
+!-----------------------------------------------------------------------
+! Version LM MB (6) : oz fix 8 / 2003 -- this code
+!
+! Changed to include the Lott and Miller MTN blocking
+! with some modifications by (* j *) 4 / 02
+! from a principal coordinate calculation using the
+! hi res 8 minute orography, the angle of the
+! mtn with that to the east (x) axis is theta, the slope
+! parameter sigma. the anisotropy is in gamma - all are input
+! topographic statistics needed. these are calculated off - line
+! as a function of model resolution in the fortran code ml01rg2.f,
+! with script mlb2.sh. (* j *)
+!
+! gwdps_mb.f version (following lmi) elvmax < hncrit (* j *)
+! mb3a expt to enhance elvmax mtn hgt see sigfac & hncrit
+! gwdps_gwdfix_v6.f fixgwd gf6.0 20070608 sigfac = 4.
+!-----------------------------------------------------------------------
+!
+! USE
+! routine is called from gbphys (after call to monnin)
+!
+! PURPOSE
+! using the gwd parameterizations of ps - GLAS and ph -
+! GFDL technique. the time tendencies of u v
+! are altered to include the effect of mountain induced
+! gravity wave drag from sub - grid scale orography including
+! convective breaking, shear breaking and the presence of
+! critical levels
+!
+! INPUT
+! VTGWD (im, km) non-lin tendency for v wind component
+! UTGWD (im, km) non-lin tendency for u wind component
+! TTGWD (im, km) non-lin tendency for temperature
+! U1 (im, km) zonal wind m / sec at t0 - dt
+! V1 (im, km) meridional wind m / sec at t0 - dt
+! T1 (im, km) temperature deg k at t0 - dt
+! Q1 (im, km) specific humidity at t0 - dt
+!
+! delt time step secs
+! SI (n) p / psfc at base of layer n
+! SL (n) p / psfc at middle of layer n
+! DEL (n) positive increment of p / psfc across layer n
+! KPBL (im) is the index of the top layer of the pbl
+!
+! OUTPUT
+! VTGWD, UTGWD as augmented by tendency due to gwdps
+! other input variables unmodified.
+!
+!-----------------------------------------------------------------------
+! REVISION LOG:
+! May 2013 J. Wang change cleff back to opn setting
+! Jan 2014 J. Wang merge henry and fangin's dissipation heat in GFS to nems
+! =======================================================================
+
+subroutine sa_gwd_oro (im, km, u1, v1, t1, q1, delt, gsize, &
+ kpbl, prsi, del, prsl, prslk, phii, phil, &
+ hprime, oc, oa4, clx4, theta, sigma, gamma, elvmax, &
+ utgwd, vtgwd, ttgwd, dusfc, dvsfc, rdxzb)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km
+ integer, intent (in) :: kpbl (im) ! index for the pbl top layer
+
+ real, intent (in) :: delt
+ real, intent (in) :: gsize (im)
+ real, intent (in) :: prsl (im, km), prsi (im, km + 1), del (im, km), &
+ prslk (im, km), phil (im, km), phii (im, km + 1)
+ real, intent (in) :: oc (im), oa4 (im, 4), clx4 (im, 4), hprime (im)
+ real, intent (in) :: elvmax (im), theta (im), sigma (im), gamma (im)
+
+ real, intent (inout) :: u1 (im, km), v1 (im, km), t1 (im, km), q1 (im, km)
+
+ real, intent (out), optional :: utgwd (im, km), vtgwd (im, km), ttgwd (im, km)
+
+ real, intent (out), optional :: dusfc (im), dvsfc (im), rdxzb (im)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ ! for lm mtn blocking
+ real :: wk (im), emax (im)
+ real :: bnv2lm (im, km), pe (im), ek (im), zbk (im), up (im)
+ real :: db (im, km), ang (im, km), uds (im, km)
+ real :: zlen, dbtmp, r, phiang, cdmb (im), dbim
+ real :: eng0, eng1
+
+ ! some constants
+
+ real :: dw2min, rimin, ric, bnv2min, efmin, &
+ efmax, hpmax, hpmin, rad_to_deg, deg_to_rad
+ parameter (rad_to_deg = 180.0 / pi, deg_to_rad = pi / 180.0)
+ parameter (dw2min = 1., rimin = - 100., ric = 0.25, bnv2min = 1.0e-5)
+ ! parameter (efmin = 0.0, efmax = 10.0, hpmax = 200.0)
+ parameter (efmin = 0.0, efmax = 10.0, hpmax = 2400.0, hpmin = 1.0)
+ ! parameter (p_crit = 30.e2)
+
+ real :: frc, ce, ceofrc, frmax, cg, gmax, &
+ veleps, factop, rlolev, rdi
+ ! critac, veleps, factop, rlolev, rdi
+ parameter (frc = 1.0, ce = 0.8, ceofrc = ce / frc, frmax = 100., cg = 0.5)
+ parameter (gmax = 1.0, veleps = 1.0, factop = 0.5)
+ ! parameter (gmax = 1.0, critac = 5.0e-4, veleps = 1.0, factop = 0.5)
+ parameter (rlolev = 50000.0)
+ ! parameter (rlolev = 500.0)
+ ! parameter (rlolev = 0.5)
+
+ real :: dpmin, hminmt, hncrit, minwnd, sigfac
+ ! --- for lm mtn blocking
+ ! parameter (cdmb = 1.0) ! non - dim sub grid mtn drag amp (* j *)
+ parameter (hncrit = 8000.) ! max value in meters for emax (* j *)
+ ! hncrit set to 8000m and sigfac added to enhance emax mtn hgt
+ parameter (sigfac = 4.0) ! mb3a expt test for emax factor (* j *)
+ parameter (hminmt = 50.) ! min mtn height (* j *)
+ parameter (minwnd = 0.1) ! min wind component (* j *)
+
+ ! parameter (dpmin = 00.0) ! minimum thickness of the reference layer
+ !! parameter (dpmin = 05.0) ! minimum thickness of the reference layer
+ ! parameter (dpmin = 20.0) ! minimum thickness of the reference layer
+ ! in centibars
+ parameter (dpmin = 5000.0) ! minimum thickness of the reference layer
+ ! in pa
+
+ real :: fdir
+ integer :: mdir
+ parameter (mdir = 8, fdir = mdir / (pi + pi))
+ integer :: nwdir (mdir)
+ data nwdir / 6, 7, 5, 8, 2, 3, 1, 4 /
+ save nwdir
+
+ logical :: icrilv (im)
+
+ ! ---- mountain induced gravity wave drag
+
+ real :: taub (im), xn (im), yn (im), ubar (im), &
+ vbar (im), ulow (im), oa (im), clx (im), &
+ roll (im), uloi (im), &
+ dtfac (im), xlinv (im), delks (im), delks1 (im)
+
+ real :: bnv2 (im, km), taup (im, km + 1), ri_n (im, km), &
+ taud (im, km), ro (im, km), vtk (im, km), &
+ vtj (im, km), scor (im), velco (im, km - 1), &
+ bnv2bar (im)
+
+ ! real :: velko (km - 1)
+ integer :: kref (im), kint (im), iwk (im), ipt (im)
+ ! for lm mtn blocking
+ integer :: kreflm (im), iwklm (im)
+ integer :: idxzb (im), ktrial, klevm1
+
+ real :: gor, gocp, gr2, bnv, fr, &
+ brvf, cleff (im), tem, tem1, tem2, temc, temv, &
+ wdir, ti, rdz, dw2, shr2, bvf2, &
+ rdelks, efact, coefm, gfobnv, &
+ scork, rscor, hd, fro, rim, sira, &
+ dtaux, dtauy, pkp1log, pklog
+ integer :: kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1, kbpsm1, &
+ kmps, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, &
+ kmll
+ ! kmll, kmds, ihit, jhit
+
+ ! parameter (cdmb = 1.0) ! non - dim sub grid mtn drag amp (* j *)
+ ! non - dim sub grid mtn drag amp (* j *)
+ ! cdmb = 1.0 / float (imx / 192)
+ ! cdmb = 192.0 / float (imx)
+ ! cdmb = 4.0 * 192.0 / float (imx)
+ do i = 1, im
+ cdmb (i) = 2.e-5 * gsize (i)
+ if (cdmbgwd (1) >= 0.0) cdmb (i) = cdmb (i) * cdmbgwd (1)
+ enddo
+
+ do i = 1, im
+ emax (i) = elvmax (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (present (utgwd)) utgwd (i, k) = 0.
+ if (present (vtgwd)) vtgwd (i, k) = 0.
+ if (present (ttgwd)) ttgwd (i, k) = 0.
+ enddo
+ enddo
+
+ do i = 1, im
+ if (present (dusfc)) dusfc (i) = 0.
+ if (present (dvsfc)) dvsfc (i) = 0.
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ db (i, k) = 0.
+ ang (i, k) = 0.
+ uds (i, k) = 0.
+ enddo
+ enddo
+
+ rdi = 1.0 / rdgas
+ gor = grav / rdgas
+ gr2 = grav * gor
+ gocp = grav / cp_air
+
+ ! ncnt = 0
+ kmm1 = km - 1
+ kmm2 = km - 2
+ lcap = km
+ lcapp1 = lcap + 1
+
+
+ if (nmtvr .eq. 14) then
+ ! ---- for lm and gwd calculation points
+ if (present (rdxzb)) rdxzb (:) = 0.
+ ipt = 0
+ npt = 0
+ do i = 1, im
+ if ((emax (i) .gt. hminmt) .and. (hprime (i) .gt. hpmin)) then
+ npt = npt + 1
+ ipt (npt) = i
+ endif
+ enddo
+ if (npt .eq. 0) return ! no gwd / mb calculation done
+
+ ! if (lprnt) print *, ' npt = ', npt, ' npr = ', npr, ' ipr = ', ipr, ' im = ', im, &
+ ! ' ipt (npt) = ', ipt (npt)
+
+ ! --- iwklm is the level above the height of the of the mountain.
+ ! --- idxzb is the level of the dividing streamline.
+ ! initialize dividing streamline (ds) control vector
+
+ do i = 1, npt
+ iwklm (i) = 2
+ idxzb (i) = 0
+ kreflm (i) = 0
+ enddo
+ ! if (lprnt) print *, ' in gwdps_lm.f npt, im, km, me = ', npt, im, km, me
+
+
+ ! > --- subgrid mountain blocking section
+
+ !..............................
+ !..............................
+
+ ! (* j *) 11 / 03: test upper limit on kmll = km - 1
+ ! then do not need hncrit -- test with large hncrit first.
+ ! kmll = km / 2 ! maximum mtnlm height : # of vertical levels / 2
+ kmll = kmm1
+ ! --- no mtn should be as high as kmll (so we do not have to start at
+ ! --- the top of the model but could do calc for all levels) .
+
+ do i = 1, npt
+ j = ipt (i)
+ emax (j) = min (emax (j) + sigfac * hprime (j), hncrit)
+ enddo
+
+ do k = 1, kmll
+ do i = 1, npt
+ j = ipt (i)
+ ! --- interpolate to max mtn height for index, iwklm (i) wk[gz]
+ ! --- emax is limited to hncrit because to hi res topo30 orog.
+ pkp1log = phil (j, k + 1) / grav
+ pklog = phil (j, k) / grav
+ !!! ------- emax (j) = min (emax (j) + sigfac * hprime (j), hncrit)
+ if ((emax (j) .le. pkp1log) .and. (emax (j) .ge. pklog)) then
+ ! print *, ' in gwdps_lm.f 1 = ', k, emax (j), pklog, pkp1log, me
+ ! --- wk for diags but can be saved and reused.
+ wk (i) = grav * emax (j) / (phil (j, k + 1) - phil (j, k))
+ iwklm (i) = max (iwklm (i), k + 1)
+ ! print *, ' in gwdps_lm.f 2 npt = ', npt, i, j, wk (i), iwklm (i), me
+ endif
+
+ ! --- find at prsl levels large scale environment variables
+ ! --- these cover all possible mtn max heights
+ vtj (i, k) = t1 (j, k) * (1. + zvir * q1 (j, k))
+ vtk (i, k) = vtj (i, k) / prslk (j, k)
+ ro (i, k) = rdi * prsl (j, k) / vtj (i, k) ! density kg / m ** 3
+ enddo
+ enddo
+
+ ! testing for highest model level of mountain top
+
+ ! ihit = 2
+ ! jhit = 0
+ ! do i = 1, npt
+ ! j = ipt (i)
+ ! if (iwklm (i) .gt. ihit) then
+ ! ihit = iwklm (i)
+ ! jhit = j
+ ! endif
+ ! enddo
+ ! print *, ' mb: kdt, max (iwklm), jhit, phil, me = ', &
+ ! kdt, ihit, jhit, phil (jhit, ihit), me
+
+ klevm1 = kmll - 1
+ do k = 1, klevm1
+ do i = 1, npt
+ j = ipt (i)
+ rdz = grav / (phil (j, k + 1) - phil (j, k))
+ ! --- brunt - vaisala frequency
+ ! > - compute brunt - vaisala frequency \f$n\f$.
+ bnv2lm (i, k) = (grav + grav) * rdz * (vtk (i, k + 1) - vtk (i, k)) &
+ / (vtk (i, k + 1) + vtk (i, k))
+ bnv2lm (i, k) = max (bnv2lm (i, k), bnv2min)
+ enddo
+ enddo
+ ! print *, ' in gwdps_lm.f 3 npt = ', npt, j, rdz, me
+
+ do i = 1, npt
+ j = ipt (i)
+ delks (i) = 1.0 / (prsi (j, 1) - prsi (j, iwklm (i)))
+ delks1 (i) = 1.0 / (prsl (j, 1) - prsl (j, iwklm (i)))
+ ubar (i) = 0.0
+ vbar (i) = 0.0
+ roll (i) = 0.0
+ pe (i) = 0.0
+ ek (i) = 0.0
+ bnv2bar (i) = (prsl (j, 1) - prsl (j, 2)) * delks1 (i) * bnv2lm (i, 1)
+ enddo
+
+ ! --- find the dividing stream line height
+ ! --- starting from the level above the max mtn downward
+ ! --- iwklm (i) is the k - index of mtn emax elevation
+ ! > - find the dividing streamline height starting from the level above
+ !! the maximum mountain height and processing downward.
+ do ktrial = kmll, 1, - 1
+ do i = 1, npt
+ if (ktrial .lt. iwklm (i) .and. kreflm (i) .eq. 0) then
+ kreflm (i) = ktrial
+ endif
+ enddo
+ enddo
+ ! print *, ' in gwdps_lm.f 4 npt = ', npt, kreflm (npt), me
+
+ ! --- in the layer kreflm (i) to 1 find pe (which needs n, emax)
+ ! --- make averages, guess dividing stream (ds) line layer.
+ ! --- this is not used in the first cut except for testing and
+ ! --- is the vert ave of quantities from the surface to mtn top.
+
+ do i = 1, npt
+ do k = 1, kreflm (i)
+ j = ipt (i)
+ rdelks = del (j, k) * delks (i)
+ ubar (i) = ubar (i) + rdelks * u1 (j, k) ! trial mean u below
+ vbar (i) = vbar (i) + rdelks * v1 (j, k) ! trial mean v below
+ roll (i) = roll (i) + rdelks * ro (i, k) ! trial mean ro below
+ rdelks = (prsl (j, k) - prsl (j, k + 1)) * delks1 (i)
+ bnv2bar (i) = bnv2bar (i) + bnv2lm (i, k) * rdelks
+ ! --- these vert ave are for diags, testing and gwd to follow (* j *) .
+ enddo
+ enddo
+ ! print *, ' in gwdps_lm.f 5 = ', i, kreflm (npt), bnv2bar (npt), me
+
+ ! --- integrate to get pe in the trial layer.
+ ! --- need the first layer where pe > ek - as soon as
+ ! --- idxzb is not 0 we have a hit and zb is found.
+
+ do i = 1, npt
+ j = ipt (i)
+ do k = iwklm (i), 1, - 1
+ phiang = atan2 (v1 (j, k), u1 (j, k)) * rad_to_deg
+ ang (i, k) = (theta (j) - phiang)
+ if (ang (i, k) .gt. 90.) ang (i, k) = ang (i, k) - 180.
+ if (ang (i, k) .lt. - 90.) ang (i, k) = ang (i, k) + 180.
+ ang (i, k) = ang (i, k) * deg_to_rad
+
+ ! > - compute wind speed uds
+ !!\f[
+ !! uds = \max (\sqrt{u1^2 + v1^2}, minwnd)
+ !!\f]
+ !! where \f$ minwnd = 0.1 \f$, \f$u1\f$ and \f$v1\f$ are zonal and
+ !! meridional wind components of model layer wind.
+ uds (i, k) = &
+ max (sqrt (u1 (j, k) * u1 (j, k) + v1 (j, k) * v1 (j, k)), minwnd)
+ ! --- test to see if we found zb previously
+ if (idxzb (i) .eq. 0) then
+ pe (i) = pe (i) + bnv2lm (i, k) * &
+ (grav * emax (j) - phil (j, k)) * &
+ (phii (j, k + 1) - phii (j, k)) / (grav * grav)
+ ! --- ke
+ ! --- wind projected on the line perpendicular to mtn range, u (zb (k)) .
+ ! --- kenetic energy is at the layer zb
+ ! --- theta ranges from - + 90deg |_ to the mtn "largest topo variations"
+ up (i) = uds (i, k) * cos (ang (i, k))
+ ek (i) = 0.5 * up (i) * up (i)
+
+ ! --- dividing stream lime is found when pe = exceeds ek.
+ if (pe (i) .ge. ek (i)) then
+ idxzb (i) = k
+ if (present (rdxzb)) rdxzb (j) = real (k)
+ endif
+ ! --- then mtn blocked flow is between zb = k (idxzb (i)) and surface
+
+ ! > - the dividing streamline height (idxzb), of a subgrid scale
+ !! obstable, is found by comparing the potential (pe) and kinetic
+ !! energies (ek) of the upstream large scale wind and subgrid scale air
+ !! parcel movements. the dividing streamline is found when
+ !! \f$pe\geq ek\f$. mountain - blocked flow is defined to exist between
+ !! the surface and the dividing streamline height (\f$h_d\f$), which
+ !! can be found by solving an integral equation for \f$h_d\f$:
+ !!\f[
+ !! \frac{u^{2} (h_{d}) }{2} = \int_{h_{d}}^{h} n^{2} (z) (h - z) dz
+ !!\f]
+ !! where \f$h\f$ is the maximum subgrid scale elevation within the grid
+ !! box of actual orography, \f$h\f$, obtained from the gtopo30 dataset
+ !! from the u.s. geological survey.
+ endif
+ enddo
+ enddo
+
+ ! print *, ' in gwdps_lm.f 6 = ', phiang, theta (ipt (npt)), me
+ ! print *, ' in gwdps_lm.f 7 = ', idxzb (npt), pe (npt)
+
+ ! if (lprnt .and. npr .gt. 0) then
+ ! print *, ' bnv2bar, bnv2lm = ', bnv2bar (npr), bnv2lm (npr, 1:klevm1)
+ ! print *, ' npr, idxzb, uds = ', npr, idxzb (npr), uds (npr, :)
+ ! print *, ' pe, up, ek = ', pe (npr), up (npr), ek (npr)
+ ! endif
+
+ do i = 1, npt
+ j = ipt (i)
+ ! --- calc if n constant in layers (zb guess) - a diagnostic only.
+ zbk (i) = emax (j) &
+ - sqrt (ubar (i) * ubar (i) + vbar (i) * vbar (i)) / bnv2bar (i)
+ enddo
+
+ ! if (lprnt .and. npr .gt. 0) then
+ ! print *, ' iwklm, zbk = ', iwklm (npr), zbk (npr), idxzb (npr)
+ ! print *, ' zb = ', phil (ipr), idxzb (npr)) / grav
+ ! print *, ' in gwdps_lm.f 8 npt = ', npt, zbk (npt), up (npt), me
+ ! endif
+
+ ! --- the drag for mtn blocked flow
+
+ do i = 1, npt
+ j = ipt (i)
+ zlen = 0.
+ ! print *, ' in gwdps_lm.f 9 = ', i, j, idxzb (i), me
+ if (idxzb (i) .gt. 0) then
+ do k = idxzb (i), 1, - 1
+ if (phil (j, idxzb (i)) .gt. phil (j, k)) then
+
+ ! > - calculate \f$zlen\f$, which sums up a number of contributions of
+ !! elliptic obstables.
+ !!\f[
+ !! zlen = \sqrt{[\frac{h_{d} - z}{z + h'}]}
+ !!\f]
+ !! where \f$z\f$ is the height, \f$h'\f$ is the orographic standard
+ !! deviation (hprime) .
+ zlen = sqrt ((phil (j, idxzb (i)) - phil (j, k)) / &
+ (phil (j, k) + grav * hprime (j)))
+ ! --- lm eq 14:
+ ! > - calculate the drag coefficient to vary with the aspect ratio of
+ !! the obstable as seen by the incident flow (see eq.14 in lott and
+ !! miller (1997) \cite lott_and_miller_1997)
+ !!\f[
+ !! r = \frac{\cos^{2}\psi + \gamma\sin^{2}\psi}{\gamma\cos^{2}\psi + \sin^{2}\psi}
+ !!\f]
+ !! where \f$\psi\f$, which is derived from theta, is the angle between
+ !! the incident flow direction and the normal ridge direcion.
+ !! \f$\gamma\f$ is the orographic anisotropy (gamma) .
+ r = cos (ang (i, k)) ** 2 + gamma (j) * sin (ang (i, k)) ** 2
+ if (abs (r) .lt. 1.e-20) then
+ db (i, k) = 0.0
+ else
+ r = (gamma (j) * cos (ang (i, k)) ** 2 + sin (ang (i, k)) ** 2) / r
+ ! --- (negitive of db -- see sign at tendency)
+ ! > - in each model layer below the dividing streamlines, a drag from
+ !! the blocked flow is exerted by the obstacle on the large scale flow.
+ !! the drag per unit area and per unit height is written (eq.15 in
+ !! lott and miller (1997) \cite lott_and_miller_1997) :
+ !!\f[
+ !! d_{b} (z) = - c_{d}\max (2 - \frac{1}{r}, 0) \rho\frac{\sigma}{2h'}zlen\max (\cos\psi, \gamma\sin\psi) \frac{uds}{2}
+ !!\f]
+ !! where \f$c_{d}\f$ is a specified constant, \f$\sigma\f$ is the
+ !! orographic slope.
+
+ dbtmp = 0.25 * cdmb (j) * &
+ max (2. - r, 0.) * sigma (j) * &
+ max (cos (ang (i, k)), gamma (j) * sin (ang (i, k))) * &
+ zlen / hprime (j)
+ db (i, k) = dbtmp * uds (i, k)
+ endif
+
+ ! if (lprnt .and. i .eq. npr) then
+ ! print *, ' in gwdps_lmi.f 10 npt = ', npt, i, j, idxzb (i), &
+ ! dbtmp, r' ang = ', ang (i, k), ' gamma = ', gamma (j), ' k = ', k
+ ! print *, ' in gwdps_lmi.f 11 k = ', k, zlen, cos (ang (i, k))
+ ! print *, ' in gwdps_lmi.f 12 db = ', db (i, k), sin (ang (i, k))
+ ! endif
+ endif
+ enddo
+ ! if (lprnt) print *, ' @k = 1, zlen, dbtmp = ', k, zlen, dbtmp
+ endif
+ enddo
+
+ !.............................
+ !.............................
+ ! end mtn blocking section
+
+ elseif (nmtvr .ne. 14) then
+ ! ---- for mb not present and gwd (nmtvr .ne .14)
+ ipt = 0
+ npt = 0
+ do i = 1, im
+ if (hprime (i) .gt. hpmin) then
+ npt = npt + 1
+ ipt (npt) = i
+ endif
+ enddo
+ if (npt .eq. 0) return ! no gwd / mb calculation done
+
+ ! if (lprnt) print *, ' npr = ', npr, ' npt = ', npt, ' ipr = ', ipr, &
+ ! ' ipt (npt) = ', ipt (npt)
+
+ do i = 1, npt
+ idxzb (i) = 0
+ if (present (rdxzb)) rdxzb (i) = 0.
+ enddo
+ endif
+
+ !.............................
+ !.............................
+
+ ! > --- orographic gravity wave drag section
+ kmpbl = km / 2 ! maximum pbl height : # of vertical levels / 2
+
+ ! scale cleff between im = 384 * 2 and 192 * 2 for t126 / t170 and t62
+
+ !if (imx .gt. 0) then
+ !cleff = 1.0e-5 * sqrt (float (imx) / 384.0) ! this is inverse of cleff
+ !cleff = 1.0e-5 * sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !cleff = 0.5e-5 * sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !cleff = 1.0e-5 * sqrt (float (imx) / 192) / float (imx / 192)
+ !cleff = 1.0e-5 / sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !cleff = 0.5e-5 / sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !hmhj for ndsl
+ !jw cleff = 0.1e-5 / sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !cleff = 2.0e-5 * sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !cleff = 2.5e-5 * sqrt (float (imx) / 192.0) ! this is inverse of cleff
+ !ndif
+ do i = 1, im
+ cleff (i) = 0.25e-5 * sqrt (2.e-5 * gsize (i))
+ if (cdmbgwd (2) >= 0.0) cleff (i) = cleff (i) * cdmbgwd (2)
+ enddo
+
+ do k = 1, km
+ do i = 1, npt
+ j = ipt (i)
+ vtj (i, k) = t1 (j, k) * (1. + zvir * q1 (j, k))
+ vtk (i, k) = vtj (i, k) / prslk (j, k)
+ ro (i, k) = rdi * prsl (j, k) / vtj (i, k) ! density tons / m ** 3
+ taup (i, k) = 0.0
+ enddo
+ enddo
+ do k = 1, kmm1
+ do i = 1, npt
+ j = ipt (i)
+ ti = 2.0 / (t1 (j, k) + t1 (j, k + 1))
+ tem = ti / (prsl (j, k) - prsl (j, k + 1))
+ rdz = grav / (phil (j, k + 1) - phil (j, k))
+ tem1 = u1 (j, k) - u1 (j, k + 1)
+ tem2 = v1 (j, k) - v1 (j, k + 1)
+ dw2 = tem1 * tem1 + tem2 * tem2
+ shr2 = max (dw2, dw2min) * rdz * rdz
+ bvf2 = grav * (gocp + rdz * (vtj (i, k + 1) - vtj (i, k))) * ti
+ ri_n (i, k) = max (bvf2 / shr2, rimin) ! richardson number
+ ! brunt - vaisala frequency
+ ! tem = gr2 * (prsl (j, k) + prsl (j, k + 1)) * tem
+ ! bnv2 (i, k) = tem * (vtk (i, k + 1) - vtk (i, k)) / (vtk (i, k + 1) + vtk (i, k))
+ bnv2 (i, k) = (grav + grav) * rdz * (vtk (i, k + 1) - vtk (i, k)) &
+ / (vtk (i, k + 1) + vtk (i, k))
+ bnv2 (i, k) = max (bnv2 (i, k), bnv2min)
+ enddo
+ enddo
+ ! print *, ' in gwdps_lm.f gwd:14 = ', npt, kmm1, bnv2 (npt, kmm1)
+
+ ! apply 3 point smoothing on bnv2
+
+ ! do k = 1, km
+ ! do i = 1, im
+ ! vtk (i, k) = bnv2 (i, k)
+ ! enddo
+ ! enddo
+ ! do k = 2, kmm1
+ ! do i = 1, im
+ ! bnv2 (i, k) = 0.25 * (vtk (i, k - 1) + vtk (i, k + 1)) + 0.5 * vtk (i, k)
+ ! enddo
+ ! enddo
+
+ ! finding the first interface index above 50 hpa level
+
+ do i = 1, npt
+ iwk (i) = 2
+ enddo
+ do k = 3, kmpbl
+ do i = 1, npt
+ j = ipt (i)
+ tem = (prsi (j, 1) - prsi (j, k))
+ if (tem .lt. dpmin) iwk (i) = k
+ enddo
+ enddo
+
+ ! > - calculate the reference level index: kref = max (2, kpbl + 1) . where
+ !! kpbl is the index for the pbl top layer.
+ kbps = 1
+ kmps = km
+ do i = 1, npt
+ j = ipt (i)
+ kref (i) = max (iwk (i), kpbl (j) + 1) ! reference level
+ delks (i) = 1.0 / (prsi (j, 1) - prsi (j, kref (i)))
+ delks1 (i) = 1.0 / (prsl (j, 1) - prsl (j, kref (i)))
+ ubar (i) = 0.0
+ vbar (i) = 0.0
+ roll (i) = 0.0
+ kbps = max (kbps, kref (i))
+ kmps = min (kmps, kref (i))
+
+ bnv2bar (i) = (prsl (j, 1) - prsl (j, 2)) * delks1 (i) * bnv2 (i, 1)
+ enddo
+ ! print *, ' in gwdps_lm.f gwd:15 = ', kbps, kmps
+ kbpsp1 = kbps + 1
+ kbpsm1 = kbps - 1
+ do k = 1, kbps
+ do i = 1, npt
+ if (k .lt. kref (i)) then
+ j = ipt (i)
+ rdelks = del (j, k) * delks (i)
+ ubar (i) = ubar (i) + rdelks * u1 (j, k) ! mean u below kref
+ vbar (i) = vbar (i) + rdelks * v1 (j, k) ! mean v below kref
+
+ roll (i) = roll (i) + rdelks * ro (i, k) ! mean ro below kref
+ rdelks = (prsl (j, k) - prsl (j, k + 1)) * delks1 (i)
+ bnv2bar (i) = bnv2bar (i) + bnv2 (i, k) * rdelks
+ endif
+ enddo
+ enddo
+ ! print *, ' in gwdps_lm.f gwd:15b = ', bnv2bar (npt)
+
+ ! figure out low - level horizontal wind direction and find 'oa'
+
+ ! nwd 1 2 3 4 5 6 7 8
+ ! wd w s sw nw e n ne se
+
+ ! > - calculate low - level horizontal wind direction, the derived
+ !! orographic asymmetry parameter (oa), and the derived lx (clx) .
+ do i = 1, npt
+ j = ipt (i)
+ wdir = atan2 (ubar (i), vbar (i)) + pi
+ idir = mod (nint (fdir * wdir), mdir) + 1
+ nwd = nwdir (idir)
+ oa (i) = (1 - 2 * int ((nwd - 1) / 4)) * oa4 (j, mod (nwd - 1, 4) + 1)
+ clx (i) = clx4 (j, mod (nwd - 1, 4) + 1)
+ enddo
+
+ ! ----- xn, yn "low - level" wind projections in zonal &
+ ! meridional directions
+ ! ----- ulow "low - level" wind magnitude - (= u)
+ ! ----- bnv2 bnv2 = n ** 2
+ ! ----- taub base momentum flux
+ ! ----- = - (ro * u ** 3 / (n * xl) * gf (fr) for n ** 2 > 0
+ ! ----- = 0. for n ** 2 < 0
+ ! ----- fr froude = n * hprime / u
+ ! ----- g gmax * fr ** 2 / (fr ** 2 + cg / oc)
+
+ ! ----- initialize some arrays
+
+ do i = 1, npt
+ xn (i) = 0.0
+ yn (i) = 0.0
+ taub (i) = 0.0
+ ulow (i) = 0.0
+ dtfac (i) = 1.0
+ icrilv (i) = .false. ! initialize critical level control vector
+
+
+ ! ---- compute the "low level" wind magnitude (m / s)
+
+ ulow (i) = max (sqrt (ubar (i) * ubar (i) + vbar (i) * vbar (i)), 1.0)
+ uloi (i) = 1.0 / ulow (i)
+ enddo
+
+ do k = 1, kmm1
+ do i = 1, npt
+ j = ipt (i)
+ velco (i, k) = 0.5 * ((u1 (j, k) + u1 (j, k + 1)) * ubar (i) &
+ + (v1 (j, k) + v1 (j, k + 1)) * vbar (i))
+ velco (i, k) = velco (i, k) * uloi (i)
+ ! if ((velco (i, k) .lt.veleps) .and. (velco (i, k) .gt.0.)) then
+ ! velco (i, k) = veleps
+ ! endif
+ enddo
+ enddo
+
+
+ ! find the interface level of the projected wind where
+ ! low levels & upper levels meet above pbl
+
+ ! do i = 1, npt
+ ! kint (i) = km
+ ! enddo
+ ! do k = 1, kmm1
+ ! do i = 1, npt
+ ! if (k .gt. kref (i)) then
+ ! if (velco (i, k) .lt. veleps .and. kint (i) .eq. km) then
+ ! kint (i) = k + 1
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+ ! warning kint = kref !!!!!!!!
+ do i = 1, npt
+ kint (i) = kref (i)
+ enddo
+
+ ! if (lprnt) print *, ' ubar = ', ubar, &
+ ! ' vbar = ', vbar, ' ulow = ', ulow, ' veleps = ', veleps
+
+ do i = 1, npt
+ j = ipt (i)
+ bnv = sqrt (bnv2bar (i))
+ fr = bnv * uloi (i) * min (hprime (j), hpmax)
+ fr = min (fr, frmax)
+ xn (i) = ubar (i) * uloi (i)
+ yn (i) = vbar (i) * uloi (i)
+
+ ! compute the base level stress and store it in taub
+ ! calculate enhancement factor, number of mountains & aspect
+ ! ratio const. use simplified relationship between standard
+ ! deviation & critical hgt
+
+ ! > - calculate enhancement factor (e), number of mountans (m') and
+ !! aspect ratio constant.
+ !!\n as in eq. (4.9), (4.10), (4.11) in kim and arakawa (1995)
+ !! \cite kim_and_arakawa_1995, we define m' and e in such a way that they
+ !! depend on the geometry and location of the subgrid - scale orography
+ !! through oa and the nonlinearity of flow above the orography through
+ !! fr. oc, which is the orographic convexity, and statistically
+ !! determine how protruded (sharp) the subgrid - scale orography is, is
+ !! included in the saturation flux g' in such a way that g' is
+ !! proportional to oc. the forms of e, m' and g' are:
+ !!\f[
+ !! e (oa, f_{r_{0}}) = (oa + 2) ^{\delta}
+ !!\f]
+ !!\f[
+ !! \delta = c_{e}f_{r_{0}} / f_{r_{c}}
+ !!\f]
+ !!\f[
+ !! m' (oa, clx) = c_{m}\triangle x (1 + clx) ^{oa + 1}
+ !!\f]
+ !!\f[
+ !! g' (oc, f_{r_{0}}) = \frac{f_{r_{0}}^2}{f_{r_{0}}^2 + a^{2}}
+ !!\f]
+ !!\f[
+ !! a^{2} = c_{g}oc^{ - 1}
+ !!\f]
+ !! where \f$f_{r_{c}} (= 1) \f$ is the critical froude number,
+ !! \f$f_{r_{0}}\f$ is the froude number. \f$c_{e}\f$, \f$c_{m}\f$,
+ !! \f$c_{g}\f$ are constants.
+
+ ! > - calculate the reference - level drag \f$\tau_{0}\f$ (eq. (4.8) in
+ !! kim and arakawa (1995) \cite kim_and_arakawa_1995) :
+ !!\f[
+ !! \tau_0 = e\frac{m'}{\triangle x}\frac{\rho_{0}u_0^3}{n_{0}}g'
+ !!\f]
+ !! where \f$e\f$, \f$m'\f$, and \f$g'\f$ are the enhancement factor,
+ !! "the number of mountains", and the flux function defined above,
+ !! respectively.
+
+ efact = (oa (i) + 2.) ** (ceofrc * fr)
+ efact = min (max (efact, efmin), efmax)
+
+ coefm = (1. + clx (i)) ** (oa (i) + 1.)
+
+ xlinv (i) = coefm * cleff (j)
+
+ tem = fr * fr * oc (j)
+ gfobnv = gmax * tem / ((tem + cg) * bnv) ! g / n0
+
+ taub (i) = xlinv (i) * roll (i) * ulow (i) * ulow (i) &
+ * ulow (i) * gfobnv * efact ! base flux tau0
+
+ ! tem = min (hprime (i), hpmax)
+ ! taub (i) = xlinv (i) * roll (i) * ulow (i) * bnv * tem * tem
+
+ k = max (1, kref (i) - 1)
+ tem = max (velco (i, k) * velco (i, k), 0.1)
+ scor (i) = bnv2 (i, k) / tem ! scorer parameter below ref level
+ enddo
+ ! if (lprnt) print *, ' taub = ', taub
+
+ ! ---- set up bottom values of stress
+
+ do k = 1, kbps
+ do i = 1, npt
+ if (k .le. kref (i)) taup (i, k) = taub (i)
+ enddo
+ enddo
+
+ ! now compute vertical structure of the stress.
+
+ do k = kmps, kmm1 ! vertical level k loop
+ kp1 = k + 1
+ do i = 1, npt
+
+ ! ----- unstable layer if ri < ric
+ ! ----- unstable layer if upper air vel comp along surf vel <= 0 (crit lay)
+ ! ---- at (u - c) = 0. crit layer exists and bit vector should be set (.le.)
+
+ if (k .ge. kref (i)) then
+ icrilv (i) = icrilv (i) .or. (ri_n (i, k) .lt. ric) &
+ .or. (velco (i, k) .le. 0.0)
+ endif
+ enddo
+
+ ! > - compute the drag above the reference level (\f$k\geq kref\f$) :
+ !! - calculate the ratio of the scorer parameter (\f$r_{scor}\f$) .
+ !! \n from a series of experiments, kim and arakawa (1995)
+ !! \cite kim_and_arakawa_1995 found that the magnitude of drag divergence
+ !! tends to be underestimated by the revised scheme in low - level
+ !! downstream regions with wave breaking. therefore, at low levels when
+ !! oa > 0 (i.e., in the "downstream" region) the saturation hypothesis
+ !! is replaced by the following formula based on the ratio of the
+ !! the scorer parameter:
+ !!\f[
+ !! r_{scor} = \min \left[\frac{\tau_i}{\tau_{i + 1}}, 1\right]
+ !!\f]
+ do i = 1, npt
+ if (k .ge. kref (i)) then
+ if (.not.icrilv (i) .and. taup (i, k) .gt. 0.0) then
+ temv = 1.0 / max (velco (i, k), 0.01)
+ ! if (oa (i) .gt. 0. .and. prsi (ipt (i), kp1) .gt.rlolev) then
+ if (oa (i) .gt.0. .and. kp1 .lt. kint (i)) then
+ scork = bnv2 (i, k) * temv * temv
+ rscor = min (1.0, scork / scor (i))
+ scor (i) = scork
+ else
+ rscor = 1.
+ endif
+
+ ! > - the drag above the reference level is expressed as:
+ !!\f[
+ !! \tau = \frac{m'}{\triangle x}\rho nuh_d^2
+ !!\f]
+ !! where \f$h_{d}\f$ is the displacement wave amplitude. in the absence
+ !! of wave breaking, the displacement amplitude for the \f$i^{th}\f$
+ !! layer can be expressed using the drag for the layer immediately
+ !! below. thus, assuming \f$\tau_i = \tau_{i + 1}\f$, we can get:
+ !!\f[
+ !! h_{d_i}^2 = \frac{\triangle x}{m'}\frac{\tau_{i + 1}}{\rho_{i}n_{i}u_{i}}
+ !!\f]
+
+ brvf = sqrt (bnv2 (i, k)) ! brunt - vaisala frequency
+ ! tem1 = xlinv (i) * (ro (i, kp1) + ro (i, k)) * brvf * velco (i, k) * 0.5
+ tem1 = xlinv (i) * (ro (i, kp1) + ro (i, k)) * brvf * 0.5&
+ * max (velco (i, k), 0.01)
+ hd = sqrt (taup (i, k) / tem1)
+ fro = brvf * hd * temv
+
+ ! rim is the minimum - richardson number by shutts (1985)
+
+ ! > - the minimum richardson number (\f$ri_{m}\f$) or local
+ !! wave - modified richardson number, which determines the onset of wave
+ !! breaking, is expressed in terms of \f$r_{i}\f$ and
+ !! \f$f_{r_{d}} = nh_{d} / u\f$:
+ !!\f[
+ !! ri_{m} = \frac{ri (1 - fr_{d}) }{ (1 + \sqrt{ri}\cdot fr_{d}) ^{2}}
+ !!\f]
+ !! see eq. (4.6) in kim and arakawa (1995) \cite kim_and_arakawa_1995.
+
+ tem2 = sqrt (ri_n (i, k))
+ tem = 1. + tem2 * fro
+ rim = ri_n (i, k) * (1. - fro) / (tem * tem)
+
+ ! check stability to employ the 'saturation hypothesis'
+ ! of lindzen (1981) except at tropospheric downstream regions
+
+ ! > - check stability to employ the 'saturation hypothesis' of lindzen
+ !! (1981) \cite lindzen_1981 except at tropospheric downstream regions.
+ !! \n wave breaking occurs when \f$ri_{m} < ri_{c} = 0.25\f$. then
+ !! lindzen's wave saturation hypothesis resets the displacement
+ !! amplitude \f$h_{d}\f$ to that corresponding to \f$ri_{m} = 0.25\f$,
+ !! we obtain the critical \f$h_{d}\f$ (or \f$h_{c}\f$) expressed in
+ !! terms of the mean values of \f$u\f$, \f$n\f$, and \f$ri\f$ (
+ !! eq. (4.7) in kim and arakawa (1995) \cite kim_and_arakawa_1995) :
+ !!\f[
+ !! h_{c} = \frac{u}{n}\left\{2 (2 + \frac{1}{\sqrt{ri}}) ^{1 / 2} - (2 + \frac{1}{\sqrt{ri}}) \right\}
+ !!\f]
+ !! if \f$ri_{m}\leq ri_{c}\f$, obtain \f$\tau\f$ from the drag above
+ !! the reference level by using \f$h_{c}\f$ computed above; otherwise
+ !! \f$\tau\f$ is unchanged (note: scaled by the ratio of the scorer
+ !! paramter) .
+ ! ----------------------
+ if (rim .le. ric .and. (oa (i) .le. 0. .or. kp1 .ge. kint (i))) then
+ ! & if (rim .le. ric .and. (oa (i) .le. 0. .or. prsi (ipt (i), kp1) .le.rlolev)) then
+ temc = 2.0 + 1.0 / tem2
+ hd = velco (i, k) * (2. * sqrt (temc) - temc) / brvf
+ taup (i, kp1) = tem1 * hd * hd
+ else
+ taup (i, kp1) = taup (i, k) * rscor
+ endif
+ taup (i, kp1) = min (taup (i, kp1), taup (i, k))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! taup (i, km + 1) = taup (i, km)
+ ! enddo
+
+ if (lcap .le. km) then
+ do klcap = lcapp1, km + 1
+ do i = 1, npt
+ sira = prsi (ipt (i), klcap) / prsi (ipt (i), lcap)
+ taup (i, klcap) = sira * taup (i, lcap)
+ enddo
+ enddo
+ endif
+ ! sjl: linear decay above p_crit, becoming constant at 1 mb
+ ! angular momentum conservation is ensured, except the top leakage
+ ! ----------------------- sjl mod ------------------------------
+ if (p_crit > 1.e-10) then
+ do i = 1, npt
+ j = ipt (i)
+ do k = km / 2, km + 1
+ if (prsi (j, k) < p_crit) then ! scale it to zero @ top
+ taup (i, k) = taup (i, k) * (prsi (j, k) - prsi (j, km + 1)) / &
+ (p_crit - prsi (j, km + 1))
+ elseif (prsi (j, k) < 1.e2) then
+ taup (i, k) = taup (i, k - 1) ! constant stress - > zero drag
+ endif
+ enddo
+ enddo
+ endif
+ ! ----------------------- sjl mod ------------------------------
+
+
+ ! calculate - (grav / p *) * d (tau) / d (sigma) and decel terms dtaux, dtauy
+
+ do k = 1, km
+ do i = 1, npt
+ taud (i, k) = grav * (taup (i, k + 1) - taup (i, k)) / del (ipt (i), k)
+ enddo
+ enddo
+
+ ! ------ limit de - acceleration (momentum deposition) at top to 1 / 2 value
+ ! ------ the idea is some stuff must go out the 'top'
+
+ if (p_crit <= 1.e-10) then
+ do klcap = lcap, km
+ do i = 1, npt
+ taud (i, klcap) = taud (i, klcap) * factop
+ enddo
+ enddo
+ endif
+
+ ! ------ if the gravity wave drag would force a critical line in the
+ ! ------ layers below sigma = rlolev during the next delt timestep,
+ ! ------ then only apply drag until that critical line is reached.
+
+ do k = 1, kmm1
+ do i = 1, npt
+ if (k .gt. kref (i) .and. prsi (ipt (i), k) .ge. rlolev) then
+ if (taud (i, k) .ne.0.) then
+ tem = delt * taud (i, k)
+ dtfac (i) = min (dtfac (i), abs (velco (i, k) / tem))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! if (lprnt .and. npr .gt. 0) then
+ ! print *, ' before a = ', a (npr, :)
+ ! print *, ' before b = ', b (npr, :)
+ ! endif
+
+ ! > - calculate outputs: a, b, dusfc, dvsfc (see parameter description) .
+ !! - below the dividing streamline height (k < idxzb), mountain
+ !! blocking (\f$d_{b}\f$) is applied.
+ !! - otherwise (k >= idxzb), orographic gwd (\f$\tau\f$) is applied.
+ do k = 1, km
+ do i = 1, npt
+ j = ipt (i)
+ taud (i, k) = taud (i, k) * dtfac (i)
+ dtaux = taud (i, k) * xn (i)
+ dtauy = taud (i, k) * yn (i)
+ eng0 = 0.5 * (u1 (j, k) ** 2 + v1 (j, k) ** 2)
+ ! --- lm mb (* j *) changes overwrite gwd
+ if (k .lt. idxzb (i) .and. idxzb (i) .ne. 0) then
+ dbim = db (i, k) / (1. + db (i, k) * delt)
+ if (present (vtgwd)) vtgwd (j, k) = - dbim * v1 (j, k)
+ if (present (utgwd)) utgwd (j, k) = - dbim * u1 (j, k)
+ if (present (dusfc)) dusfc (j) = dusfc (j) - dbim * u1 (j, k) * del (j, k)
+ if (present (dvsfc)) dvsfc (j) = dvsfc (j) - dbim * v1 (j, k) * del (j, k)
+ v1 (j, k) = v1 (j, k) - dbim * v1 (j, k) * delt
+ u1 (j, k) = u1 (j, k) - dbim * u1 (j, k) * delt
+ !eng1 = eng0 * (1.0 - dbim * delt) * (1.0 - dbim * delt)
+ eng1 = 0.5 * (u1 (j, k) ** 2 + v1 (j, k) ** 2)
+ else
+ if (present (vtgwd)) vtgwd (j, k) = dtauy
+ if (present (utgwd)) utgwd (j, k) = dtaux
+ if (present (dusfc)) dusfc (j) = dusfc (j) + dtaux * del (j, k)
+ if (present (dvsfc)) dvsfc (j) = dvsfc (j) + dtauy * del (j, k)
+ v1 (j, k) = v1 (j, k) + dtauy * delt
+ u1 (j, k) = u1 (j, k) + dtaux * delt
+ eng1 = 0.5 * (u1 (j, k) ** 2 + v1 (j, k) ** 2)
+ endif
+ if (present (ttgwd)) ttgwd (j, k) = (eng0 - eng1) / cp_air / delt
+ t1 (j, k) = t1 (j, k) + (eng0 - eng1) / cp_air
+ enddo
+ enddo
+ ! if (lprnt) then
+ ! print *, ' in gwdps_lm.f after a = ', a (ipr, :)
+ ! print *, ' in gwdps_lm.f after b = ', b (ipr, :)
+ ! print *, ' db = ', db (ipr, :)
+ ! endif
+ tem = - 1.0 / grav
+ do i = 1, npt
+ j = ipt (i)
+ ! tem = (- 1.e3 / grav)
+ if (present (dusfc)) dusfc (j) = tem * dusfc (j)
+ if (present (dvsfc)) dvsfc (j) = tem * dvsfc (j)
+ enddo
+
+ ! monitor for excessive gravity wave drag tendencies if ncnt > 0
+
+ ! if (ncnt.gt.0) then
+ ! if (lat.ge.38.and.lat.le.42) then
+ !cmic$ guard 37
+ ! do 92 i = 1, im
+ ! if (ikount.gt.ncnt) go to 92
+ ! if (i.lt.319.or.i.gt.320) go to 92
+ ! do 91 k = 1, km
+ ! if (abs (taud (i, k)) .gt. critac) then
+ ! if (i.le.im) then
+ ! ikount = ikount + 1
+ ! print 123, i, lat, kdt
+ ! print 124, taub (i), bnv (i), ulow (i),
+ ! 1 gf (i), fr (i), roll (i), hprime (i), xn (i), yn (i)
+ ! print 124, (taud (i, kk), kk = 1, km)
+ ! print 124, (taup (i, kk), kk = 1, km + 1)
+ ! print 124, (ri_n (i, kk), kk = 1, km)
+ ! do 93 kk = 1, kmm1
+ ! velko (kk) =
+ ! 1 0.5 * ((u1 (i, kk) + u1 (i, kk + 1)) * ubar (i) +
+ ! 2 (v1 (i, kk) + v1 (i, kk + 1)) * vbar (i)) * uloi (i)
+ !93 continue
+ ! print 124, (velko (kk), kk = 1, kmm1)
+ ! print 124, (a (i, kk), kk = 1, km)
+ ! print 124, (dtauy (i, kk), kk = 1, km)
+ ! print 124, (b (i, kk), kk = 1, km)
+ ! print 124, (dtaux (i, kk), kk = 1, km)
+ ! go to 92
+ ! endif
+ ! endif
+ !91 continue
+ !92 continue
+ !cmic$ end guard 37
+ !123 format (' *** migwd print *** i = ', i3, ' lat = ', i3, ' kdt = ', i3)
+ !124 format (2x, 10e13.6)
+ ! endif
+ ! endif
+
+ ! print *, ' in gwdps_lm.f 18 = ', a (ipt (1), idxzb (1)), &
+ ! b (ipt (1), idxzb (1)), me
+
+end subroutine sa_gwd_oro
+
+! =======================================================================
+! Stationary convection forced gravity wave drag based on chun and
+! baik (1998) \cite chun_and_baik_1998
+!
+! This subroutine is the parameterization of convective gravity wave
+! drag based on the theory given by Chun and Baik (1998)
+! \cite chun_and_baik_1998 modified for implementation into the
+! GFS / CFS by Ake Johansson (Aug 2005).
+!
+! Parameterizing subgrid-scale convection-induced gravity wave
+! momentum flux for use in large-scale models inherently requires
+! some information from subgrid-scale cumulus parameterization.
+! The methodology for parameterizing the zonal momentum flux induced
+! by thermal forcing can be summarized as follows. From the cloud-base
+! to cloud-top height, the effect of the momentum flux
+! induced by subgrid-scale diabatic forcing is not considered because
+! subgrid-scale cumulus convection in large-scale models is only
+! activated in a conditionally unstable atmosphere. Below the cloud
+! base, the momentum flux is also not considered because of the wave
+! momentum cancellation. At the cloud top, the momentum flux is
+! obtained by eq. (18) and (19) in Chun and Baik (1998)
+! \cite chun_and_baik_1998. Above the cloud top, there are two ways to
+! construct the momentum flux profile. One way is to specify a
+! vertical structure of the momentum flux normalized by the cloud-top
+! value, similar to what has been done for mountain drag
+! parameterization. The other way is to apply the wave saturation
+! hypothesis in order to find wave breaking levels in terms of the
+! richardon number criterion using the nonlinearity factor of
+! thermally induced waves.
+!
+!-----------------------------------------------------------------------
+! \param[in] IM horizontal number of used pts
+! \param[in] KM vertical layer dimension
+! \param[in] U1 u component of layer wind
+! \param[in] V1 v component of layer wind
+! \param[in] T1 layer mean temperature (k)
+! \param[in] Q1 layer mean tracer concentration
+! \param[in] PRSL mean layer pressure
+! \param[in] PRSI pressure at layer interfaces
+! \param[in] DEL mean layer delta p
+! \param[in] QMAX maximum convective heating rate (k / s) in a
+! horizontal grid point calculated
+! from cumulus parameterization
+! \param[in] KTOP vertical level index for cloud top
+! \param[in] KBOT vertical level index for cloud bottom
+! \param[in] KCNV (0, 1) dependent on whether convection occur or not
+! \param[in] CLDF deep convective cloud fraction at the cloud top
+! \param[in] DLENGTH grid spacing in the direction of basic wind at the cloud top
+! \param[out] UTGWC zonal wind tendency
+! \param[out] VTGWC meridional wind tendency
+! \param[out] TAUCTX wave stress at the cloud top projected in the east
+! \param[out] TAUCTY wave stress at the cloud top projected in the north
+!
+!-----------------------------------------------------------------------
+! Aug 2005 Ake Johansson - original code for parameterization of convectively forced
+! gravity wave drag from Yonsei university, Korea
+! based on the theory given by Chun and Baik (JAS, 1998)
+! modified for implementation into the GFS / CFSD by
+! 2013 S. Moorthi - updated and optimized code for T1534 GFS implementation
+! ??? ?? 2015 J. Alpert - reducing the magnitude of tauctmax to fix blow up in L64 GFS
+! S. Kar & M. Young
+! Aug 15 2016 - S. Moorthi - fix for exessive dissipation which led to blow up in
+! 128 level runs with NEMS / GSM
+!
+!-----------------------------------------------------------------------
+! ARGUMENTS
+!
+! input variables
+!
+! U : midpoint zonal wind
+! V : midpoint meridional wind
+! T : midpoint temperatures
+! PMID : midpoint pressures
+! PINT : interface pressures
+! DPMID : midpoint delta p (pi (k) - pi (k - 1))
+! QMAX : deep convective heating
+! KCLDTOP : vertical level index for cloud top (mid level)
+! KCLDBOT : vertical level index for cloud bottom (mid level)
+! KCNV : (0, 1) dependent on whether convection occur or not
+!
+! output variables
+!
+! UTGWC : zonal wind tendency
+! VTGWC : meridional wind tendency
+!
+!-----------------------------------------------------------------------
+! LOCAL WORKSPACE
+!
+! i, k : loop index
+! kk : loop index
+! cldf : deep convective cloud fraction at the cloud top.
+! ugwdc : zonal wind after gwdc paramterization
+! vgwdc : meridional wind after gwdc parameterization
+! plnmid : log (pmid) (mid level)
+! plnint : log (pint) (interface level)
+! dpint : delta pmid (interface level)
+! tauct : wave stress at the cloud top calculated using basic - wind
+! parallel to the wind vector at the cloud top (mid level)
+! tauctx : wave stress at the cloud top projected in the east
+! taucty : wave stress at the cloud top projected in the north
+! qmax : maximum deep convective heating rate (k s - 1) in a
+! horizontal grid point calculated from cumulus para -
+! meterization. (mid level)
+! wtgwc : wind tendency in direction to the wind vector at the cloud top level
+! due to convectively generated gravity waves (mid level)
+! utgwcl : zonal wind tendency due to convectively generated
+! gravity waves (mid level)
+! vtgwcl : meridional wind tendency due to convectively generated
+! gravity waves (mid level)
+! taugwci : profile of wave stress calculated using basic - wind
+! parallel to the wind vector at the cloud top
+! taugwcxi : profile of zonal component of gravity wave stress
+! taugwcyi : profile of meridional component of gravity wave stress
+!
+! taugwci, taugwcxi, and taugwcyi are defined at the interface level
+!
+! bruni : brunt - vaisala frequency (interface level)
+! brunm : brunt - vaisala frequency (mid level)
+! rhoi : air density (interface level)
+! rhom : air density (mid level)
+! ti : temperature (interface level)
+! basicum : basic - wind profile. basic - wind is parallel to the wind
+! vector at the cloud top level. (mid level)
+! basicui : basic - wind profile. basic - wind is parallel to the wind
+! vector at the cloud top level. (interface level)
+! riloc : local richardson number (interface level)
+! rimin : minimum richardson number including both the basic - state
+! and gravity wave effects (interface level)
+! gwdcloc : horizontal location where the gwdc scheme is activated.
+! break : horizontal location where wave breaking is occurred.
+! critic : horizontal location where critical level filtering is
+! occurred.
+! dogwdc : logical flag whether the gwdc parameterization is
+! calculated at a grid point or not.
+!
+! dogwdc is used in order to lessen cpu time for gwdc calculation.
+!
+!-----------------------------------------------------------------------
+! Local Variables
+!
+! ucltop : zonal wind at the cloud top (mid level)
+! vcltop : meridional wind at the cloud top (mid level)
+! windcltop : wind speed at the cloud top (mid level)
+! shear : vertical shear of basic wind
+! cosphi : cosine of angle of wind vector at the cloud top
+! sinphi : sine of angle of wind vector at the cloud top
+! c1 : tunable parameter
+! c2 : tunable parameter
+! dlength : grid spacing in the direction of basic wind at the cloud top
+! nonlinct : nonlinear parameter at the cloud top
+! nonlin : nonlinear parameter above the cloud top
+! nonlins : saturation nonlinear parameter
+! taus : saturation gravity wave drag == taugwci (i, k)
+! n2 : square of brunt - vaisala frequency
+! dtdp : dt / dp
+! xstress : vertically integrated zonal momentum change due to gwdc
+! ystress : vertically integrated meridional momentum change due to gwdc
+! crit1 : variable 1 for checking critical level
+! crit2 : variable 2 for checking critical level
+! =======================================================================
+
+subroutine sa_gwd_cnv (im, km, u1, v1, t1, q1, delt, gsize, qmax, &
+ prsl, prsi, del, ktop, kbot, kcnv, &
+ utgwc, vtgwc, ttgwc, tauctx, taucty)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km
+ integer, intent (in) :: ktop (im), kbot (im), kcnv (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: gsize (im), qmax (im)
+ real, intent (in) :: prsl (im, km), prsi (im, km + 1), del (im, km)
+
+ real, intent (inout) :: u1 (im, km), v1 (im, km), t1 (im, km), q1 (im, km)
+
+ real, intent (out), optional :: utgwc (im, km), vtgwc (im, km), ttgwc (im, km)
+
+ real, intent (out), optional :: tauctx (im), taucty (im)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ ! cumchr1 (im, km)
+
+ integer :: i, ii, k, k1, kk, kb, ilev, npt, kcb, kcldm
+ integer :: ipt (im)
+
+ real :: cldf (im), dlength (im)
+
+ real :: tem, tem1, tem2, qtem, wtgwc, tauct, &
+ windcltop, shear, nonlinct, nonlin, nonlins, &
+ n2, dtdp, crit1, crit2, p1, p2, &
+ ! n2, dtdp, crit1, crit2, p1, p2, &
+ gsqr, onebg, eng0, eng1
+ ! taus, n2, dtdp, crit1, crit2, p1, p2
+
+ integer, allocatable :: kcldtop (:), kcldbot (:)
+ logical, allocatable :: do_gwc (:)
+ real, allocatable :: tauctxl (:), tauctyl (:), &
+ gwdcloc (:), break (:), &
+ ! critic (:), &
+ ! critic (:), angle (:), &
+ cosphi (:), sinphi (:), &
+ xstress (:), ystress (:), &
+ ucltop (:), vcltop (:), &
+ wrk (:), dtfac (:), &
+ dlen (:), gqmcldlen (:)
+ ! real, allocatable :: plnint (:, :), dpint (:, :), &
+ ! taugwci (:, :), taugwcxi (:, :), &
+ ! taugwcyi (:, :), bruni (:, :), &
+ ! taugwcyi (:, :), bruni (:, :),
+ real, allocatable :: plnint (:, :), velco (:, :), &
+ taugwci (:, :), bruni (:, :), &
+ rhoi (:, :), basicui (:, :), &
+ ti (:, :), riloc (:, :), &
+ rimin (:, :), pint (:, :)
+ ! real, allocatable :: ugwdc (:, :), vgwdc (:, :),
+ real, allocatable :: &
+ ! plnmid (:, :), wtgwc (:, :), &
+ plnmid (:, :), taugw (:, :), &
+ utgwcl (:, :), vtgwcl (:, :), &
+ basicum (:, :), u (:, :), v (:, :), &
+ t (:, :), spfh (:, :), &
+ pmid (:, :), dpmid (:, :), &
+ ! pmid (:, :), cumchr (:, :), &
+ brunm (:, :), rhom (:, :)
+
+ ! copy from gsmphys/physcons.f90
+ integer, parameter :: max_lon = 5000, max_lat = 2000, min_lon = 192, min_lat = 94
+ real :: dxmax, dxmin, dxinv, work1 (im), work2 (im)
+
+ real, parameter :: &
+ c1 = 1.41, c2 = - 0.38, ricrit = 0.25, &
+ n2min = 1.e-32, zero = 0.0, one = 1.0, &
+ taumin = 1.0e-20, tauctmax = - 20., &
+ ! taumin = 1.0e-20, tauctmax = - 5., &
+ qmin = 1.0e-10, shmin = 1.0e-20, &
+ rimax = 1.0e+20, rimaxm = 0.99e+20, &
+ rimaxp = 1.01e+20, rilarge = 0.9e+20, &
+ riminx = - 1.0e+20, riminm = - 1.01e+20, &
+ riminp = - 0.99e+20, rismall = - 0.9e+20
+
+
+ npt = 0
+ do i = 1, im
+ ipt (i) = 0
+ if (kcnv (i) /= 0 .and. qmax (i) > zero) then
+ npt = npt + 1
+ ipt (npt) = i
+ endif
+ enddo
+ do k = 1, km
+ do i = 1, im
+ if (present (utgwc)) utgwc (i, k) = 0.0
+ if (present (vtgwc)) vtgwc (i, k) = 0.0
+ if (present (ttgwc)) ttgwc (i, k) = 0.0
+ ! brunm (i, k) = 0.0
+ ! rhom (i, k) = 0.0
+ enddo
+ enddo
+ do i = 1, im
+ if (present (tauctx)) tauctx (i) = 0.0
+ if (present (taucty)) taucty (i) = 0.0
+ enddo
+ if (npt == 0) return ! no gwdc calculation done
+
+ !-------------------------------------------------------------------
+ ! calculate deep convective cloud fraction at the cloud top.
+ tem = rerth * rerth * (pi + pi) * pi
+ dxmax = log (tem / (max_lon * max_lat))
+ dxmin = log (tem / (min_lon * min_lat))
+ dxinv = 1.0 / (dxmax - dxmin)
+ do i = 1, im
+ work1 (i) = (2.0 * log (gsize (i)) - dxmin) * dxinv
+ work1 (i) = max (0.0, min (1.0, work1 (i)))
+ work2 (i) = 1.0 - work1 (i)
+ cldf (i) = cgwf (1) * work1 (i) + cgwf (2) * work2 (i)
+ enddo
+ !-------------------------------------------------------------------
+ ! calculate grid spacing in the direction of basic wind at the cloud top
+ do i = 1, im
+ dlength(i) = sqrt (2. * gsize (i) * gsize (i))
+ enddo
+
+ ! ***********************************************************************
+
+ ! begin gwdc
+
+ ! ***********************************************************************
+
+ ! -----------------------------------------------------------------------
+ ! write out incoming variables
+ ! -----------------------------------------------------------------------
+
+ ! fhourpr = zero
+ ! if (lprnt) then
+ ! if (fhour >= fhourpr) then
+ ! print *, ' '
+ ! write (*, *) 'inside gwdc raw input start print at fhour = ', &
+ ! fhour
+ ! write (*, *) 'im km ', im, km
+ ! write (*, *) 'kbot ktop qmax dlength kcnv ',
+ ! + kbot (ipr), ktop (ipr), qmax (ipr), dlength (ipr), kcnv (ipr)
+ ! write (*, *) 'grav cp_air rdgas ', grav, cp_air, rdgas
+
+ ! -------- pressure levels ----------
+ ! write (*, 9100)
+ ! ilev = km + 1
+ ! write (*, 9110) ilev, (10. * prsi (ipr, ilev))
+ ! do ilev = km, 1, - 1
+ ! write (*, 9120) ilev, (10. * prsl (ipr, ilev)), &
+ ! (10. * del (ipr, ilev))
+ ! write (*, 9110) ilev, (10. * prsi (ipr, ilev))
+ ! enddo
+
+ ! -------- u1 v1 t1 ----------
+ ! write (*, 9130)
+ ! do ilev = km, 1, - 1
+ ! write (*, 9140) ilev, u1 (ipr, ilev), v1 (ipr, ilev), t1 (ipr, ilev)
+ ! enddo
+
+ ! print *, ' '
+ ! print *, ' inside gwdc raw input end print'
+ ! endif
+ ! endif
+
+ !9100 format (//, 14x, 'pressure levels', //,
+ ! + ' ilev', 6x, 'prsi', 7x, 'prsl', 6x, 'del', /)
+ !9110 format (i4, 2x, f10.3)
+ !9120 format (i4, 12x, 2 (2x, f10.3))
+ !9130 format (//, ' ilev', 7x, 'u1', 10x, 'v1', 10x, 't1', /)
+ !9140 format (i4, 3 (2x, f10.3))
+
+ ! allocate local arrays
+
+ allocate (kcldtop (npt), kcldbot (npt), do_gwc (npt))
+ allocate (tauctxl (npt), tauctyl (npt), dtfac (npt), &
+ gwdcloc (npt), break (npt), cosphi (npt), &
+ ! gwdcloc (npt), break (npt), critic (npt), cosphi (npt), &
+ sinphi (npt), xstress (npt), ystress (npt), wrk (npt), &
+ ucltop (npt), vcltop (npt), dlen (npt), gqmcldlen (npt))
+
+ ! allocate (plnint (npt, 2:km + 1), dpint (npt, km + 1), &
+ ! taugwci (npt, km + 1), taugwcxi (npt, km + 1), &
+ ! taugwcyi (npt, km + 1), bruni (npt, km + 1),
+ allocate (plnint (npt, 2:km + 1), &
+ taugwci (npt, km + 1), bruni (npt, km + 1), &
+ rhoi (npt, km + 1), basicui (npt, km + 1), &
+ ti (npt, km + 1), riloc (npt, km + 1), &
+ rimin (npt, km + 1), pint (npt, km + 1))
+
+ ! allocate (ugwdc (npt, km), vgwdc (npt, km),
+ allocate &
+ ! (plnmid (npt, km), wtgwc (npt, km), &
+ (plnmid (npt, km), velco (npt, km), &
+ utgwcl (npt, km), vtgwcl (npt, km), &
+ basicum (npt, km), u (npt, km), v (npt, km), &
+ t (npt, km), spfh (npt, km), pmid (npt, km), &
+ dpmid (npt, km), taugw (npt, km), &
+ ! dpmid (npt, km), cumchr (npt, km), &
+ brunm (npt, km), rhom (npt, km))
+
+ ! -----------------------------------------------------------------------
+ ! > - # create local arrays with reversed vertical indices
+ !! and initialize local variables
+ ! -----------------------------------------------------------------------
+ gsqr = grav * grav
+ onebg = one / grav
+
+ ! if (lprnt) then
+ ! npr = 1
+ ! do i = 1, npt
+ ! if (ipr == ipt (i)) then
+ ! npr = i
+ ! exit
+ ! endif
+ ! enddo
+ ! endif
+
+ do k = 1, km
+ k1 = km - k + 1
+ do i = 1, npt
+ ii = ipt (i)
+ u (i, k) = u1 (ii, k1)
+ v (i, k) = v1 (ii, k1)
+ t (i, k) = t1 (ii, k1)
+ spfh (i, k) = max (q1 (ii, k1), qmin)
+ pmid (i, k) = prsl (ii, k1)
+ dpmid (i, k) = del (ii, k1) * onebg
+ ! cumchr (i, k) = cumchr1 (ii, k1)
+
+ rhom (i, k) = pmid (i, k) / (rdgas * t (i, k) * (1.0 + zvir * spfh (i, k)))
+ plnmid (i, k) = log (pmid (i, k))
+ utgwcl (i, k) = zero
+ vtgwcl (i, k) = zero
+ ! ugwdc (i, k) = zero
+ ! vgwdc (i, k) = zero
+ brunm (i, k) = zero
+ basicum (i, k) = zero
+ enddo
+ enddo
+
+ do k = 1, km + 1
+ k1 = km - k + 2
+ do i = 1, npt
+ ii = ipt (i)
+ pint (i, k) = prsi (ii, k1)
+ taugwci (i, k) = zero
+ bruni (i, k) = zero
+ rhoi (i, k) = zero
+ ti (i, k) = zero
+ basicui (i, k) = zero
+ riloc (i, k) = zero
+ rimin (i, k) = zero
+ enddo
+ enddo
+ do k = 2, km + 1
+ do i = 1, npt
+ plnint (i, k) = log (pint (i, k))
+ enddo
+ enddo
+
+ do i = 1, npt
+ ii = ipt (i)
+ kcldtop (i) = km - ktop (ii) + 1
+ kcldbot (i) = km - kbot (ii) + 1
+ dlen (i) = dlength (ii)
+ ! (grav * qmax (ii) * cldf (ii) * dlength (ii))
+ gqmcldlen (i) = grav * qmax (ii) * cldf (ii) * dlen (i)
+ enddo
+ ! if (lprnt) write (7000, *) ' ktop = ', ktop (ipr), ' kbot = ', kbot (ipr), &
+ ! ' kcldtop = ', kcldtop (npr), ' kcldbot = ', kcldbot (npr), &
+ ! ' dlength = ', dlength (ipr), ' qmax = ', qmax (ipr), ' cldf = ', cldf (ipr)
+
+ ! if (lprnt) then
+ ! if (fhour.ge.fhourpr) then
+ ! write (*, 9200)
+ ! do i = 1, im
+ ! write (*, 9201) kcnv (i), kcldbot (i), kcldtop (i)
+ ! enddo
+ ! endif
+ ! endif
+
+ !9200 format (//, ' inside gwdc local variables start print', //,
+ ! + 2x, 'kcnv', 2x, 'kcldbot', 2x, 'kcldtop', //)
+ !9201 format (i4, 2x, i5, 4x, i5)
+
+ ! ***********************************************************************
+
+ ! -----------------------------------------------------------------------
+
+ ! pressure variables
+
+ ! interface 1 ======== pint (1) *********
+ ! mid - level 1 -------- pmid (1) dpmid (1)
+ ! 2 ======== pint (2) dpint (2)
+ ! 2 -------- pmid (2) dpmid (2)
+ ! 3 ======== pint (3) dpint (3)
+ ! 3 -------- pmid (3) dpmid (3)
+ ! 4 ======== pint (4) dpint (4)
+ ! 4 -------- pmid (4) dpmid (4)
+ ! ........
+ ! 17 ======== pint (17) dpint (17)
+ ! 17 -------- pmid (17) dpmid (17)
+ ! 18 ======== pint (18) dpint (18)
+ ! 18 -------- pmid (18) dpmid (18)
+ ! 19 ======== pint (19) *********
+
+ ! -----------------------------------------------------------------------
+
+ do i = 1, npt
+ tauctxl (i) = zero
+ tauctyl (i) = zero
+
+ ! -----------------------------------------------------------------------
+ ! thermal variables
+
+ ! interface 1 ======== ti (1) rhoi (1) bruni (1)
+ ! 1 -------- t (1) rhom (1) brunm (1)
+ ! 2 ======== ti (2) rhoi (2) bruni (2)
+ ! 2 -------- t (2) rhom (2) brunm (2)
+ ! 3 ======== ti (3) rhoi (3) bruni (3)
+ ! 3 -------- t (3) rhom (3) brunm (3)
+ ! 4 ======== ti (4) rhoi (4) bruni (4)
+ ! 4 -------- t (4) rhom (4) brunm (4)
+ ! ........
+ ! 17 ========
+ ! 17 -------- t (17) rhom (17) brunm (17)
+ ! 18 ======== ti (18) rhoi (18) bruni (18)
+ ! 18 -------- t (18) rhom (18) brunm (18)
+ ! 19 ======== ti (19) rhoi (19) bruni (19)
+
+
+
+ ! > - the top interface temperature, density, and brunt - vaisala
+ !! frequencies (\f$n\f$) are calculated assuming an isothermal
+ !! atmosphere above the top mid level.
+
+ ti (i, 1) = t (i, 1)
+ rhoi (i, 1) = pint (i, 1) / (rdgas * ti (i, 1))
+ bruni (i, 1) = sqrt (gsqr / (cp_air * ti (i, 1)))
+
+ ! > - the bottom interface temperature, density, and brunt - vaisala
+ !! frequencies (\f$n\f$) are calculated assuming an isothermal
+ !! atmosphere below the bottom mid level.
+
+ ti (i, km + 1) = t (i, km)
+ rhoi (i, km + 1) = pint (i, km + 1) / (rdgas * ti (i, km + 1) * (1.0 + zvir * spfh (i, km)))
+ bruni (i, km + 1) = sqrt (gsqr / (cp_air * ti (i, km + 1)))
+ enddo
+
+ ! -----------------------------------------------------------------------
+
+ ! > - the interface level temperature, density, and brunt - vaisala
+ !! frequencies (\f$n\f$) are calculated based on linear interpolation
+ !! of temperature in ln (p) .
+
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km
+ do i = 1, npt
+ tem1 = (plnmid (i, k) - plnint (i, k)) / (plnmid (i, k) - plnmid (i, k - 1))
+ tem2 = one - tem1
+ ti (i, k) = t (i, k - 1) * tem1 + t (i, k) * tem2
+ qtem = spfh (i, k - 1) * tem1 + spfh (i, k) * tem2
+ rhoi (i, k) = pint (i, k) / (rdgas * ti (i, k) * (1.0 + zvir * qtem))
+ dtdp = (t (i, k) - t (i, k - 1)) / (pmid (i, k) - pmid (i, k - 1))
+ n2 = gsqr / ti (i, k) * (1. / cp_air - rhoi (i, k) * dtdp)
+ bruni (i, k) = sqrt (max (n2min, n2))
+ enddo
+ enddo
+
+ deallocate (spfh)
+ ! -----------------------------------------------------------------------
+
+ ! > - the mid - level brunt - vaisala frequencies (\f$n\f$) are calculated
+ !! based on interpolated interface temperatures.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, npt
+ dtdp = (ti (i, k + 1) - ti (i, k)) / (pint (i, k + 1) - pint (i, k))
+ n2 = gsqr / t (i, k) * (1. / cp_air - rhom (i, k) * dtdp)
+ brunm (i, k) = sqrt (max (n2min, n2))
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! printout
+ ! -----------------------------------------------------------------------
+
+ ! if (lprnt) then
+ ! if (fhour.ge.fhourpr) then
+
+ ! -------- pressure levels ----------
+ ! write (*, 9101)
+ ! do ilev = 1, km
+ ! write (*, 9111) ilev, (0.01 * pint (ipr, ilev)), &
+ ! (0.01 * dpint (ipr, ilev)), plnint (ipr, ilev)
+ ! write (*, 9121) ilev, (0.01 * pmid (ipr, ilev)), &
+ ! (0.01 * dpmid (ipr, ilev)), plnmid (ipr, ilev)
+ ! enddo
+ ! ilev = km + 1
+ ! write (*, 9111) ilev, (0.01 * pint (ipr, ilev)), &
+ ! (0.01 * dpint (ipr, ilev)), plnint (ipr, ilev)
+
+ ! 2
+ ! -------- u v t n ----------
+ ! write (*, 9102)
+ ! do ilev = 1, km
+ ! write (*, 9112) ilev, ti (ipr, ilev), (100. * bruni (ipr, ilev))
+ ! write (*, 9122) ilev, u (ipr, ilev), v (ipr, ilev),
+ ! + t (ipr, ilev), (100. * brunm (ipr, ilev))
+ ! enddo
+ ! ilev = km + 1
+ ! write (*, 9112) ilev, ti (ipr, ilev), (100. * bruni (ipr, ilev))
+
+ ! endif
+ ! endif
+
+ !9101 format (//, 14x, 'pressure levels', //,
+ ! + ' ilev', 4x, 'pint', 4x, 'pmid', 4x, 'dpint', 3x, 'dpmid', 5x, 'lnp', /)
+ !9111 format (i4, 1x, f8.2, 9x, f8.2, 9x, f8.2)
+ !9121 format (i4, 9x, f8.2, 9x, f8.2, 1x, f8.2)
+ !9102 format (// ' ilev', 5x, 'u', 7x, 'v', 5x, 'ti', 7x, 't',
+ ! + 5x, 'bruni', 3x, 'brunm', //)
+ !9112 format (i4, 16x, f8.2, 8x, f8.3)
+ !9122 format (i4, 2f8.2, 8x, f8.2, 8x, f8.3)
+
+
+ ! ***********************************************************************
+
+ ! big loop over grid points only done if kcnv = 1
+
+ ! ***********************************************************************
+
+ kcldm = 1
+ do i = 1, npt
+ kk = kcldtop (i)
+ kb = kcldbot (i)
+ kcldm = max (kcldm, kk)
+
+ ! -----------------------------------------------------------------------
+
+ ! > - # calculate the cloud top wind components and speed.
+ !! here, ucltop, vcltop, and windcltop are wind components and
+ !! wind speed at mid - level cloud top index
+
+ ! -----------------------------------------------------------------------
+
+ ucltop (i) = u (i, kk)
+ vcltop (i) = v (i, kk)
+ ! windcltop = sqrt (ucltop (i) * ucltop (i) + vcltop (i) * vcltop (i))
+ windcltop = 1.0 / sqrt (ucltop (i) * ucltop (i) &
+ + vcltop (i) * vcltop (i))
+ cosphi (i) = ucltop (i) * windcltop
+ sinphi (i) = vcltop (i) * windcltop
+ ! angle (i) = acos (cosphi) * 180. / pi
+ enddo
+
+ ! -----------------------------------------------------------------------
+
+ ! > - # calculate the basic state wind projected in the direction of the
+ !! cloud top wind at mid level and interface level (u, ui), where:
+ !! \n u : basic - wind speed profile. basic - wind is parallel to the wind
+ !! vector at the cloud top level. (mid level)
+ !! \n ui: basic - wind speed profile. basic - wind is parallel to the wind
+ !! vector at the cloud top level. (interface level)
+ ! input u (i, k) and v (i, k) is defined at mid level
+
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, npt
+ basicum (i, k) = u (i, k) * cosphi (i) + v (i, k) * sinphi (i)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+
+ ! basic state wind at interface level is also calculated
+ ! based on linear interpolation in ln (pressure)
+
+ ! in the top and bottom boundaries, basic - state wind at interface level
+ ! is assumed to be vertically uniform.
+
+ ! -----------------------------------------------------------------------
+
+ do i = 1, npt
+ basicui (i, 1) = basicum (i, 1)
+ basicui (i, km + 1) = basicum (i, km)
+ enddo
+ do k = 2, km
+ do i = 1, npt
+ tem1 = (plnmid (i, k) - plnint (i, k)) / (plnmid (i, k) - plnmid (i, k - 1))
+ tem2 = one - tem1
+ basicui (i, k) = basicum (i, k) * tem2 + basicum (i, k - 1) * tem1
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+
+ ! > - # calculate the local richardson number
+ !! \f[
+ !! ri = n^2 / \eta^2
+ !! \f]
+ !! where \f$\eta\f$ is the vertical shear (\f$du / dz\f$) .
+
+ ! basicum : u at mid level
+ ! basicui : ui at interface level
+
+ ! interface 1 ======== ui (1) rhoi (1) bruni (1) riloc (1)
+ ! mid - level 1 -------- u (1)
+ ! 2 ======== ui (2) dpint (2) rhoi (2) bruni (2) riloc (2)
+ ! 2 -------- u (2)
+ ! 3 ======== ui (3) dpint (3) rhoi (3) bruni (3) riloc (3)
+ ! 3 -------- u (3)
+ ! 4 ======== ui (4) dpint (4) rhoi (4) bruni (4) riloc (4)
+ ! 4 -------- u (4)
+ ! ........
+ ! 17 ======== ui (17) dpint (17) rhoi (17) bruni (17) riloc (17)
+ ! 17 -------- u (17)
+ ! 18 ======== ui (18) dpint (18) rhoi (18) bruni (18) riloc (18)
+ ! 18 -------- u (18)
+ ! 19 ======== ui (19) rhoi (19) bruni (19) riloc (19)
+
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km
+ do i = 1, npt
+ shear = grav * rhoi (i, k) * (basicum (i, k) - basicum (i, k - 1)) &
+ / (pmid (i, k) - pmid (i, k - 1))
+ if (abs (shear) < shmin) then
+ riloc (i, k) = rimax
+ else
+ tem = bruni (i, k) / shear
+ riloc (i, k) = tem * tem
+ if (riloc (i, k) >= rimax) riloc (i, k) = rilarge
+ endif
+ enddo
+ enddo
+
+ do i = 1, npt
+ riloc (i, 1) = riloc (i, 2)
+ riloc (i, km + 1) = riloc (i, km)
+ enddo
+
+ ! if (lprnt.and. (i.eq.ipr)) then
+ ! if (fhour.ge.fhourpr) then
+ ! write (*, 9104) ucltop, vcltop, windcltop, angle, kk
+ ! do ilev = 1, km
+ ! write (*, 9114) ilev, basicui (ipr, ilev), dpint (ipr, ilev),
+ ! + rhoi (ipr, ilev), (100. * bruni (ipr, ilev)), riloc (ilev)
+ ! write (*, 9124) ilev, (basicum (ipr, ilev))
+ ! enddo
+ ! ilev = km + 1
+ ! write (*, 9114) ilev, basicui (ipr, ilev), dpint (ipr, ilev),
+ ! + rhoi (ipr, ilev), (100. * bruni (ipr, ilev)), riloc (ilev)
+ ! endif
+ ! endif
+
+ !9104 format (//, 'wind vector at cloudtop = (', f6.2, ', ', f6.2, ') = ',
+ ! + f6.2, ' in direction ', f6.2, 4x, 'kk = ', i2, //,
+ ! + ' ilev', 2x, 'basicum', 2x, 'basicui', 4x, 'dpint', 6x, 'rhoi', 5x,
+ ! + 'bruni', 6x, 'ri', /)
+ !9114 format (i4, 10x, f8.2, 4 (2x, f8.2))
+ !9124 format (i4, 1x, f8.2)
+
+ ! -----------------------------------------------------------------------
+
+ ! > - # calculate the gravity wave stress at the interface level cloud top.
+
+ ! kcldtopi : the interface level cloud top index
+ ! kcldtop : the midlevel cloud top index
+ ! kcldbot : the midlevel cloud bottom index
+
+ ! a : find deep convective heating rate maximum
+
+ ! if kcldtop (i) is less than kcldbot (i) in a horizontal grid point,
+ ! it can be thought that there is deep convective cloud. however,
+ ! deep convective heating between kcldbot and kcldtop is sometimes
+ ! zero in spite of kcldtop less than kcldbot. in this case,
+ ! maximum deep convective heating is assumed to be 1.e-30.
+
+ ! b : kk is the vertical index for interface level cloud top
+
+ ! c : total convective fractional cover (cldf) is used as the
+ ! convective cloud cover for gwdc calculation instead of
+ ! convective cloud cover in each layer (concld) .
+ ! a1 = cldf * dlength
+ ! you can see the difference between cldf (i) and concld (i)
+ ! in (4.a.2) in description of the ncar community climate
+ ! model (ccm3) .
+ ! in ncar ccm3, cloud fractional cover in each layer in a deep
+ ! cumulus convection is determined assuming total convective
+ ! cloud cover is randomly overlapped in each layer in the
+ ! cumulus convection.
+
+ ! d : wave stress at cloud top is calculated when the atmosphere
+ ! is dynamically stable at the cloud top
+
+ ! e : cloud top wave stress and nonlinear parameter are calculated
+ ! using density, temperature, and wind that are defined at mid
+ ! level just below the interface level in which cloud top wave
+ ! stress is defined.
+ ! nonlinct is defined at the interface level.
+
+ ! f : if the atmosphere is dynamically unstable at the cloud top,
+ ! gwdc calculation in current horizontal grid is skipped.
+
+ ! g : if mean wind at the cloud top is less than zero, gwdc
+
+ ! > - wave stress at cloud top is calculated when the atmosphere
+ !! is dynamically stable at the cloud top
+ !
+ ! > - the cloud top wave stress and nonlinear parameter are calculated
+ !! using density, temperature, and wind that are defined at mid
+ !! level just below the interface level in which cloud top wave
+ !! stress is defined.
+ !! the parameter \f$\mu\f$ is the nonlinearity factor of thermally
+ !! induced internal gravity waves defined by eq. (17) in chun and
+ !! baik, 1998 \cite chun_and_baik_1998
+ !! \f[
+ !! \mu = \frac{gq_{0}a_{1}}{c_{p}t_{0}nu^{2}}
+ !! \f]
+ !! where \f$q_{0}\f$ is the maximum deep convective heating rate in a
+ !! horizontal grid point calculated from cumulus parameterization.
+ !! \f$a_{1}\f$ is the half - width of
+ !! the forcing function.\f$g\f$ is gravity. \f$c_{p}\f$ is specific
+ !! heat at constant pressure. \f$t_{0}\f$ is the layer mean
+ !! temperature (t1) . as eqs. (18) and (19) \cite chun_and_baik_1998,
+ !! the zonal momentum flux is given by
+ !! \f[
+ !! \tau_{x} = - [\rho u^{3} / (n\triangle x) ]g (\mu)
+ !! \f]
+ !! where
+ !! \f[
+ !! g (\mu) = c_{1}c_2^2 \mu^{2}
+ !! \f]
+ !! wher \f$\rho\f$ is the local density.
+ !! the tunable parameter \f$c_1\f$ is related to the horizontal
+ !! structure of thermal forcing. the tunable parameter \f$c_2\f$ is
+ !! related to the basic - state wind and stability and the bottom and
+ !! top heights of thermal forcing. if the atmosphere is dynamically
+ !! unstable at the cloud top, the convective gwd calculation is
+ !! skipped at that grid point.
+ !
+ ! - if mean wind at the cloud top is less than zero, gwdc
+ ! calculation in current horizontal grid is skipped.
+
+
+ ! > - the stress is capped at tauctmax = - 5\f$n / m^2\f$
+ !! in order to prevent numerical instability.
+
+ ! -----------------------------------------------------------------------
+ !d
+ do i = 1, npt
+ kk = kcldtop (i)
+ if (abs (basicui (i, kk)) > zero .and. riloc (i, kk) > ricrit) then
+ !e
+ tem = basicum (i, kk)
+ tem1 = tem * tem
+ nonlinct = gqmcldlen (i) / (bruni (i, kk) * t (i, kk) * tem1) ! mu
+ tem2 = c2 * nonlinct
+ ! rhou^3c1 (c2mu) ^2 / ndx
+ tauct = - rhom (i, kk) * tem * tem1 * c1 * tem2 * tem2&
+ / (bruni (i, kk) * dlen (i))
+
+ tauct = max (tauctmax, tauct)
+ tauctxl (i) = tauct * cosphi (i) ! x stress at cloud top
+ tauctyl (i) = tauct * sinphi (i) ! y stress at cloud top
+ taugwci (i, kk) = tauct ! * 1
+ do_gwc (i) = .true.
+ else
+ !f
+ tauctxl (i) = zero
+ tauctyl (i) = zero
+ do_gwc (i) = .false.
+ endif
+ !h
+ enddo
+
+ ! if (lprnt.and. (i.eq.ipr)) then
+ ! if (fhour.ge.fhourpr) then
+ ! write (*, 9210) tauctx (ipr), taucty (ipr), tauct (ipr), angle, kk
+ ! endif
+ ! endif
+
+ !9210 format (/, 5x, 'stress vector = (', f8.3, ', ', f8.3, ') = ', f8.3,
+ ! + ' in direction ', f6.2, 4x, 'kk = ', i2, /)
+
+ ! -----------------------------------------------------------------------
+
+ ! at this point, mean wind at the cloud top is larger than zero and
+ ! local ri at the cloud top is larger than ricrit (= 0.25)
+
+ ! calculate minimum of richardson number including both basic - state
+ ! condition and wave effects.
+
+ ! g * q_0 * alpha * dx ri_loc * (1 - mu * |c2|)
+ ! mu = ---------------- ri_min = -----------------------------
+ ! c_p * n * t * u^2 (1 + mu * ri_loc^ (0.5) * |c2|) ^2
+
+ ! minimum ri is calculated for the following two cases
+
+ ! (1) riloc < 1.e+20
+ ! (2) riloc = 1.e+20 ---- > vertically uniform basic - state wind
+
+ ! riloc cannot be smaller than zero because n^2 becomes 1.e-32 in the
+ ! case of n^2 < 0.. thus the sign of rinum is determined by
+ ! 1 - nonlin * |c2|.
+
+ ! -----------------------------------------------------------------------
+ ! > - # calculate the minimum richardson number including both the
+ !! basic - state condition and wave effects.
+ !!\f[
+ !! ri_{min}\approx\frac{ri (1 - \mu|c_{2}|) }{ (1 + \mu ri^{1 / 2}|c_{2}|) ^{2}}
+ !!\f]
+
+ do k = kcldm, 1, - 1
+
+ do i = 1, npt
+ if (do_gwc (i)) then
+ kk = kcldtop (i)
+ if (k > kk) cycle
+ if (k /= 1) then
+ tem1 = (u (i, k) + u (i, k - 1)) * 0.5
+ tem2 = (v (i, k) + v (i, k - 1)) * 0.5
+ crit1 = ucltop (i) * tem1
+ crit2 = vcltop (i) * tem2
+ velco (i, k) = tem1 * cosphi (i) + tem2 * sinphi (i)
+ else
+ crit1 = ucltop (i) * u (i, 1)
+ crit2 = vcltop (i) * v (i, 1)
+ velco (i, 1) = u (i, 1) * cosphi (i) + v (i, 1) * sinphi (i)
+ endif
+ ! if (lprnt .and. i == npr) write (7000, *) ' k = ', k, ' crit1 = ', &
+ ! crit1, ' crit2 = ', crit2, ' basicui = ', basicui (i, k)
+
+ if (abs (basicui (i, k)) > zero .and. crit1 > zero .and. crit2 > zero) then
+ tem = basicui (i, k) * basicui (i, k)
+ nonlin = gqmcldlen (i) / (bruni (i, k) * ti (i, k) * tem)
+ tem = nonlin * abs (c2)
+ if (riloc (i, k) < rimaxm) then
+ tem1 = 1 + tem * sqrt (riloc (i, k))
+ rimin (i, k) = riloc (i, k) * (1 - tem) / (tem1 * tem1)
+ else if ((riloc (i, k) > rimaxm) .and. (riloc (i, k) < rimaxp)) then
+ rimin (i, k) = (1 - tem) / (tem * tem)
+ endif
+ if (rimin (i, k) <= riminx) then
+ rimin (i, k) = rismall
+ endif
+ else
+ rimin (i, k) = riminx
+ endif
+ ! if (lprnt .and. i == npr) write (7000, *) ' rimin = ', rimin (i, k)
+
+ ! -----------------------------------------------------------------------
+
+ ! if the minimum \f$r_{i}\f$ at interface cloud top is less than or equal to 1 / 4,
+ ! the convective gwd calculation is skipped at that grid point.
+
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+
+ ! > - # calculate the gravity wave stress profile using the wave
+ !! saturation hypothesis of lindzen (1981) \cite lindzen_1981.
+
+ ! assuming kcldtop (i) = 10 and kcldbot = 16,
+
+ ! taugwci riloc rimin utgwc
+
+ ! interface 1 ======== - 0.001 - 1.e20
+ ! 1 -------- 0.000
+ ! 2 ======== - 0.001 - 1.e20
+ ! 2 -------- 0.000
+ ! 3 ======== - 0.001 - 1.e20
+ ! 3 --------- .xxx
+ ! 4 ======== - 0.001 2.600 2.000
+ ! 4 -------- 0.000
+ ! 5 ======== - 0.001 2.500 2.000
+ ! 5 -------- 0.000
+ ! 6 ======== - 0.001 1.500 0.110
+ ! 6 -------- + .xxx
+ ! 7 ======== - 0.005 2.000 3.000
+ ! 7 -------- 0.000
+ ! 8 ======== - 0.005 1.000 0.222
+ ! 8 -------- + .xxx
+ ! 9 ======== - 0.010 1.000 2.000
+ ! 9 -------- 0.000
+ ! kcldtopi 10 ======== $$$ - 0.010
+ ! kcldtop 10 -------- $$$ yyyyy
+ ! 11 ======== $$$ 0
+ ! 11 -------- $$$
+ ! 12 ======== $$$ 0
+ ! 12 -------- $$$
+ ! 13 ======== $$$ 0
+ ! 13 -------- $$$
+ ! 14 ======== $$$ 0
+ ! 14 -------- $$$
+ ! 15 ======== $$$ 0
+ ! 15 -------- $$$
+ ! 16 ======== $$$ 0
+ ! kcldbot 16 -------- $$$
+ ! 17 ======== 0
+ ! 17 --------
+ ! 18 ======== 0
+ ! 18 --------
+ ! 19 ======== 0
+
+ ! -----------------------------------------------------------------------
+
+ ! even though the cloud top level obtained in deep convective para -
+ ! meterization is defined in mid - level, the cloud top level for
+ ! the gwdc calculation is assumed to be the interface level just
+ ! above the mid - level cloud top vertical level index.
+
+ ! -----------------------------------------------------------------------
+
+ ! > - when \f$ri_{min}\f$ is set to 1 / 4 based on lindzen's (1981)
+ !! \cite lindzen_1981 saturation hypothesis, the nonlinearity factor
+ !! for wave saturation can be derived by
+ !! \f[
+ !! \mu_{s} = \frac{1}{|c_{2}|}[2\sqrt{2 + \frac{1}{\sqrt{ri}}} - (2 + \frac{1}{\sqrt{ri}}) ]
+ !! \f]
+ !! then the saturation zonal momentum flux is given by
+ !! \f[
+ !! \tau_{s} = - [\rho u^{3} / (n\triangle x) ]c_{1}c_2^2\mu_s^2
+ !! \f]
+
+ if (k < kk .and. k > 1) then
+ if (abs (taugwci (i, k + 1)) > taumin) then ! taugwci
+ if (riloc (i, k) > ricrit) then ! riloc
+ if (rimin (i, k) > ricrit) then ! rimin
+ taugwci (i, k) = taugwci (i, k + 1)
+ elseif (rimin (i, k) > riminp) then
+ tem = 2.0 + 1.0 / sqrt (riloc (i, k))
+ nonlins = (1.0 / abs (c2)) * (2. * sqrt (tem) - tem)
+ tem1 = basicui (i, k)
+ tem2 = c2 * nonlins * tem1
+ taugwci (i, k) = - rhoi (i, k) * c1 * tem1 * tem2 * tem2&
+ / (bruni (i, k) * dlen (i))
+ elseif (rimin (i, k) > riminm) then
+ taugwci (i, k) = zero
+ ! taugwci (i, k) = taugwci (i, k + 1)
+ endif ! rimin
+ else
+
+ ! > - if the minimum \f$r_{i}\f$ at interface cloud top is less than
+ !! or equal to 1 / 4, the convective gwd calculation is skipped at that
+ !! grid point.
+
+ taugwci (i, k) = zero
+ endif ! riloc
+ else
+ taugwci (i, k) = zero
+ endif ! taugwci
+
+ if ((basicum (i, k + 1) * basicum (i, k)) < 0.) then
+ taugwci (i, k + 1) = zero
+ taugwci (i, k) = zero
+ endif
+
+ if (abs (taugwci (i, k)) > abs (taugwci (i, k + 1))) then
+ taugwci (i, k) = taugwci (i, k + 1)
+ endif
+
+ elseif (k == 1) then
+
+ ! > - as an upper boundary condition, upward propagation of gravity
+ !! wave energy is permitted.
+
+ taugwci (i, 1) = taugwci (i, 2)
+ endif
+
+ ! if (lprnt .and. i == npr) then
+ ! write (7000, *) 'k = ', k, ' taugwci = ', taugwci (i, k), &
+ ! 'riloc', riloc (i, k), 'riminp = ', riminp, ' ricrit = ', ricrit, &
+ ! 'bruni (i, k) = ', bruni (i, k), ' deln = ', bruni (i, k), &
+ ! 'basicui (i, k) = ', basicui (i, k), ' rimin = ', rimin (i, k), &
+ ! ' dlen = ', dlen (i), ' rhoi = ', rhoi (i, k)
+ ! endif
+
+ endif
+ enddo ! end of i = 1, npt loop
+ enddo ! end of k = kcldm, 1, - 1 loop
+
+ do i = 1, npt
+ dtfac (i) = 1.0
+ enddo
+ do k = 1, km
+ do i = 1, npt
+ if (do_gwc (i)) then
+ kk = kcldtop (i)
+ if (k < kk) then
+ taugw (i, k) = (taugwci (i, k + 1) - taugwci (i, k)) / dpmid (i, k)
+ if (taugw (i, k) /= 0.0) then
+ tem = delt * taugw (i, k)
+ dtfac (i) = min (dtfac (i), abs (velco (i, k) / tem))
+ endif
+ else
+ taugw (i, k) = 0.0
+ endif
+ else
+ taugw (i, k) = 0.0
+ endif
+ enddo
+ enddo
+
+ !!!!!! vertical differentiation
+ !!!!!
+ ! > - # calculate wind tendency in direction to the wind vector, zonal
+ !! wind tendency and meridional wind tendency above the cloud top
+ !! level due to convectively generated gravity waves.
+
+ do k = 1, km
+ do i = 1, npt
+ if (do_gwc (i)) then
+ kk = kcldtop (i)
+ if (k < kk) then
+ ! wtgwc = (taugwci (i, k + 1) - taugwci (i, k)) / dpmid (i, k)
+ wtgwc = taugw (i, k) * dtfac (i)
+ utgwcl (i, k) = wtgwc * cosphi (i)
+ vtgwcl (i, k) = wtgwc * sinphi (i)
+ else
+ utgwcl (i, k) = zero
+ vtgwcl (i, k) = zero
+ endif
+ ! if (lprnt .and. i == npr) then
+ ! write (7000, *) 'k = ', k, ' wtgwc = ', wtgwc, ' taugwci = ', taugwci (i, k), &
+ ! taugwci (i, k + 1), ' dpmid = ', dpmid (i, k), ' cosphi = ', cosphi (i), &
+ ! ' sinphi = ', sinphi (i), ' utgwcl = ', utgwcl (i, k), &
+ ! 'vtgwcl = ', vtgwcl (i, k), ' dtfac = ', dtfac (i)
+ ! endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+
+ ! calculate momentum flux = stress deposited above cloup top
+ ! apply equal amount with opposite sign within cloud
+
+ ! -----------------------------------------------------------------------
+
+ do i = 1, npt
+ xstress (i) = zero
+ ystress (i) = zero
+ enddo
+ do k = 1, kcldm
+ do i = 1, npt
+ if (do_gwc (i)) then
+ xstress (i) = xstress (i) + utgwcl (i, k) * dpmid (i, k)
+ ystress (i) = ystress (i) + vtgwcl (i, k) * dpmid (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! alt 1 only uppermost layer
+ ! -----------------------------------------------------------------------
+
+ ! kk = kcldtop (i)
+ ! tem1 = grav / dpmid (i, kk)
+ ! utgwc (i, kk) = - tem1 * xstress
+ ! vtgwc (i, kk) = - tem1 * ystress
+
+ ! -----------------------------------------------------------------------
+ ! alt 2 sin (kt - kb)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, npt
+ if (do_gwc (i)) then
+ wrk (i) = 0.5 * pi / (pint (i, kcldbot (i) + 1) - pint (i, kcldtop (i)))
+ endif
+ enddo
+ do k = 1, km
+ do i = 1, npt
+ if (do_gwc (i)) then
+ kk = kcldtop (i)
+ if (k >= kk .and. k <= kcldbot (i)) then
+ p1 = sin (wrk (i) * (pint (i, k) - pint (i, kk)))
+ p2 = sin (wrk (i) * (pint (i, k + 1) - pint (i, kk)))
+ tem = - (p2 - p1) / dpmid (i, k)
+ utgwcl (i, k) = tem * xstress (i)
+ vtgwcl (i, k) = tem * ystress (i)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! alt 3 from kt to kb proportional to conv heating
+ ! -----------------------------------------------------------------------
+
+ ! do k = kcldtop (i), kcldbot (i)
+ ! p1 = cumchr (i, k)
+ ! p2 = cumchr (i, k + 1)
+ ! utgwcl (i, k) = - grav * xstress * (p1 - p2) / dpmid (i, k)
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+
+ ! the gwdc should accelerate the zonal and meridional wind in the
+ ! opposite direction of the previous zonal and meridional wind,
+ ! respectively
+
+ ! -----------------------------------------------------------------------
+
+ ! do k = 1, kcldtop (i) - 1
+
+ ! if (utgwcl (i, k) * u (i, k) .gt. 0.0) then
+
+ ! -------------------- x - component -------------------
+
+ ! write (6, ' (a) ')
+ ! + ' (gwdc) warning: the gwdc should accelerate the zonal wind '
+ ! write (6, ' (a, a, i3, a, i3) ')
+ ! + 'in the opposite direction of the previous zonal wind',
+ ! + ' at i = ', i, ' and j = ', lat
+ ! write (6, ' (4 (1x, e17.10)) ') u (i, kk), v (i, kk), u (i, k), v (i, k)
+ ! write (6, ' (a, 1x, e17.10)) ') 'vcld . v = ',
+ ! + u (i, kk) * u (i, k) + v (i, kk) * v (i, k)
+
+ ! if (u (i, kcldtop (i)) * u (i, k) + v (i, kcldtop (i)) * v (i, k) .gt.0.0) then
+ ! do k1 = 1, km
+ ! write (6, ' (i2, 36x, 2 (1x, e17.10)) ')
+ ! + k1, taugwcxi (i, k1), taugwci (i, k1)
+ ! write (6, ' (i2, 2 (1x, e17.10)) ') k1, utgwcl (i, k1), u (i, k1)
+ ! enddo
+ ! write (6, ' (i2, 36x, 1x, e17.10) ') (km + 1), taugwcxi (i, km + 1)
+ ! endif
+
+ ! -------------------- along wind at cloud top -----
+
+ ! do k1 = 1, km
+ ! write (6, ' (i2, 36x, 2 (1x, e17.10)) ')
+ ! + k1, taugwci (i, k1)
+ ! write (6, ' (i2, 2 (1x, e17.10)) ') k1, wtgwc (i, k1), basicum (i, k1)
+ ! enddo
+ ! write (6, ' (i2, 36x, 1x, e17.10) ') (km + 1), taugwci (i, km + 1)
+
+ ! endif
+
+ ! if (vtgwc (i, k) * v (i, k) .gt. 0.0) then
+ ! write (6, ' (a) ')
+ ! + ' (gwdc) warning: the gwdc should accelerate the meridional wind'
+ ! write (6, ' (a, a, i3, a, i3) ')
+ ! + 'in the opposite direction of the previous meridional wind',
+ ! + ' at i = ', i, ' and j = ', lat
+ ! write (6, ' (4 (1x, e17.10)) ') u (i, kcldtop (i)), v (i, kcldtop (i)),
+ ! + u (i, k), v (i, k)
+ ! write (6, ' (a, 1x, e17.10)) ') 'vcld . v = ',
+ ! + u (i, kcldtop (i)) * u (i, k) + v (i, kcldtop (i)) * v (i, k)
+ ! if (u (i, kcldtop (i)) * u (i, k) + v (i, kcldtop (i)) * v (i, k) .gt.0.0) then
+ ! do k1 = 1, km
+ ! write (6, ' (i2, 36x, 2 (1x, e17.10)) ')
+ ! + k1, taugwcyi (i, k1), taugwci (i, k1)
+ ! write (6, ' (i2, 2 (1x, e17.10)) ') k1, vtgwc (i, k1), v (i, k1)
+ ! enddo
+ ! write (6, ' (i2, 36x, 1x, e17.10) ') (km + 1), taugwcyi (i, km + 1)
+ ! endif
+ ! endif
+
+ ! enddo
+
+ !1000 continue
+
+
+ ! ***********************************************************************
+
+ ! if (lprnt) then
+ ! if (fhour.ge.fhourpr) then
+ ! -------- utgwc vtgwc ----------
+ ! write (*, 9220)
+ ! do ilev = 1, km
+ ! write (*, 9221) ilev, (86400. * utgwcl (ipr, ilev)),
+ ! + (86400. * vtgwcl (ipr, ilev))
+ ! enddo
+ ! endif
+ ! endif
+
+ !9220 format (//, 14x, 'tendency due to gwdc', //,
+ ! + ' ilev', 6x, 'utgwc', 7x, 'vtgwc', /)
+ !9221 format (i4, 2 (2x, f10.3))
+
+ ! -----------------------------------------------------------------------
+
+ ! for gwdc performance analysis
+
+ ! -----------------------------------------------------------------------
+
+ ! do k = 1, kk - 1
+ ! do i = 1, nct
+
+ ! kk = kcldtop (i)
+
+ ! if ((abs (taugwci (i, kk)) > taumin)) then
+
+ ! gwdcloc (i) = one
+
+ ! if (abs (taugwci (i, k) - taugwci (i, kk)) > taumin) then
+ ! break (i) = 1.0
+ ! go to 2000
+ ! endif
+ ! enddo
+ !2000 continue
+
+ ! do k = 1, kk - 1
+
+ ! if ((abs (taugwci (i, k)) .lt.taumin) .and. (abs (taugwci (i, k + 1)) .gt.taumin) .and. (basicum (i, k + 1) * basicum (i, k) .lt. 0.)) then
+ ! critic (i) = 1.0
+ ! print *, i, k, ' inside gwdc taugwci (k) = ', taugwci (i, k)
+ ! print *, i, k + 1, ' inside gwdc taugwci (k + 1) = ', taugwci (i, k + 1)
+ ! print *, i, k, ' inside gwdc basicum (k) = ', basicum (i, k)
+ ! print *, i, k + 1, ' inside gwdc basicum (k + 1) = ', basicum (i, k + 1)
+ ! print *, i, ' inside gwdc critic = ', critic (i)
+ ! goto 2010
+ ! endif
+ ! enddo
+ !2010 continue
+
+ ! endif
+
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! > - # convert back local convective gwd tendency arrays to gfs model
+ !! vertical indices.
+ ! outgoing (fu1, fv1) = (utgwc, vtgwc)
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ k1 = km - k + 1
+ do i = 1, npt
+ ii = ipt (i)
+ eng0 = 0.5 * (u1 (ii, k1) ** 2 + v1 (ii, k1) ** 2)
+ if (present (utgwc)) utgwc (ii, k1) = utgwcl (i, k)
+ if (present (vtgwc)) vtgwc (ii, k1) = vtgwcl (i, k)
+
+ ! brunm (ii, kk) = brunm (i, k)
+ ! brunm (i, k) = tem
+
+ ! rhom (ii, kk) = rhom (i, k)
+ u1 (ii, k1) = u1 (ii, k1) + utgwcl (i, k) * delt
+ v1 (ii, k1) = v1 (ii, k1) + vtgwcl (i, k) * delt
+ eng1 = 0.5 * (u1 (ii, k1) ** 2 + v1 (ii, k1) ** 2)
+ if (present (ttgwc)) ttgwc (ii, k1) = (eng0 - eng1) / cp_air / delt
+ t1 (ii, k1) = t1 (ii, k1) + (eng0 - eng1) / cp_air
+ enddo
+ ! if (lprnt) write (7000, *) ' k = ', k, ' k1 = ', k1, ' utgwc = ', &
+ ! utgwc (ipr, k1), ' vtgwc = ', vtgwc (ipr, k1)
+ enddo
+ do i = 1, npt
+ ii = ipt (i)
+ if (present (tauctx)) tauctx (ii) = tauctxl (i)
+ if (present (taucty)) taucty (ii) = tauctyl (i)
+ enddo
+
+ ! if (lprnt) then
+ ! if (fhour.ge.fhourpr) then
+ ! -------- utgwc vtgwc ----------
+ ! write (*, 9225)
+ ! do ilev = km, 1, - 1
+ ! write (*, 9226) ilev, (86400. * fu1 (ipr, ilev)),
+ ! + (86400. * fv1 (ipr, ilev))
+ ! enddo
+ ! endif
+ ! endif
+
+ !9225 format (//, 14x, 'tendency due to gwdc - to gbphys', //,
+ ! + ' ilev', 6x, 'utgwc', 7x, 'vtgwc', /)
+ !9226 format (i4, 2 (2x, f10.3))
+
+ deallocate (kcldtop, kcldbot, do_gwc)
+ deallocate (tauctxl, tauctyl, dtfac, &
+ ! gwdcloc, break, critic, cosphi, &
+ gwdcloc, break, cosphi, &
+ sinphi, xstress, ystress, &
+ dlen, ucltop, vcltop, gqmcldlen, wrk)
+
+ deallocate (plnint, taugwci, velco, &
+ bruni, rhoi, basicui, &
+ ti, riloc, rimin, pint)
+
+ deallocate (plnmid, utgwcl, vtgwcl, basicum, u, v, t, &
+ pmid, dpmid, brunm, rhom, taugw)
+
+end subroutine sa_gwd_cnv
+
+end module sa_gwd_mod
diff --git a/model/sa_sas.F90 b/model/sa_sas.F90
new file mode 100644
index 000000000..609df22de
--- /dev/null
+++ b/model/sa_sas.F90
@@ -0,0 +1,4473 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! Scale-Aware Simplified-Arakawa-Schubert (SA-SAS) Convection Scheme
+! This code was originally from GFS. It was later rewritten as an inline scheme.
+! Developers: Jongil Han, Linjiong Zhou, and the GFDL FV3 Team
+! References: Han and Pan (2011), Han et al. (2017), Han and Bretherton (2019)
+! =======================================================================
+
+module sa_sas_mod
+
+ use fms_mod, only: check_nml_error
+ use gfdl_mp_mod, only: mqs
+
+ implicit none
+
+ private
+
+ ! -----------------------------------------------------------------------
+ ! public subroutines, functions, and variables
+ ! -----------------------------------------------------------------------
+
+ public :: sa_sas_init
+ public :: sa_sas_deep
+ public :: sa_sas_shal
+
+ ! -----------------------------------------------------------------------
+ ! physics constants
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), 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 :: 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 :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS
+ real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K)
+
+ real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS
+
+ real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS
+
+ ! -----------------------------------------------------------------------
+ ! namelist parameters
+ ! -----------------------------------------------------------------------
+
+ ! mass flux deep convection
+
+ real :: clam_deep = 0.1 ! c_e for deep convection (Han and Pan, 2011, eq(6))
+ real :: c0s_deep = 0.002 ! conversion parameter of detrainment from liquid water into convetive precipitaiton
+ real :: c1_deep = 0.002 ! conversion parameter of detrainment from liquid water into grid-scale cloud water
+ real :: pgcon_deep = 0.55 ! control the reduction in momentum transport
+ ! 0.7 : Gregory et al. (1997, QJRMS)
+ ! 0.55: Zhang & Wu (2003, JAS)
+ real :: asolfac_deep = 0.89 ! aerosol-aware parameter based on Lim & Hong (2012)
+ ! asolfac_deep= cx / c0s_deep(=.002)
+ ! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s_deep)
+ ! Nccn: CCN number concentration in cm^(-3)
+ ! Until a realistic Nccn is provided, typical Nccns are assumed
+ ! as Nccn=100 for sea and Nccn=7000 for land
+ real :: evfact_deep = 0.3 ! evaporation factor
+ real :: evfactl_deep = 0.3 ! evaporation factor over land
+ real :: betal_deep = 0.05 ! downdraft heat flux contribution over land
+ real :: betas_deep = 0.05 ! downdraft heat flux contribution over ocean
+ real :: dxcrtas_deep = 8.e3 ! the threshold value (unit: m) for the quasi-equilibrium assumption of Arakawa-Schubert
+
+ ! mass flux shallow convectio
+
+ real :: clam_shal = 0.3 ! c_e for shallow convection (Han and Pan, 2011, eq(6))
+ real :: c0s_shal = 0.002 ! conversion parameter of detrainment from liquid water into convetive precipitaiton
+ real :: c1_shal = 5.e-4 ! conversion parameter of detrainment from liquid water into grid-scale cloud water
+ real :: pgcon_shal = 0.55 ! control the reduction in momentum transport
+ ! 0.7 : Gregory et al. (1997, QJRMS)
+ ! 0.55: Zhang & Wu (2003, JAS)
+ real :: asolfac_shal = 0.89 ! aerosol-aware parameter based on Lim & Hong (2012)
+ ! asolfac_shal= cx / c0s_shal(=.002)
+ ! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s_shal)
+ ! Nccn: CCN number concentration in cm^(-3)
+ ! Until a realistic Nccn is provided, typical Nccns are assumed
+ ! as Nccn=100 for sea and Nccn=7000 for land
+ real :: evfact_shal = 0.3 ! rain evaporation efficiency over the ocean
+ real :: evfactl_shal = 0.3 ! rain evaporation efficiency over the land
+
+ ! -----------------------------------------------------------------------
+ ! namelist
+ ! -----------------------------------------------------------------------
+
+ namelist / sa_sas_nml / &
+ clam_deep, c0s_deep, c1_deep, pgcon_deep, asolfac_deep, evfact_deep, evfactl_deep, &
+ clam_shal, c0s_shal, c1_shal, pgcon_shal, asolfac_shal, evfact_shal, evfactl_shal, &
+ betal_deep, betas_deep, dxcrtas_deep
+
+contains
+
+! =======================================================================
+! SA-SAS initialization
+! =======================================================================
+
+subroutine sa_sas_init (input_nml_file, logunit)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: logunit
+
+ character (len = *), intent (in) :: input_nml_file (:)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: ios, ierr
+
+ ! -----------------------------------------------------------------------
+ ! read namelist
+ ! -----------------------------------------------------------------------
+
+ read (input_nml_file, nml = sa_sas_nml, iostat = ios)
+ ierr = check_nml_error (ios, 'sa_sas_nml')
+
+ ! -----------------------------------------------------------------------
+ ! write namelist to log file
+ ! -----------------------------------------------------------------------
+
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "sa_sas_mod"
+ write (logunit, nml = sa_sas_nml)
+
+end subroutine sa_sas_init
+
+! =======================================================================
+! deep convection part
+! =======================================================================
+
+subroutine sa_sas_deep (im, km, delt, delp, prslp, psp, phil, ql, &
+ q1, t1, u1, v1, qr, rn, kbot, ktop, kcnv, islimsk, gsize, &
+ dot, ncloud, ud_mf, dd_mf, dt_mf, cnvw, cnvc)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, ncloud, islimsk (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: psp (im), delp (im, km), &
+ prslp (im, km), gsize (im), dot (im, km), phil (im, km)
+
+ integer, intent (inout) :: kcnv (im)
+
+ real, intent (inout) :: ql (im, km), &
+ q1 (im, km), t1 (im, km), u1 (im, km), v1 (im, km)
+
+ integer, intent (out) :: kbot (im), ktop (im)
+
+ real, intent (out) :: rn (im), qr (im, km)
+ real, intent (out), optional :: cnvw (im, km), cnvc (im, km), &
+ ud_mf (im, km), dd_mf (im, km), dt_mf (im, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, indx, jmn, k, kk, km1, n
+
+ real :: cxlamu, cxlamd, xlamde, xlamdd, crtlamu, crtlamd
+
+ ! real :: detad
+
+ real :: adw, aup, aafac, beta, d0, &
+ dellat, delta, desdt, dg, &
+ dh, dhh, dp, &
+ dq, dqsdp, dqsdt, dt, &
+ dt2, dtmax, dtmin, &
+ dxcrtuf, &
+ dv1h, dv2h, dv3h, &
+ dv1q, dv2q, dv3q, &
+ dz, dz1, e1, edtmax, &
+ edtmaxl, edtmaxs, el2orc, elocp, &
+ es, etah, &
+ cthk, dthk, &
+ evef, fact1, &
+ fact2, factor, &
+ g, gamma, pprime, cm, &
+ qlk, qrch, qs, &
+ rain, rfact, shear, tfac, &
+ val, val1, val2, &
+ w1, w1l, w1s, w2, &
+ w2l, w2s, w3, w3l, &
+ w3s, w4, w4l, w4s, &
+ rho, betaw, &
+ xdby, xpw, xpwd, &
+ xqrch, tem, tem1, tem2, &
+ ptem, ptem1, ptem2
+
+ integer :: kb (im), kbcon (im), kbcon1 (im), &
+ ktcon (im), ktcon1 (im), ktconn (im), &
+ jmin (im), lmin (im), kbmax (im), &
+ kbm (im), kmax (im)
+
+ ! real :: acrt (im), acrtfct (im),
+
+ real :: aa1 (im), &
+ umean (im), tauadv (im), &
+ delhbar (im), delq (im), delq2 (im), &
+ delqbar (im), delqev (im), deltbar (im), &
+ deltv (im), dtconv (im), edt (im), &
+ edto (im), edtx (im), fld (im), &
+ hcdo (im, km), hmax (im), hmin (im), &
+ ucdo (im, km), vcdo (im, km), aa2 (im), &
+ pdot (im), po (im, km), &
+ pwavo (im), pwevo (im), mbdt (im), &
+ qcdo (im, km), qcond (im), qevap (im), &
+ rntot (im), vshear (im), xaa0 (im), &
+ xk (im), xlamd (im), cina (im), &
+ xmb (im), xmbmax (im), xpwav (im), &
+ xpwev (im), xlamx (im), &
+ delubar (im), delvbar (im)
+
+ real :: c0 (im)
+
+ real :: cinpcr, cinpcrmx, cinpcrmn, &
+ cinacr, cinacrmx, cinacrmn
+
+ ! parameters for updraft velocity calculation
+ real :: bet1, cd1, f1, gam1, &
+ bb1, bb2, wucb
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (d0 = .01)
+
+ ! asolfac_deep: aerosol - aware parameter based on lim & hong (2012)
+ ! asolfac_deep = cx / c0s_deep (= .002)
+ ! cx = min ([ - 0.7 ln (nccn) + 24] * 1.e-4, c0s_deep)
+ ! nccn: ccn number concentration in cm^ (- 3)
+ ! until a realistic nccn is provided, typical nccns are assumed
+ ! as nccn = 100 for sea and nccn = 7000 for land
+
+ parameter (cm = 1.0, delta = zvir)
+ parameter (fact1 = (cp_vap - c_liq) / rvgas, fact2 = hlv / rvgas - fact1 * tice)
+ parameter (cthk = 200., dthk = 25.)
+ parameter (cinpcrmx = 180., cinpcrmn = 120.)
+ parameter (cinacrmx = - 120., cinacrmn = - 80.)
+ parameter (bet1 = 1.875, cd1 = .506, f1 = 2.0, gam1 = .5)
+ parameter (betaw = .03, dxcrtuf = 15.e3)
+
+ ! local variables and arrays
+ real :: pfld (im, km), to (im, km), qo (im, km), &
+ uo (im, km), vo (im, km), qeso (im, km)
+
+ ! for updraft velocity calculation
+ real :: wu2 (im, km), buo (im, km), drag (im, km)
+ real :: wc (im), scaldfunc (im), sigmagfm (im)
+
+ real :: qlko_ktcon (im), dellal (im, km), tvo (im, km), &
+ dbyo (im, km), zo (im, km), &
+ xlamue (im, km), xlamud (im, km), &
+ fent1 (im, km), fent2 (im, km), frh (im, km), &
+ heo (im, km), heso (im, km), &
+ qrcd (im, km), dellah (im, km), dellaq (im, km), &
+ dellau (im, km), dellav (im, km), hcko (im, km), &
+ ucko (im, km), vcko (im, km), qcko (im, km), &
+ eta (im, km), etad (im, km), zi (im, km), &
+ qrcko (im, km), qrcdo (im, km), &
+ pwo (im, km), pwdo (im, km), c0t (im, km), &
+ tx1 (im), sumx (im), cnvwt (im, km)
+ ! rhbar (im)
+
+ logical :: totflg, cnvflg (im), asqecflg (im), flg (im)
+
+ ! asqecflg: flag for the quasi - equilibrium assumption of arakawa - schubert
+
+ ! real :: pcrit (15), acritt (15), acrit (15)
+ ! save pcrit, acritt
+ ! data pcrit / 850., 800., 750., 700., 650., 600., 550., 500., 450., 400., &
+ ! 350., 300., 250., 200., 150. /
+ ! data acritt / .0633, .0445, .0553, .0664, .075, .1082, .1521, .2216, &
+ ! .3151, .3677, .41, .5255, .7663, 1.1686, 1.6851 /
+ ! gdas derived acrit
+ ! data acritt / .203, .515, .521, .566, .625, .665, .659, .688, &
+ ! .743, .813, .886, .947, 1.138, 1.377, 1.896 /
+
+ real :: tf, tcr, tcrf
+ parameter (tf = 233.16, tcr = 263.16, tcrf = 1.0 / (tcr - tf))
+
+ ! -----------------------------------------------------------------------
+ ! compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm.
+ ! convert input pressure terms to centibar units.
+ ! convert input pa terms to cb terms -- moorthi
+ ! -----------------------------------------------------------------------
+
+ km1 = km - 1
+
+ ! -----------------------------------------------------------------------
+ ! initialize column - integrated and other single - value - per - column variable arrays.
+ ! initialize arrays
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ cnvflg (i) = .true.
+ rn (i) = 0.
+ mbdt (i) = 10.
+ kbot (i) = km + 1
+ ktop (i) = 0
+ kbcon (i) = km
+ ktcon (i) = 1
+ ktconn (i) = 1
+ dtconv (i) = 3600.
+ pdot (i) = 0.
+ lmin (i) = 1
+ jmin (i) = 1
+ qlko_ktcon (i) = 0.
+ edt (i) = 0.
+ edto (i) = 0.
+ edtx (i) = 0.
+ ! acrt (i) = 0.
+ ! acrtfct (i) = 1.
+ aa1 (i) = 0.
+ aa2 (i) = 0.
+ xaa0 (i) = 0.
+ cina (i) = 0.
+ pwavo (i) = 0.
+ pwevo (i) = 0.
+ xpwav (i) = 0.
+ xpwev (i) = 0.
+ vshear (i) = 0.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine aerosol - aware rain conversion parameter over land
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (islimsk (i) == 1) then
+ c0 (i) = c0s_deep * asolfac_deep
+ else
+ c0 (i) = c0s_deep
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine rain conversion parameter above the freezing level which exponentially
+ ! decreases with decreasing temperature from han et al.'s (2017) equation 8.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (t1 (i, k) > 273.16) then
+ c0t (i, k) = c0 (i)
+ else
+ tem = d0 * (t1 (i, k) - 273.16)
+ tem1 = exp (tem)
+ c0t (i, k) = c0 (i) * tem1
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! initialize convective cloud water and cloud cover to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw)) cnvw (i, k) = 0.
+ if (present (cnvc)) cnvc (i, k) = 0.
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ qr (i, k) = 0.
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! initialize updraft and downdraft mass fluxes to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf)) ud_mf (i, k) = 0.
+ if (present (dd_mf)) dd_mf (i, k) = 0.
+ if (present (dt_mf)) dt_mf (i, k) = 0.
+ enddo
+ enddo
+
+ ! do k = 1, 15
+ ! acrit (k) = acritt (k) * (975. - pcrit (k))
+ ! enddo
+
+ dt2 = delt
+ ! val = 1200.
+ val = 600.
+ dtmin = max (dt2, val)
+ ! val = 5400.
+ val = 10800.
+ dtmax = max (dt2, val)
+
+ ! -----------------------------------------------------------------------
+ ! model tunable parameters are all here
+ ! -----------------------------------------------------------------------
+
+ edtmaxl = .3
+ edtmaxs = .3
+ ! clam_deep = .1
+ aafac = .1
+ ! betal_deep = .15
+ ! betas_deep = .15
+ ! betal_deep = .05
+ ! betas_deep = .05
+ ! evef = 0.07
+ ! evfact_deep = 0.3
+ ! evfactl_deep = 0.3
+
+ crtlamu = 1.0e-4
+ crtlamd = 1.0e-4
+
+ cxlamu = 1.0e-3
+ cxlamd = 1.0e-4
+ xlamde = 1.0e-4
+ xlamdd = 1.0e-4
+
+ ! pgcon_deep = 0.7 ! gregory et al. (1997, qjrms)
+ ! pgcon_deep = 0.55 ! zhang & wu (2003, jas)
+
+ w1l = - 8.e-3
+ w2l = - 4.e-2
+ w3l = - 5.e-3
+ w4l = - 5.e-4
+ w1s = - 2.e-4
+ w2s = - 2.e-3
+ w3s = - 1.e-3
+ w4s = - 2.e-5
+
+ ! -----------------------------------------------------------------------
+ ! define top layer for search of the downdraft originating layer
+ ! and the maximum thetae for updraft
+ ! determine maximum indices for the parcel starting point (kbm), lfc (kbmax), and cloud top (kmax) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ kbmax (i) = km
+ kbm (i) = km
+ kmax (i) = km
+ tx1 (i) = 1.0 / psp (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (prslp (i, k) * tx1 (i) > 0.04) kmax (i) = k + 1
+ if (prslp (i, k) * tx1 (i) > 0.45) kbmax (i) = k + 1
+ if (prslp (i, k) * tx1 (i) > 0.70) kbm (i) = k + 1
+ enddo
+ enddo
+
+ do i = 1, im
+ kmax (i) = min (km, kmax (i))
+ kbmax (i) = min (kbmax (i), kmax (i))
+ kbm (i) = min (kbm (i), kmax (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hydrostatic height assume zero terr and initially assume
+ ! updraft entrainment rate as an inverse function of height
+ ! calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ zo (i, k) = phil (i, k) / g
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate interface height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ zi (i, k) = 0.5 * (zo (i, k) + zo (i, k + 1))
+ xlamue (i, k) = clam_deep / zi (i, k)
+ ! xlamue (i, k) = max (xlamue (i, k), crtlamu)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convert surface pressure to mb from cb
+ ! convert prsl from centibar to millibar, set normalized mass fluxes to 1, cloud properties to 0, and save model state variables (after advection / turbulence) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ pfld (i, k) = prslp (i, k) * 0.01
+ eta (i, k) = 1.
+ fent1 (i, k) = 1.
+ fent2 (i, k) = 1.
+ frh (i, k) = 0.
+ hcko (i, k) = 0.
+ qcko (i, k) = 0.
+ qrcko (i, k) = 0.
+ ucko (i, k) = 0.
+ vcko (i, k) = 0.
+ etad (i, k) = 1.
+ hcdo (i, k) = 0.
+ qcdo (i, k) = 0.
+ ucdo (i, k) = 0.
+ vcdo (i, k) = 0.
+ qrcd (i, k) = 0.
+ qrcdo (i, k) = 0.
+ dbyo (i, k) = 0.
+ pwo (i, k) = 0.
+ pwdo (i, k) = 0.
+ dellal (i, k) = 0.
+ to (i, k) = t1 (i, k)
+ qo (i, k) = q1 (i, k)
+ uo (i, k) = u1 (i, k)
+ vo (i, k) = v1 (i, k)
+ ! uo (i, k) = u1 (i, k) * rcs (i)
+ ! vo (i, k) = v1 (i, k) * rcs (i)
+ wu2 (i, k) = 0.
+ buo (i, k) = 0.
+ drag (i, k) = 0.
+ cnvwt (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! column variables
+ ! p is pressure of the layer (mb)
+ ! t is temperature at t - dt (k) ..tn
+ ! q is mixing ratio at t - dt (kg / kg) ..qn
+ ! to is temperature at t + dt (k) ... this is after advection and turbulan
+ ! qo is mixing ratio at t + dt (kg / kg) ..q1
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate saturation specific humidity and enforce minimum moisture values.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ ! tvo (i, k) = to (i, k) + delta * to (i, k) * qo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute moist static energy
+ ! calculate moist static energy (heo) and saturation moist static energy (heso) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (k <= kmax (i)) then
+ ! tem = g * zo (i, k) + cp_air * to (i, k)
+ tem = phil (i, k) + cp_air * to (i, k)
+ heo (i, k) = tem + hlv * qo (i, k)
+ heso (i, k) = tem + hlv * qeso (i, k)
+ ! heo (i, k) = min (heo (i, k), heso (i, k))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine level with largest moist static energy
+ ! this is the level where updraft starts
+ ! perform calculations related to the updraft of the entraining / detraining cloud model ("static control") .
+ ! search below index "kbm" for the level of maximum moist static energy.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ hmax (i) = heo (i, 1)
+ kb (i) = 1
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (k <= kbm (i)) then
+ if (heo (i, k) > hmax (i)) then
+ kb (i) = k
+ hmax (i) = heo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the temperature, specific humidity, and pressure at interface levels.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k <= kmax (i) - 1) then
+ dz = .5 * (zo (i, k + 1) - zo (i, k))
+ dp = .5 * (pfld (i, k + 1) - pfld (i, k))
+ es = 0.01 * mqs (to (i, k + 1)) ! mqs is in pa
+ pprime = pfld (i, k + 1) + epsm1 * es
+ qs = eps * es / pprime
+ dqsdp = - qs / pprime
+ desdt = es * (fact1 / to (i, k + 1) + fact2 / (to (i, k + 1) ** 2))
+ dqsdt = qs * pfld (i, k + 1) * desdt / (es * pprime)
+ gamma = el2orc * qeso (i, k + 1) / (to (i, k + 1) ** 2)
+ dt = (g * dz + hlv * dqsdp * dp) / (cp_air * (1. + gamma))
+ dq = dqsdt * dt + dqsdp * dp
+ to (i, k) = to (i, k + 1) + dt
+ qo (i, k) = qo (i, k + 1) + dq
+ po (i, k) = .5 * (pfld (i, k) + pfld (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. enforce minimum specific humidity and calculate \f$ (1 - rh) \f$.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k <= kmax (i) - 1) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (po (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ frh (i, k) = 1. - min (qo (i, k) / qeso (i, k), 1.)
+ heo (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qeso (i, k)
+ uo (i, k) = .5 * (uo (i, k) + uo (i, k + 1))
+ vo (i, k) = .5 * (vo (i, k) + vo (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! look for the level of free convection as cloud base
+ ! search below the index "kbmax" for the level of free convection (lfc) where the condition \f$h_b > h^ * \f$ is first met, where \f$h_b, h^ * \f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. set "kbcon" to the index of the lfc.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .true.
+ kbcon (i) = kmax (i)
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (flg (i) .and. k <= kbmax (i)) then
+ if (k > kb (i) .and. heo (i, kb (i)) > heso (i, k)) then
+ kbcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if no lfc, return to the calling routine without modifying state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (kbcon (i) == kmax (i)) cnvflg (i) = .false.
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine the vertical pressure velocity at the lfc. after han and pan (2011), determine the maximum pressure thickness between a parcel's starting level and the lfc. if a parcel doesn't reach the lfc within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! pdot (i) = 10. * dot (i, kbcon (i))
+ pdot (i) = 0.01 * dot (i, kbcon (i)) ! now dot is in pa / s
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if pressure depth between parcel source level
+ ! and cloud base is larger than a critical value, cinpcr
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ ptem = 1. - tem
+ ptem1 = .5 * (cinpcrmx - cinpcrmn)
+ cinpcr = cinpcrmx - ptem * ptem1
+ tem1 = pfld (i, kb (i)) - pfld (i, kbcon (i))
+ if (tem1 > cinpcr) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! assume that updraft entrainment rate above cloud base is
+ ! same as that at cloud base
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamx (i) = xlamue (i, kbcon (i))
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ xlamue (i, k) = xlamx (i)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify a background (turbulent) detrainment rate for the updrafts
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k < kmax (i)) then
+ xlamud (i, k) = xlamx (i)
+ ! xlamud (i, k) = crtlamd
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! functions rapidly decreasing with height, mimicking a cloud ensemble
+ ! entrainment functions decreasing with height (fent),
+ ! mimicking a cloud ensemble
+ ! (bechtold et al., 2008)
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ tem = qeso (i, k) / qeso (i, kbcon (i))
+ fent1 (i, k) = tem ** 2
+ fent2 (i, k) = tem ** 3
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final entrainment and detrainment rates as the sum of turbulent part and
+ ! organized entrainment depending on the environmental relative humidity
+ ! (bechtold et al., 2008)
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. (k > kbcon (i) .and. k < kmax (i))) then
+ tem = cxlamu * frh (i, k) * fent2 (i, k)
+ xlamue (i, k) = xlamue (i, k) * fent1 (i, k) + tem
+ ! tem1 = cxlamd * frh (i, k)
+ ! xlamud (i, k) = xlamud (i, k) + tem1
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine updraft mass flux for the subcloud layers
+ ! calculate the normalized mass flux for subcloud and in - cloud layers according to pan and wu (1995) equation 1:
+ ! \f[
+ ! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d
+ ! \f]
+ ! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < kbcon (i) .and. k >= kb (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ tem = 0.5 * (xlamud (i, k) + xlamud (i, k + 1))
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k + 1)) - tem
+ eta (i, k) = eta (i, k + 1) / (1. + ptem * dz)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute mass flux above cloud base
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k > kbcon (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamud (i, k) + xlamud (i, k - 1))
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) - tem
+ eta (i, k) = eta (i, k - 1) * (1 + ptem * dz)
+ if (eta (i, k) <= 0.) then
+ kmax (i) = k
+ ktconn (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft cloud properties
+ ! set cloud properties equal to the state variables at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = kb (i)
+ hcko (i, indx) = heo (i, indx)
+ ucko (i, indx) = uo (i, indx)
+ vcko (i, indx) = vo (i, indx)
+ pwavo (i) = 0.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud property is modified by the entrainment process
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! cloud property is modified by the entrainment process
+ ! cm is an enhancement factor in entrainment rates for momentum
+ ! calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. discretization follows appendix b of grell (1993). following han and pan (2006), the convective momentum transport is reduced by the convection - induced pressure gradient force by the constant "pgcon_deep", currently set to 0.55 after zhang and wu (2003).
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ hcko (i, k) = ((1. - tem1) * hcko (i, k - 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k - 1))) / factor
+ dbyo (i, k) = hcko (i, k) - heso (i, k)
+
+ tem = 0.5 * cm * tem
+ factor = 1. + tem
+ ptem = tem + pgcon_deep
+ ptem1 = tem - pgcon_deep
+ ucko (i, k) = ((1. - tem) * ucko (i, k - 1) + ptem * uo (i, k) &
+ + ptem1 * uo (i, k - 1)) / factor
+ vcko (i, k) = ((1. - tem) * vcko (i, k - 1) + ptem * vo (i, k) &
+ + ptem1 * vo (i, k - 1)) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! taking account into convection inhibition due to existence of
+ ! dry layers below cloud base
+ ! with entrainment, recalculate the lfc as the first level where buoyancy is positive. the difference in pressure levels between lfcs calculated with / without entrainment must be less than a threshold (currently 25 hpa) . otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. this is the subcloud dryness trigger modification discussed in han and pan (2011).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ kbcon1 (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kmax (i)) then
+ if (k >= kbcon (i) .and. dbyo (i, k) > 0.) then
+ kbcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kbcon1 (i) == kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = pfld (i, kbcon (i)) - pfld (i, kbcon1 (i))
+ if (tem > dthk) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! calculate convective inhibition
+ ! calculate additional trigger condition of the convective inhibition (cin) according to han et al.'s (2017) equation 13.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kbcon1 (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ dz1 * g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if the cin is less than a critical value (cinacr) which is inversely proportional to the large - scale vertical velocity.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ tem = 1. - tem
+ tem1 = .5 * (cinacrmx - cinacrmn)
+ cinacr = cinacrmx - tem * tem1
+
+ ! cinacr = cinacrmx
+ if (cina (i) < cinacr) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine first guess cloud top as the level of zero buoyancy
+ ! calculate the cloud top as the first level where parcel buoyancy becomes negative. if the thickness of the calculated convection is less than a threshold (currently 200 hpa), then convection is inhibited, and the scheme returns to the calling routine.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ ktcon (i) = 1
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kmax (i)) then
+ if (k > kbcon1 (i) .and. dbyo (i, k) < 0.) then
+ ktcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (ktcon (i) == 1 .and. ktconn (i) > 1) then
+ ktcon (i) = ktconn (i)
+ endif
+ tem = pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ if (tem < cthk) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! search for downdraft originating level above theta - e minimum
+ ! to originate the downdraft, search for the level above the minimum in moist static energy. return to the calling routine without modification if this level is determined to be outside of the convective cloud layers.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ hmin (i) = heo (i, kbcon1 (i))
+ lmin (i) = kbmax (i)
+ jmin (i) = kbmax (i)
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kbmax (i)) then
+ if (k > kbcon1 (i) .and. heo (i, k) < hmin (i)) then
+ lmin (i) = k + 1
+ hmin (i) = heo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! make sure that jmin (i) is within the cloud
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ jmin (i) = min (lmin (i), ktcon (i) - 1)
+ jmin (i) = max (jmin (i), kbcon1 (i) + 1)
+ if (jmin (i) >= ktcon (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify upper limit of mass flux at cloud base
+ ! calculate the maximum value of the cloud base mass flux using the cfl - criterion - based formula of han and pan (2011), equation 7.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! xmbmax (i) = .1
+
+ k = kbcon (i)
+ dp = delp (i, k)
+ xmbmax (i) = dp / (g * dt2)
+
+ ! mbdt (i) = 0.1 * dp / g
+
+ ! tem = dp / (g * dt2)
+ ! xmbmax (i) = min (tem, xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property and precipitation
+ ! set cloud moisture property equal to the enviromental moisture at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! aa1 (i) = 0.
+ qcko (i, kb (i)) = qo (i, kb (i))
+ qrcko (i, kb (i)) = qo (i, kb (i))
+ ! rhbar (i) = 0.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the moisture content of the entraining / detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation a.14 in grell (1993). their difference is the amount of convective cloud water (qlk = rain + condensate) . determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo) . calculate and save the negative cloud work function (aa1) due to water loading. the liquid water in the updraft layer is assumed to be detrained from the layers above the level of the minimum moist static energy into the grid - scale cloud water (dellal) .
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! rhbar (i) = rhbar (i) + qo (i, k) / qeso (i, k)
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i) .and. dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0 .and. k > jmin (i)) then
+ ptem = c0t (i, k) + c1_deep
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_deep * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ ! aa1 (i) = aa1 (i) - dz * g * qlk * etah
+ ! aa1 (i) = aa1 (i) - dz * g * qlk
+ buo (i, k) = buo (i, k) - g * qlk
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ pwavo (i) = pwavo (i) + pwo (i, k)
+ ! cnvwt (i, k) = (etah * qlk + pwo (i, k)) * g / dp
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy and drag for updraft velocity
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i)) then
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ buo (i, k) = buo (i, k) + (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ buo (i, k) = buo (i, k) + g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ drag (i, k) = max (xlamue (i, k), xlamud (i, k))
+ endif
+
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! indx = ktcon (i) - kb (i) - 1
+ ! rhbar (i) = rhbar (i) / float (indx)
+ ! endif
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! do k = 2, km1
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (k >= kbcon (i) .and. k < ktcon (i)) then
+ ! dz1 = zo (i, k + 1) - zo (i, k)
+ ! gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ ! rfact = 1. + delta * cp_air * gamma &
+ ! * to (i, k) / hlv
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ ! dz1 * (g / (cp_air * to (i, k))) &
+ ! * dbyo (i, k) / (1. + gamma) &
+ ! * rfact
+ ! val = 0.
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate the cloud work function according to pan and wu (1995) equation 4:
+ ! \f[
+ ! a_u = \int_{z_0}^{z_t}\frac{g}{c_pt (z) }\frac{\eta}{1 + \gamma}[h (z) - h^ * (z) ]dz
+ ! \f]
+ ! (discretized according to grell (1993) equation b.10 using b.2 and b.3 of arakawa and schubert (1974) and assuming \f$\eta = 1\f$) where \f$a_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{l}{c_p}\left (\frac{\partial \overline{q_s}}{\partial t}\right) _p\f$ and other quantities are previously defined.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ ! aa1 (i) = aa1 (i) + buo (i, k) * dz1 * eta (i, k)
+ aa1 (i) = aa1 (i) + buo (i, k) * dz1
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i) .and. aa1 (i) <= 0.) cnvflg (i) = .false.
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! estimate the onvective overshooting as the level
+ ! where the [aafac * cloud work function] becomes zero,
+ ! which is the final cloud top
+ ! continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to han and pan (2011). convective overshooting stops when \f$ ca_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa2 (i) = aafac * aa1 (i)
+ endif
+ enddo
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ ktcon1 (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k >= ktcon (i) .and. k < kmax (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ aa2 (i) = aa2 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ ! val = 0.
+ ! aa2 (i) = aa2 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ if (aa2 (i) < 0.) then
+ ktcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property, detraining cloud water
+ ! and precipitation in overshooting layers
+ ! for the overshooting convection, calculate the moisture content of the entraining / detraining parcel as before. partition convective cloud water and precipitation and detrain convective cloud water above the mimimum in moist static energy.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= ktcon (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0) then
+ ptem = c0t (i, k) + c1_deep
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_deep * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ pwavo (i) = pwavo (i) + pwo (i, k)
+ ! cnvwt (i, k) = (etah * qlk + pwo (i, k)) * g / dp
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity square (wu2)
+ ! calculate updraft velocity square (wu2) according to han et al.'s (2017) equation 7.
+ ! -----------------------------------------------------------------------
+
+ ! bb1 = 2. * (1. + bet1 * cd1)
+ ! bb2 = 2. / (f1 * (1. + gam1))
+ !
+ ! bb1 = 3.9
+ ! bb2 = 0.67
+ !
+ ! bb1 = 2.0
+ ! bb2 = 4.0
+
+ bb1 = 4.0
+ bb2 = 0.8
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kbcon1 (i)
+ tem = po (i, k) / (rdgas * to (i, k))
+ wucb = - 0.01 * dot (i, k) / (tem * g)
+ if (wucb > 0.) then
+ wu2 (i, k) = wucb * wucb
+ else
+ wu2 (i, k) = 0.
+ endif
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.25 * bb1 * (drag (i, k) + drag (i, k - 1)) * dz
+ tem1 = 0.5 * bb2 * (buo (i, k) + buo (i, k - 1)) * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ wu2 (i, k) = max (wu2 (i, k), 0.)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity average over the whole cumulus
+ ! calculate the mean updraft velocity within the cloud (wc) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ wc (i) = 0.
+ sumx (i) = 0.
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (sqrt (wu2 (i, k)) + sqrt (wu2 (i, k - 1)))
+ wc (i) = wc (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sumx (i) == 0.) then
+ cnvflg (i) = .false.
+ else
+ wc (i) = wc (i) / sumx (i)
+ endif
+ val = 1.e-4
+ if (wc (i) < val) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! exchange ktcon with ktcon1
+ ! swap the indices of the convective cloud top (ktcon) and the overshooting convection top (ktcon1) to use the same cloud top level in the calculations of \f$a^ + \f$ and \f$a^ * \f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = ktcon (i)
+ ktcon (i) = ktcon1 (i)
+ ktcon1 (i) = kk
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! this section is ready for cloud water
+ ! separate the total updraft cloud water at cloud top into vapor and condensate.
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ ! -----------------------------------------------------------------------
+ ! compute liquid and vapor separation at cloud top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = ktcon (i) - 1
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ dq = qcko (i, k) - qrch
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ qlko_ktcon (i) = dq
+ qcko (i, k) = qrch
+ endif
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! downdraft calculations
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! compute precipitation efficiency in terms of windshear
+ ! perform calculations related to the downdraft of the entraining / detraining cloud model ("static control") .
+ ! first, in order to calculate the downdraft mass flux (as a fraction of the updraft mass flux), calculate the wind shear and precipitation efficiency according to equation 58 in fritsch and chappell (1980):
+ ! \f[
+ ! e = 1.591 - 0.639\frac{\delta v}{\delta z} + 0.0953\left (\frac{\delta v}{\delta z}\right) ^2 - 0.00496\left (\frac{\delta v}{\delta z}\right) ^3
+ ! \f]
+ ! where \f$\delta v\f$ is the integrated horizontal shear over the cloud depth, \f$\delta z\f$, (the ratio is converted to units of \f$10^{ - 3} s^{ - 1}\f$) . the variable "edto" is \f$1 - e\f$ and is constrained to the range \f$[0, 0.9]\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ shear = sqrt ((uo (i, k) - uo (i, k - 1)) ** 2 &
+ + (vo (i, k) - vo (i, k - 1)) ** 2)
+ vshear (i) = vshear (i) + shear
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 1.e3 * vshear (i) / (zi (i, ktcon (i)) - zi (i, kb (i)))
+ e1 = 1.591 - .639 * vshear (i) &
+ + .0953 * (vshear (i) ** 2) - .00496 * (vshear (i) ** 3)
+ edt (i) = 1. - e1
+ val = .9
+ edt (i) = min (edt (i), val)
+ val = .0
+ edt (i) = max (edt (i), val)
+ edto (i) = edt (i)
+ edtx (i) = edt (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine detrainment rate between 1 and kbcon
+ ! next, calculate the variable detrainment rate between the surface and the lfc according to:
+ ! \f[
+ ! \lambda_d = \frac{1 - \beta^{\frac{1}{k_{lfc}}}}{\overline{\delta z}}
+ ! \f]
+ ! \f$\lambda_d\f$ is the detrainment rate, \f$\beta\f$ is a constant currently set to 0.05, implying that only 5% of downdraft mass flux at lfc reaches the ground surface due to detrainment, \f$k_{lfc}\f$ is the vertical index of the lfc level, and \f$\overline{\delta z}\f$ is the average vertical grid spacing below the lfc.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ endif
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= 1 .and. k < kbcon (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ beta = betas_deep
+ if (islimsk (i) == 1) beta = betal_deep
+ if (cnvflg (i)) then
+ dz = (sumx (i) + zi (i, 1)) / float (kbcon (i))
+ tem = 1. / float (kbcon (i))
+ xlamd (i) = (1. - beta ** tem) / dz
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine downdraft mass flux
+ ! calculate the normalized downdraft mass flux from equation 1 of pan and wu (1995). downdraft entrainment and detrainment rates are constants from the downdraft origination to the lfc.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ if (k < jmin (i) .and. k >= kbcon (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ptem = xlamdd - xlamde
+ etad (i, k) = etad (i, k + 1) * (1. - ptem * dz)
+ else if (k < kbcon (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ptem = xlamd (i) + xlamdd - xlamde
+ etad (i, k) = etad (i, k + 1) * (1. - ptem * dz)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft moisture properties
+ ! set initial cloud downdraft properties equal to the state variables at the downdraft origination level.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ jmn = jmin (i)
+ hcdo (i, jmn) = heo (i, jmn)
+ qcdo (i, jmn) = qo (i, jmn)
+ qrcdo (i, jmn) = qo (i, jmn)
+ ucdo (i, jmn) = uo (i, jmn)
+ vcdo (i, jmn) = vo (i, jmn)
+ pwevo (i) = 0.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the cloud properties as a parcel descends, modified by entrainment and detrainment. discretization follows appendix b of grell (1993).
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ factor = 1. + tem - tem1
+ hcdo (i, k) = ((1. - tem1) * hcdo (i, k + 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k + 1))) / factor
+ dbyo (i, k) = hcdo (i, k) - heso (i, k)
+
+ tem = 0.5 * cm * tem
+ factor = 1. + tem
+ ptem = tem - pgcon_deep
+ ptem1 = tem + pgcon_deep
+ ucdo (i, k) = ((1. - tem) * ucdo (i, k + 1) + ptem * uo (i, k + 1) &
+ + ptem1 * uo (i, k)) / factor
+ vcdo (i, k) = ((1. - tem) * vcdo (i, k + 1) + ptem * vo (i, k + 1) &
+ + ptem1 * vo (i, k)) / factor
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute the amount of moisture that is necessary to keep the downdraft saturated.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrcdo (i, k) = qeso (i, k) + &
+ (1. / hlv) * (gamma / (1. + gamma)) * dbyo (i, k)
+ ! detad = etad (i, k + 1) - etad (i, k)
+
+ dz = zi (i, k + 1) - zi (i, k)
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ factor = 1. + tem - tem1
+ qcdo (i, k) = ((1. - tem1) * qrcdo (i, k + 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k + 1))) / factor
+
+ ! pwdo (i, k) = etad (i, k + 1) * qcdo (i, k + 1) - &
+ ! etad (i, k) * qrcdo (i, k)
+ ! pwdo (i, k) = pwdo (i, k) - detad * &
+ ! .5 * (qrcdo (i, k) + qrcdo (i, k + 1))
+
+ pwdo (i, k) = etad (i, k) * (qcdo (i, k) - qrcdo (i, k))
+ pwevo (i) = pwevo (i) + pwdo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final downdraft strength dependent on precip
+ ! efficiency (edt), normalized condensate (pwav), and
+ ! evaporate (pwev)
+ ! update the precipitation efficiency (edto) based on the ratio of normalized cloud condensate (pwavo) to normalized cloud evaporate (pwevo) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ edtmax = edtmaxl
+ if (islimsk (i) == 0) edtmax = edtmaxs
+ if (cnvflg (i)) then
+ if (pwevo (i) < 0.) then
+ edto (i) = - edto (i) * pwavo (i) / pwevo (i)
+ edto (i) = min (edto (i), edtmax)
+ else
+ edto (i) = 0.
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft cloudwork functions
+ ! calculate downdraft cloud work function (\f$a_d\f$) according to equation a.42 (discretized by b.11) in grell (1993). add it to the updraft cloud work function, \f$a_u\f$.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < jmin (i)) then
+ gamma = el2orc * qeso (i, k) / to (i, k) ** 2
+ dhh = hcdo (i, k)
+ dt = to (i, k)
+ dg = gamma
+ dh = heso (i, k)
+ dz = - 1. * (zo (i, k + 1) - zo (i, k))
+ ! aa1 (i) = aa1 (i) + edto (i) * dz * etad (i, k)
+ aa1 (i) = aa1 (i) + edto (i) * dz &
+ * (g / (cp_air * dt)) * ((dhh - dh) / (1. + dg)) &
+ * (1. + delta * cp_air * dg * dt / hlv)
+ val = 0.
+ ! aa1 (i) = aa1 (i) + edto (i) * dz * etad (i, k)
+ aa1 (i) = aa1 (i) + edto (i) * dz &
+ * g * delta * max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! check for negative total cloud work function; if found, return to calling routine without modifying state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i) .and. aa1 (i) <= 0.) then
+ cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! what would the change be, that a cloud with unit mass
+ ! will do to the environment?
+ ! calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux near the surface using equations b.18 and b.19 from grell (1993), for all layers below cloud top from equations b.14 and b.15, and for the cloud top from b.16 and b.17.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ dellah (i, k) = 0.
+ dellaq (i, k) = 0.
+ dellau (i, k) = 0.
+ dellav (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ dp = delp (i, 1)
+ dellah (i, 1) = edto (i) * etad (i, 1) * (hcdo (i, 1) &
+ - heo (i, 1)) * g / dp
+ dellaq (i, 1) = edto (i) * etad (i, 1) * (qrcdo (i, 1) &
+ - qo (i, 1)) * g / dp
+ dellau (i, 1) = edto (i) * etad (i, 1) * (ucdo (i, 1) &
+ - uo (i, 1)) * g / dp
+ dellav (i, 1) = edto (i) * etad (i, 1) * (vcdo (i, 1) &
+ - vo (i, 1)) * g / dp
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! changed due to subsidence and entrainment
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k > jmin (i)) adw = 0.
+ dp = delp (i, k)
+ dz = zi (i, k) - zi (i, k - 1)
+
+ dv1h = heo (i, k)
+ dv2h = .5 * (heo (i, k) + heo (i, k - 1))
+ dv3h = heo (i, k - 1)
+ dv1q = qo (i, k)
+ dv2q = .5 * (qo (i, k) + qo (i, k - 1))
+ dv3q = qo (i, k - 1)
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1))
+ tem1 = 0.5 * (xlamud (i, k) + xlamud (i, k - 1))
+
+ if (k <= kbcon (i)) then
+ ptem = xlamde
+ ptem1 = xlamd (i) + xlamdd
+ else
+ ptem = xlamde
+ ptem1 = xlamdd
+ endif
+
+ dellah (i, k) = dellah (i, k) + &
+ ((aup * eta (i, k) - adw * edto (i) * etad (i, k)) * dv1h &
+ - (aup * eta (i, k - 1) - adw * edto (i) * etad (i, k - 1)) * dv3h &
+ - (aup * tem * eta (i, k - 1) + adw * edto (i) * ptem * etad (i, k)) * dv2h * dz &
+ + aup * tem1 * eta (i, k - 1) * .5 * (hcko (i, k) + hcko (i, k - 1)) * dz &
+ + adw * edto (i) * ptem1 * etad (i, k) * .5 * (hcdo (i, k) + hcdo (i, k - 1)) * dz &
+ ) * g / dp
+
+ dellaq (i, k) = dellaq (i, k) + &
+ ((aup * eta (i, k) - adw * edto (i) * etad (i, k)) * dv1q &
+ - (aup * eta (i, k - 1) - adw * edto (i) * etad (i, k - 1)) * dv3q &
+ - (aup * tem * eta (i, k - 1) + adw * edto (i) * ptem * etad (i, k)) * dv2q * dz &
+ + aup * tem1 * eta (i, k - 1) * .5 * (qrcko (i, k) + qcko (i, k - 1)) * dz &
+ + adw * edto (i) * ptem1 * etad (i, k) * .5 * (qrcdo (i, k) + qcdo (i, k - 1)) * dz &
+ ) * g / dp
+
+ tem1 = eta (i, k) * (uo (i, k) - ucko (i, k))
+ tem2 = eta (i, k - 1) * (uo (i, k - 1) - ucko (i, k - 1))
+ ptem1 = etad (i, k) * (uo (i, k) - ucdo (i, k))
+ ptem2 = etad (i, k - 1) * (uo (i, k - 1) - ucdo (i, k - 1))
+ dellau (i, k) = dellau (i, k) + &
+ (aup * (tem1 - tem2) - adw * edto (i) * (ptem1 - ptem2)) * g / dp
+
+ tem1 = eta (i, k) * (vo (i, k) - vcko (i, k))
+ tem2 = eta (i, k - 1) * (vo (i, k - 1) - vcko (i, k - 1))
+ ptem1 = etad (i, k) * (vo (i, k) - vcdo (i, k))
+ ptem2 = etad (i, k - 1) * (vo (i, k - 1) - vcdo (i, k - 1))
+ dellav (i, k) = dellav (i, k) + &
+ (aup * (tem1 - tem2) - adw * edto (i) * (ptem1 - ptem2)) * g / dp
+
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = ktcon (i)
+ dp = delp (i, indx)
+ dv1h = heo (i, indx - 1)
+ dellah (i, indx) = eta (i, indx - 1) * &
+ (hcko (i, indx - 1) - dv1h) * g / dp
+ dv1q = qo (i, indx - 1)
+ dellaq (i, indx) = eta (i, indx - 1) * &
+ (qcko (i, indx - 1) - dv1q) * g / dp
+ dellau (i, indx) = eta (i, indx - 1) * &
+ (ucko (i, indx - 1) - uo (i, indx - 1)) * g / dp
+ dellav (i, indx) = eta (i, indx - 1) * &
+ (vcko (i, indx - 1) - vo (i, indx - 1)) * g / dp
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! -----------------------------------------------------------------------
+
+ dellal (i, indx) = eta (i, indx - 1) * &
+ qlko_ktcon (i) * g / dp
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final changed variable per unit mass flux
+ ! if grid size is less than a threshold value (dxcrtas_deep: currently 8km), the quasi - equilibrium assumption of arakawa - schubert is not used any longer.
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! if grid size is less than a threshold value (dxcrtas_deep),
+ ! the quasi - equilibrium assumption of arakawa - schubert is not
+ ! used any longer.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ asqecflg (i) = cnvflg (i)
+ if (asqecflg (i) .and. gsize (i) < dxcrtas_deep) then
+ asqecflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if grid size is larger than the threshold value (i.e., asqecflg = .true.), the quasi - equilibrium assumption is used to obtain the cloud base mass flux. to begin with, calculate the change in the temperature and moisture profiles per unit cloud base mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i)) then
+ if (k > ktcon (i)) then
+ qo (i, k) = q1 (i, k)
+ to (i, k) = t1 (i, k)
+ endif
+ if (k <= ktcon (i)) then
+ qo (i, k) = dellaq (i, k) * mbdt (i) + q1 (i, k)
+ dellat = (dellah (i, k) - hlv * dellaq (i, k)) / cp_air
+ to (i, k) = dellat * mbdt (i) + t1 (i, k)
+ val = 1.e-10
+ qo (i, k) = max (qo (i, k), val)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! the above changed environment is now used to calulate the
+ ! effect the arbitrary cloud (with unit mass flux)
+ ! would have on the stability,
+ ! which then is used to calculate the real mass flux,
+ ! necessary to keep this change in balance with the large - scale
+ ! destabilization.
+ ! environmental conditions again, first heights
+ ! using the updated temperature and moisture profiles that were modified by the convection on a short time - scale, recalculate the total cloud work function to determine the change in the cloud work function due to convection, or the stabilizing effect of the cumulus.
+ ! using notation from pan and wu (1995), the previously calculated cloud work function is denoted by \f$a^ + \f$. now, it is necessary to use the entraining / detraining cloud model ("static control") to determine the cloud work function of the environment after the stabilization of the arbitrary convective element (per unit cloud base mass flux) has been applied, denoted by \f$a^ * \f$.
+ ! recalculate saturation specific humidity.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ ! tvo (i, k) = to (i, k) + delta * to (i, k) * qo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! moist static energy
+ ! recalculate moist static energy and saturation moist static energy.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i) - 1) then
+ dz = .5 * (zo (i, k + 1) - zo (i, k))
+ dp = .5 * (pfld (i, k + 1) - pfld (i, k))
+ es = 0.01 * mqs (to (i, k + 1)) ! mqs is in pa
+ pprime = pfld (i, k + 1) + epsm1 * es
+ qs = eps * es / pprime
+ dqsdp = - qs / pprime
+ desdt = es * (fact1 / to (i, k + 1) + fact2 / (to (i, k + 1) ** 2))
+ dqsdt = qs * pfld (i, k + 1) * desdt / (es * pprime)
+ gamma = el2orc * qeso (i, k + 1) / (to (i, k + 1) ** 2)
+ dt = (g * dz + hlv * dqsdp * dp) / (cp_air * (1. + gamma))
+ dq = dqsdt * dt + dqsdp * dp
+ to (i, k) = to (i, k + 1) + dt
+ qo (i, k) = qo (i, k + 1) + dq
+ po (i, k) = .5 * (pfld (i, k) + pfld (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (asqecflg (i) .and. k <= kmax (i) - 1) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (po (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ heo (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qeso (i, k)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ k = kmax (i)
+ heo (i, k) = g * zo (i, k) + cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = g * zo (i, k) + cp_air * to (i, k) + hlv * qeso (i, k)
+ ! heo (i, k) = min (heo (i, k), heso (i, k))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! static control
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! moisture and cloud work functions
+ ! as before, recalculate the updraft cloud work function.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ xaa0 (i) = 0.
+ xpwav (i) = 0.
+ endif
+ enddo
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ indx = kb (i)
+ hcko (i, indx) = heo (i, indx)
+ qcko (i, indx) = qo (i, indx)
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (asqecflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ hcko (i, k) = ((1. - tem1) * hcko (i, k - 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k - 1))) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (asqecflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ xdby = hcko (i, k) - heso (i, k)
+ xqrch = qeso (i, k) &
+ + gamma * xdby / (hlv * (1. + gamma))
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.25 * (xlamud (i, k) + xlamud (i, k - 1)) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+
+ dq = eta (i, k) * (qcko (i, k) - xqrch)
+
+ if (k >= kbcon (i) .and. dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ if (ncloud > 0 .and. k > jmin (i)) then
+ ptem = c0t (i, k) + c1_deep
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ if (k < ktcon1 (i)) then
+ ! xaa0 (i) = xaa0 (i) - dz * g * qlk * etah
+ xaa0 (i) = xaa0 (i) - dz * g * qlk
+ endif
+ qcko (i, k) = qlk + xqrch
+ xpw = etah * c0t (i, k) * dz * qlk
+ xpwav (i) = xpwav (i) + xpw
+ endif
+ endif
+ if (k >= kbcon (i) .and. k < ktcon1 (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ xaa0 (i) = xaa0 (i) &
+ ! + dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ + dz1 * (g / (cp_air * to (i, k))) &
+ * xdby / (1. + gamma) &
+ * rfact
+ val = 0.
+ xaa0 (i) = xaa0 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ dz1 * g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft calculations
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! downdraft moisture properties
+ ! as before, recalculate the downdraft cloud work function.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ jmn = jmin (i)
+ hcdo (i, jmn) = heo (i, jmn)
+ qcdo (i, jmn) = qo (i, jmn)
+ qrcd (i, jmn) = qo (i, jmn)
+ xpwev (i) = 0.
+ endif
+ enddo
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (asqecflg (i) .and. k < jmin (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ factor = 1. + tem - tem1
+ hcdo (i, k) = ((1. - tem1) * hcdo (i, k + 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k + 1))) / factor
+ endif
+ enddo
+ enddo
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (asqecflg (i) .and. k < jmin (i)) then
+ dq = qeso (i, k)
+ dt = to (i, k)
+ gamma = el2orc * dq / dt ** 2
+ dh = hcdo (i, k) - heso (i, k)
+ qrcd (i, k) = dq + (1. / hlv) * (gamma / (1. + gamma)) * dh
+ ! detad = etad (i, k + 1) - etad (i, k)
+
+ dz = zi (i, k + 1) - zi (i, k)
+ if (k >= kbcon (i)) then
+ tem = xlamde * dz
+ tem1 = 0.5 * xlamdd * dz
+ else
+ tem = xlamde * dz
+ tem1 = 0.5 * (xlamd (i) + xlamdd) * dz
+ endif
+ factor = 1. + tem - tem1
+ qcdo (i, k) = ((1. - tem1) * qrcd (i, k + 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k + 1))) / factor
+
+ ! xpwd = etad (i, k + 1) * qcdo (i, k + 1) - &
+ ! etad (i, k) * qrcd (i, k)
+ ! xpwd = xpwd - detad * &
+ ! .5 * (qrcd (i, k) + qrcd (i, k + 1))
+
+ xpwd = etad (i, k) * (qcdo (i, k) - qrcd (i, k))
+ xpwev (i) = xpwev (i) + xpwd
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ edtmax = edtmaxl
+ if (islimsk (i) == 0) edtmax = edtmaxs
+ if (asqecflg (i)) then
+ if (xpwev (i) >= 0.) then
+ edtx (i) = 0.
+ else
+ edtx (i) = - edtx (i) * xpwav (i) / xpwev (i)
+ edtx (i) = min (edtx (i), edtmax)
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! downdraft cloudwork functions
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (asqecflg (i) .and. k < jmin (i)) then
+ gamma = el2orc * qeso (i, k) / to (i, k) ** 2
+ dhh = hcdo (i, k)
+ dt = to (i, k)
+ dg = gamma
+ dh = heso (i, k)
+ dz = - 1. * (zo (i, k + 1) - zo (i, k))
+ ! xaa0 (i) = xaa0 (i) + edtx (i) * dz * etad (i, k)
+ xaa0 (i) = xaa0 (i) + edtx (i) * dz &
+ * (g / (cp_air * dt)) * ((dhh - dh) / (1. + dg)) &
+ * (1. + delta * cp_air * dg * dt / hlv)
+ val = 0.
+ ! xaa0 (i) = xaa0 (i) + edtx (i) * dz * etad (i, k)
+ xaa0 (i) = xaa0 (i) + edtx (i) * dz &
+ * g * delta * max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate critical cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (pfld (i, ktcon (i)) < pcrit (15)) then
+ ! acrt (i) = acrit (15) * (975. - pfld (i, ktcon (i))) &
+ ! / (975. - pcrit (15))
+ ! else if (pfld (i, ktcon (i)) > pcrit (1)) then
+ ! acrt (i) = acrit (1)
+ ! else
+ ! k = int ((850. - pfld (i, ktcon (i))) / 50.) + 2
+ ! k = min (k, 15)
+ ! k = max (k, 2)
+ ! acrt (i) = acrit (k) + (acrit (k - 1) - acrit (k)) * &
+ ! (pfld (i, ktcon (i)) - pcrit (k)) / (pcrit (k - 1) - pcrit (k))
+ ! endif
+ ! endif
+ ! enddo
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (islimsk (i) == 1) then
+ ! w1 = w1l
+ ! w2 = w2l
+ ! w3 = w3l
+ ! w4 = w4l
+ ! else
+ ! w1 = w1s
+ ! w2 = w2s
+ ! w3 = w3s
+ ! w4 = w4s
+ ! endif
+
+ ! -----------------------------------------------------------------------
+ ! modify critical cloud workfunction by cloud base vertical velocity
+ ! -----------------------------------------------------------------------
+
+ ! if (pdot (i) <= w4) then
+ ! acrtfct (i) = (pdot (i) - w4) / (w3 - w4)
+ ! elseif (pdot (i) >= - w4) then
+ ! acrtfct (i) = - (pdot (i) + w4) / (w4 - w3)
+ ! else
+ ! acrtfct (i) = 0.
+ ! endif
+ ! val1 = - 1.
+ ! acrtfct (i) = max (acrtfct (i), val1)
+ ! val2 = 1.
+ ! acrtfct (i) = min (acrtfct (i), val2)
+ ! acrtfct (i) = 1. - acrtfct (i)
+
+ ! -----------------------------------------------------------------------
+ ! modify acrtfct (i) by colume mean rh if rhbar (i) is greater than 80 percent
+ ! -----------------------------------------------------------------------
+
+ ! if (rhbar (i) >= .8) then
+ ! acrtfct (i) = acrtfct (i) * (.9 - min (rhbar (i), .9)) * 10.
+ ! endif
+
+ ! -----------------------------------------------------------------------
+ ! modify adjustment time scale by cloud base vertical velocity
+ ! -----------------------------------------------------------------------
+
+ ! dtconv (i) = dt2 + max ((1800. - dt2), 0.) * &
+ ! (pdot (i) - w2) / (w1 - w2)
+ ! dtconv (i) = max (dtconv (i), dt2)
+ ! dtconv (i) = 1800. * (pdot (i) - w2) / (w1 - w2)
+
+ ! dtconv (i) = max (dtconv (i), dtmin)
+ ! dtconv (i) = min (dtconv (i), dtmax)
+
+ ! endif
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute convective turn - over time
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! following bechtold et al. (2008), the convective adjustment time (dtconv) is set to be proportional to the convective turnover time, which is computed using the mean updraft velocity (wc) and the cloud depth. it is also proportional to the grid size (gsize) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = zi (i, ktcon1 (i)) - zi (i, kbcon1 (i))
+ dtconv (i) = tem / wc (i)
+ tfac = 1. + gsize (i) / 75000.
+ dtconv (i) = tfac * dtconv (i)
+ dtconv (i) = max (dtconv (i), dtmin)
+ dtconv (i) = min (dtconv (i), dtmax)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate advective time scale (tauadv) using a mean cloud layer wind speed.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ umean (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon1 (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = sqrt (u1 (i, k) * u1 (i, k) + v1 (i, k) * v1 (i, k))
+ umean (i) = umean (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ umean (i) = umean (i) / sumx (i)
+ umean (i) = max (umean (i), 1.)
+ tauadv (i) = gsize (i) / umean (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! from han et al.'s (2017) equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi - equilibrium assumption of arakawa - schubert is not valid any longer.
+ ! as discussed in han et al. (2017), when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. in this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv.
+ ! compute cloud base mass flux as a function of the mean
+ ! updraft velcoity for the grid sizes where
+ ! the quasi - equilibrium assumption of arakawa - schubert is not
+ ! valid any longer.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i) .and. .not.asqecflg (i)) then
+ k = kbcon (i)
+ rho = po (i, k) * 100. / (rdgas * to (i, k))
+ tfac = tauadv (i) / dtconv (i)
+ tfac = min (tfac, 1.)
+ xmb (i) = tfac * betaw * rho * wc (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud base mass flux using
+ ! the quasi - equilibrium assumption of arakawa - schubert
+ ! for the cases where the quasi - equilibrium assumption of arakawa - schubert is valid, first calculate the large scale destabilization as in equation 5 of pan and wu (1995):
+ ! \f[
+ ! \frac{\partial a}{\partial t}_{ls} = \frac{a^ + - ca^0}{\delta t_{ls}}
+ ! \f]
+ ! here \f$a^0\f$ is set to zero following han et al.'s (2017), implying that the instability is completely eliminated after the convective adjustment time, \f$\delta t_{ls}\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (asqecflg (i)) then
+ ! fld (i) = (aa1 (i) - acrt (i) * acrtfct (i)) / dtconv (i)
+ fld (i) = aa1 (i) / dtconv (i)
+ if (fld (i) <= 0.) then
+ asqecflg (i) = .false.
+ cnvflg (i) = .false.
+ endif
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! calculate the stabilization effect of the convection (per unit cloud base mass flux) as in equation 6 of pan and wu (1995):
+ ! \f[
+ ! \frac{\partial a}{\partial t}_{cu} = \frac{a^ * - a^ + }{\delta t_{cu}}
+ ! \f]
+ ! \f$\delta t_{cu}\f$ is the short timescale of the convection.
+ ! -----------------------------------------------------------------------
+
+ if (asqecflg (i)) then
+ ! xaa0 (i) = max (xaa0 (i), 0.)
+ xk (i) = (xaa0 (i) - aa1 (i)) / mbdt (i)
+ if (xk (i) >= 0.) then
+ asqecflg (i) = .false.
+ cnvflg (i) = .false.
+ endif
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! kernel, cloud base mass flux
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! the cloud base mass flux (xmb) is then calculated from equation 7 of pan and wu (1995)
+ ! \f[
+ ! m_c = \frac{ - \frac{\partial a}{\partial t}_{ls}}{\frac{\partial a}{\partial t}_{cu}}
+ ! \f]
+ ! -----------------------------------------------------------------------
+ ! again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv.
+ ! -----------------------------------------------------------------------
+
+ if (asqecflg (i)) then
+ tfac = tauadv (i) / dtconv (i)
+ tfac = min (tfac, 1.)
+ xmb (i) = - tfac * fld (i) / xk (i)
+ ! xmb (i) = min (xmb (i), xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the large scale destabilization is less than zero, or the stabilization by the convection is greater than zero, then the scheme returns to the calling routine without modifying the state variables.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! modified grell & freitas' (2014) updraft fraction which uses
+ ! actual entrainment rate at cloud base
+ ! for scale - aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see han et al.'s (2017) equation 4 and 5), following the study by grell and freitas (2014).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = min (max (xlamx (i), 7.e-5), 3.e-4)
+ tem = 0.2 / tem
+ tem1 = 3.14 * tem * tem
+ sigmagfm (i) = tem1 / (gsize (i) ** 2.0)
+ sigmagfm (i) = max (sigmagfm (i), 0.001)
+ sigmagfm (i) = min (sigmagfm (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute scale - aware function based on arakawa & wu (2013)
+ ! then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by arakawa and wu (2013) (also see han et al.'s (2017) equation 1 and 2) . the final cloud base mass flux with scale - aware parameterization is obtained from the mass flux when sigmagfm < < 1, multiplied by the reduction factor (han et al.'s (2017) equation 2) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (gsize (i) < dxcrtuf) then
+ scaldfunc (i) = (1. - sigmagfm (i)) * (1. - sigmagfm (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ xmb (i) = xmb (i) * scaldfunc (i)
+ xmb (i) = min (xmb (i), xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! restore to, qo, uo, vo to t1, q1, u1, v1 in case convection stops
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ to (i, k) = t1 (i, k)
+ qo (i, k) = q1 (i, k)
+ uo (i, k) = u1 (i, k)
+ vo (i, k) = v1 (i, k)
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! feedback: simply the changes from the cloud with unit mass flux
+ ! multiplied by the mass flux necessary to keep the
+ ! equilibrium with the larger - scale.
+ ! for the "feedback" control, calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control.
+ ! calculate the temperature tendency from the moist static energy and specific humidity tendencies.
+ ! update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux - normalized tendencies by the cloud base mass flux.
+ ! accumulate column - integrated tendencies.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ delhbar (i) = 0.
+ delqbar (i) = 0.
+ deltbar (i) = 0.
+ delubar (i) = 0.
+ delvbar (i) = 0.
+ qcond (i) = 0.
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k <= ktcon (i)) then
+ dellat = (dellah (i, k) - hlv * dellaq (i, k)) / cp_air
+ t1 (i, k) = t1 (i, k) + dellat * xmb (i) * dt2
+ q1 (i, k) = q1 (i, k) + dellaq (i, k) * xmb (i) * dt2
+ ! tem = 1. / rcs (i)
+ ! u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2 * tem
+ ! v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2 * tem
+ u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2
+ v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2
+ dp = delp (i, k)
+ delhbar (i) = delhbar (i) + dellah (i, k) * xmb (i) * dp / g
+ delqbar (i) = delqbar (i) + dellaq (i, k) * xmb (i) * dp / g
+ deltbar (i) = deltbar (i) + dellat * xmb (i) * dp / g
+ delubar (i) = delubar (i) + dellau (i, k) * xmb (i) * dp / g
+ delvbar (i) = delvbar (i) + dellav (i, k) * xmb (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity using the updated temperature.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k <= ktcon (i)) then
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! add up column - integrated convective precipitation by multiplying the normalized value by the cloud base mass flux.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ rntot (i) = 0.
+ delqev (i) = 0.
+ delq2 (i) = 0.
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ if (k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k >= jmin (i)) adw = 0.
+ rain = aup * pwo (i, k) + adw * edto (i) * pwdo (i, k)
+ rntot (i) = rntot (i) + rain * xmb (i) * .001 * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine the evaporation of the convective precipitation and update the integrated convective precipitation.
+ ! update state temperature and moisture to account for evaporation of convective precipitation.
+ ! update column - integrated tendencies to account for evaporation of convective precipitation.
+ ! -----------------------------------------------------------------------
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (k <= kmax (i)) then
+ deltv (i) = 0.
+ delq (i) = 0.
+ qevap (i) = 0.
+ if (cnvflg (i) .and. k < ktcon (i)) then
+ aup = 1.
+ if (k <= kb (i)) aup = 0.
+ adw = 1.
+ if (k >= jmin (i)) adw = 0.
+ rain = aup * pwo (i, k) + adw * edto (i) * pwdo (i, k)
+ rn (i) = rn (i) + rain * xmb (i) * .001 * dt2
+ qr (i, k) = qr (i, k) + rain * xmb (i) * .001 * dt2
+ endif
+ if (flg (i) .and. k < ktcon (i)) then
+ evef = edt (i) * evfact_deep
+ if (islimsk (i) == 1) evef = edt (i) * evfactl_deep
+ ! if (islimsk (i) == 1) evef = .07
+ ! if (islimsk (i) == 1) evef = 0.
+ qcond (i) = evef * (q1 (i, k) - qeso (i, k)) &
+ / (1. + el2orc * qeso (i, k) / t1 (i, k) ** 2)
+ dp = delp (i, k)
+ if (rn (i) > 0. .and. qcond (i) < 0.) then
+ qevap (i) = - qcond (i) * (1. - exp (- .32 * sqrt (dt2 * rn (i))))
+ qevap (i) = min (qevap (i), rn (i) * 1000. * g / dp)
+ delq2 (i) = delqev (i) + .001 * qevap (i) * dp / g
+ endif
+ if (rn (i) > 0. .and. qcond (i) < 0. .and. delq2 (i) > rntot (i)) then
+ qevap (i) = 1000. * g * (rntot (i) - delqev (i)) / dp
+ flg (i) = .false.
+ endif
+ if (rn (i) > 0. .and. qevap (i) > 0.) then
+ q1 (i, k) = q1 (i, k) + qevap (i)
+ t1 (i, k) = t1 (i, k) - elocp * qevap (i)
+ rn (i) = rn (i) - .001 * qevap (i) * dp / g
+ qr (i, k) = qr (i, k) - .001 * qevap (i) * dp / g
+ deltv (i) = - elocp * qevap (i) / dt2
+ delq (i) = + qevap (i) / dt2
+ delqev (i) = delqev (i) + .001 * dp * qevap (i) / g
+ endif
+ delqbar (i) = delqbar (i) + delq (i) * dp / g
+ deltbar (i) = deltbar (i) + deltv (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! if (me == 31 .and. cnvflg (i)) then
+ ! if (cnvflg (i)) then
+ ! print *, ' deep delhbar, delqbar, deltbar = ', &
+ ! delhbar (i), hlv * delqbar (i), cp_air * deltbar (i)
+ ! print *, ' deep delubar, delvbar = ', delubar (i), delvbar (i)
+ ! print *, ' precip = ', hlv * rn (i) * 1000. / dt2
+ ! print *, 'pdif = ', pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ ! endif
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! precipitation rate converted to actual precip
+ ! in unit of m instead of kg
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ ! -----------------------------------------------------------------------
+ ! in the event of upper level rain evaporation and lower level downdraft
+ ! moistening, rn can become negative, in this case, we back out of the
+ ! heating and the moistening
+ ! -----------------------------------------------------------------------
+
+ if (rn (i) < 0. .and. .not.flg (i)) rn (i) = 0.
+ if (rn (i) <= 0.) then
+ rn (i) = 0.
+ else
+ ktop (i) = ktcon (i)
+ kbot (i) = kbcon (i)
+ kcnv (i) = 1
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud water
+ ! calculate convective cloud water.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvw (i, k) = cnvwt (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud cover
+ ! calculate convective cloud cover, which is used when pdf - based cloud fraction is used (i.e., pdfcld = .true.) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvc) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvc (i, k) = 0.04 * log (1. + 675. * eta (i, k) * xmb (i))
+ cnvc (i, k) = min (cnvc (i, k), 0.6)
+ cnvc (i, k) = max (cnvc (i, k), 0.0)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! separate detrained cloud water into liquid and ice species as a function of temperature only.
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) > 0.) then
+ ! if (k > kb (i) .and. k <= ktcon (i)) then
+ if (k >= kbcon (i) .and. k <= ktcon (i)) then
+ tem = dellal (i, k) * xmb (i) * dt2
+ ql (i, k) = ql (i, k) + tem
+ endif
+ endif
+ enddo
+ enddo
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! if convective precipitation is zero or negative, reset the updated state variables back to their original values (negating convective changes) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. rn (i) <= 0.) then
+ if (k <= kmax (i)) then
+ t1 (i, k) = to (i, k)
+ q1 (i, k) = qo (i, k)
+ u1 (i, k) = uo (i, k)
+ v1 (i, k) = vo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! calculate and retain the updraft and downdraft mass fluxes for dust transport by cumulus convection.
+ ! calculate the updraft convective mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= kb (i) .and. k < ktop (i)) then
+ ud_mf (i, k) = eta (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! save the updraft convective mass flux at cloud top.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (present (dt_mf) .and. present (ud_mf) .and. cnvflg (i) .and. rn (i) > 0.) then
+ k = ktop (i) - 1
+ dt_mf (i, k) = ud_mf (i, k)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the downdraft convective mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (dd_mf) .and. cnvflg (i) .and. rn (i) > 0.) then
+ if (k >= 1 .and. k <= jmin (i)) then
+ dd_mf (i, k) = edto (i) * etad (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+end subroutine sa_sas_deep
+
+! =======================================================================
+! shallow convection part
+! =======================================================================
+
+subroutine sa_sas_shal (im, km, delt, delp, prslp, psp, phil, ql, &
+ q1, t1, u1, v1, qr, rn, kbot, ktop, kcnv, islimsk, gsize, &
+ dot, ncloud, hpbl, ud_mf, dt_mf, cnvw, cnvc)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, ncloud, islimsk (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: psp (im), delp (im, km), &
+ prslp (im, km), gsize (im), hpbl (im), dot (im, km), phil (im, km)
+
+ integer, intent (inout) :: kbot (im), ktop (im), kcnv (im)
+
+ real, intent (inout) :: ql (im, km), q1 (im, km), t1 (im, km), &
+ u1 (im, km), v1 (im, km)
+
+ real, intent (out) :: rn (im), qr (im, km)
+ real, intent (out), optional :: cnvw (im, km), cnvc (im, km), &
+ ! hchuang code change mass flux output
+ ud_mf (im, km), dt_mf (im, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, j, indx, k, kk, km1, n
+ integer :: kpbl (im)
+
+ real :: dellat, delta, &
+ c0l, d0, &
+ desdt, dp, &
+ dq, dqsdp, dqsdt, dt, &
+ dt2, dtmax, dtmin, dxcrt, &
+ dv1h, dv2h, dv3h, &
+ dv1q, dv2q, dv3q, &
+ dz, dz1, e1, &
+ el2orc, elocp, aafac, cm, &
+ es, etah, h1, &
+ evef, fact1, &
+ fact2, factor, dthk, &
+ g, gamma, pprime, betaw, &
+ qlk, qrch, qs, &
+ rfact, shear, tfac, &
+ val, val1, val2, &
+ w1, w1l, w1s, w2, &
+ w2l, w2s, w3, w3l, &
+ w3s, w4, w4l, w4s, &
+ rho, tem, tem1, tem2, &
+ ptem, ptem1
+
+ integer :: kb (im), kbcon (im), kbcon1 (im), &
+ ktcon (im), ktcon1 (im), ktconn (im), &
+ kbm (im), kmax (im)
+
+ real :: aa1 (im), cina (im), &
+ umean (im), tauadv (im), &
+ delhbar (im), delq (im), delq2 (im), &
+ delqbar (im), delqev (im), deltbar (im), &
+ deltv (im), dtconv (im), edt (im), &
+ pdot (im), po (im, km), &
+ qcond (im), qevap (im), hmax (im), &
+ rntot (im), vshear (im), &
+ xlamud (im), xmb (im), xmbmax (im), &
+ delubar (im), delvbar (im)
+
+ real :: c0 (im)
+
+ real :: crtlamd
+
+ real :: cinpcr, cinpcrmx, cinpcrmn, &
+ cinacr, cinacrmx, cinacrmn
+
+ ! parameters for updraft velocity calculation
+ real :: bet1, cd1, f1, gam1, &
+ bb1, bb2, wucb
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (elocp = hlv / cp_air, &
+ el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (d0 = .01)
+
+ ! asolfac_shal: aerosol - aware parameter based on lim & hong (2012)
+ ! asolfac_shal = cx / c0s_shal (= .002)
+ ! cx = min ([ - 0.7 ln (nccn) + 24] * 1.e-4, c0s_shal)
+ ! nccn: ccn number concentration in cm^ (- 3)
+ ! until a realistic nccn is provided, typical nccns are assumed
+ ! as nccn = 100 for sea and nccn = 7000 for land
+
+ parameter (cm = 1.0, delta = zvir)
+ parameter (fact1 = (cp_vap - c_liq) / rvgas, fact2 = hlv / rvgas - fact1 * tice)
+ parameter (dthk = 25.)
+ parameter (cinpcrmx = 180., cinpcrmn = 120.)
+ parameter (cinacrmx = - 120., cinacrmn = - 80.)
+ parameter (crtlamd = 3.e-4)
+ parameter (dtmax = 10800., dtmin = 600.)
+ parameter (bet1 = 1.875, cd1 = .506, f1 = 2.0, gam1 = .5)
+ parameter (betaw = .03, dxcrt = 15.e3)
+ parameter (h1 = 0.33333333)
+
+ ! local variables and arrays
+ real :: pfld (im, km), to (im, km), qo (im, km), &
+ uo (im, km), vo (im, km), qeso (im, km)
+
+ ! for updraft velocity calculation
+ real :: wu2 (im, km), buo (im, km), drag (im, km)
+ real :: wc (im), scaldfunc (im), sigmagfm (im)
+
+ ! cloud water
+ ! real :: qlko_ktcon (im), dellal (im, km), tvo (im, km),
+ real :: qlko_ktcon (im), dellal (im, km), &
+ dbyo (im, km), zo (im, km), xlamue (im, km), &
+ heo (im, km), heso (im, km), &
+ dellah (im, km), dellaq (im, km), &
+ dellau (im, km), dellav (im, km), hcko (im, km), &
+ ucko (im, km), vcko (im, km), qcko (im, km), &
+ qrcko (im, km), eta (im, km), &
+ zi (im, km), pwo (im, km), c0t (im, km), &
+ sumx (im), tx1 (im), cnvwt (im, km)
+
+ logical :: totflg, cnvflg (im), flg (im)
+
+ real :: tf, tcr, tcrf
+ parameter (tf = 233.16, tcr = 263.16, tcrf = 1.0 / (tcr - tf))
+
+ ! -----------------------------------------------------------------------
+ ! convert input pa terms to cb terms -- moorthi
+ ! compute preliminary quantities needed for the static and feedback control portions of the algorithm.
+ ! convert input pressure terms to centibar units.
+ ! -----------------------------------------------------------------------
+
+ km1 = km - 1
+
+ ! -----------------------------------------------------------------------
+ ! initialize arrays
+ ! initialize column - integrated and other single - value - per - column variable arrays.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ cnvflg (i) = .true.
+ if (kcnv (i) == 1) cnvflg (i) = .false.
+ if (cnvflg (i)) then
+ kbot (i) = km + 1
+ ktop (i) = 0
+ endif
+ rn (i) = 0.
+ kbcon (i) = km
+ ktcon (i) = 1
+ ktconn (i) = 1
+ kb (i) = km
+ pdot (i) = 0.
+ qlko_ktcon (i) = 0.
+ edt (i) = 0.
+ aa1 (i) = 0.
+ cina (i) = 0.
+ vshear (i) = 0.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! return to the calling routine if deep convection is present or the surface buoyancy flux is negative.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine aerosol - aware rain conversion parameter over land
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (islimsk (i) == 1) then
+ c0 (i) = c0s_shal * asolfac_shal
+ else
+ c0 (i) = c0s_shal
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from han et al.'s (2017) equation 8.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (t1 (i, k) > 273.16) then
+ c0t (i, k) = c0 (i)
+ else
+ tem = d0 * (t1 (i, k) - 273.16)
+ tem1 = exp (tem)
+ c0t (i, k) = c0 (i) * tem1
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! initialize convective cloud water and cloud cover to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw)) cnvw (i, k) = 0.
+ if (present (cnvc)) cnvc (i, k) = 0.
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ qr (i, k) = 0.
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! initialize updraft mass fluxes to zero.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf)) ud_mf (i, k) = 0.
+ if (present (dt_mf)) dt_mf (i, k) = 0.
+ enddo
+ enddo
+
+ dt2 = delt
+
+ ! -----------------------------------------------------------------------
+ ! model tunable parameters are all here
+ ! -----------------------------------------------------------------------
+
+ ! clam_shal = .3
+ aafac = .1
+ ! evef = 0.07
+ ! evfact_shal = 0.3
+ ! evfactl_shal = 0.3
+
+ ! pgcon_shal = 0.7 ! gregory et al. (1997, qjrms)
+ ! pgcon_shal = 0.55 ! zhang & wu (2003, jas)
+
+ w1l = - 8.e-3
+ w2l = - 4.e-2
+ w3l = - 5.e-3
+ w4l = - 5.e-4
+ w1s = - 2.e-4
+ w2s = - 2.e-3
+ w3s = - 1.e-3
+ w4s = - 2.e-5
+
+ ! -----------------------------------------------------------------------
+ ! define top layer for search of the downdraft originating layer
+ ! and the maximum thetae for updraft
+ ! determine maximum indices for the parcel starting point (kbm) and cloud top (kmax) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ kbm (i) = km
+ kmax (i) = km
+ tx1 (i) = 1.0 / psp (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (prslp (i, k) * tx1 (i) > 0.70) kbm (i) = k + 1
+ if (prslp (i, k) * tx1 (i) > 0.60) kmax (i) = k + 1
+ enddo
+ enddo
+
+ do i = 1, im
+ kbm (i) = min (kbm (i), kmax (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! hydrostatic height assume zero terr and compute
+ ! updraft entrainment rate as an inverse function of height
+ ! calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ zo (i, k) = phil (i, k) / g
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate interface height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ zi (i, k) = 0.5 * (zo (i, k) + zo (i, k + 1))
+ xlamue (i, k) = clam_shal / zi (i, k)
+ enddo
+ enddo
+
+ do i = 1, im
+ xlamue (i, km) = xlamue (i, km1)
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! pbl height
+ ! find the index for the pbl top using the pbl height; enforce that it is lower than the maximum parcel starting level.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ kpbl (i) = 1
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. zo (i, k) <= hpbl (i)) then
+ kpbl (i) = k
+ else
+ flg (i) = .false.
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ kpbl (i) = min (kpbl (i), kbm (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convert surface pressure to mb from cb
+ ! convert prsl from centibar to millibar, set normalized mass flux to 1, cloud properties to 0, and save model state variables (after advection / turbulence) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ pfld (i, k) = prslp (i, k) * 0.01
+ eta (i, k) = 1.
+ hcko (i, k) = 0.
+ qcko (i, k) = 0.
+ qrcko (i, k) = 0.
+ ucko (i, k) = 0.
+ vcko (i, k) = 0.
+ dbyo (i, k) = 0.
+ pwo (i, k) = 0.
+ dellal (i, k) = 0.
+ to (i, k) = t1 (i, k)
+ qo (i, k) = q1 (i, k)
+ uo (i, k) = u1 (i, k)
+ vo (i, k) = v1 (i, k)
+ ! uo (i, k) = u1 (i, k) * rcs (i)
+ ! vo (i, k) = v1 (i, k) * rcs (i)
+ wu2 (i, k) = 0.
+ buo (i, k) = 0.
+ drag (i, k) = 0.
+ cnvwt (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! column variables
+ ! p is pressure of the layer (mb)
+ ! t is temperature at t - dt (k) ..tn
+ ! q is mixing ratio at t - dt (kg / kg) ..qn
+ ! to is temperature at t + dt (k) ... this is after advection and turbulan
+ ! qo is mixing ratio at t + dt (kg / kg) ..q1
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate saturation specific humidity and enforce minimum moisture values.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ ! tvo (i, k) = to (i, k) + delta * to (i, k) * qo (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute moist static energy
+ ! calculate moist static energy (heo) and saturation moist static energy (heso) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ ! tem = g * zo (i, k) + cp_air * to (i, k)
+ tem = phil (i, k) + cp_air * to (i, k)
+ heo (i, k) = tem + hlv * qo (i, k)
+ heso (i, k) = tem + hlv * qeso (i, k)
+ ! heo (i, k) = min (heo (i, k), heso (i, k))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine level with largest moist static energy within pbl
+ ! this is the level where updraft starts
+ ! perform calculations related to the updraft of the entraining / detraining cloud model ("static control") .
+ ! search in the pbl for the level of maximum moist static energy to start the ascending parcel.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ hmax (i) = heo (i, 1)
+ kb (i) = 1
+ endif
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ if (heo (i, k) > hmax (i)) then
+ kb (i) = k
+ hmax (i) = heo (i, k)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the temperature, water vapor mixing ratio, and pressure at interface levels.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ dz = .5 * (zo (i, k + 1) - zo (i, k))
+ dp = .5 * (pfld (i, k + 1) - pfld (i, k))
+ es = 0.01 * mqs (to (i, k + 1)) ! mqs is in pa
+ pprime = pfld (i, k + 1) + epsm1 * es
+ qs = eps * es / pprime
+ dqsdp = - qs / pprime
+ desdt = es * (fact1 / to (i, k + 1) + fact2 / (to (i, k + 1) ** 2))
+ dqsdt = qs * pfld (i, k + 1) * desdt / (es * pprime)
+ gamma = el2orc * qeso (i, k + 1) / (to (i, k + 1) ** 2)
+ dt = (g * dz + hlv * dqsdp * dp) / (cp_air * (1. + gamma))
+ dq = dqsdt * dt + dqsdp * dp
+ to (i, k) = to (i, k + 1) + dt
+ qo (i, k) = qo (i, k + 1) + dq
+ po (i, k) = .5 * (pfld (i, k) + pfld (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. enforce minimum specific humidity.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i) - 1) then
+ qeso (i, k) = 0.01 * mqs (to (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (po (i, k) + epsm1 * qeso (i, k))
+ val1 = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val1)
+ val2 = 1.e-10
+ qo (i, k) = max (qo (i, k), val2)
+ ! qo (i, k) = min (qo (i, k), qeso (i, k))
+ heo (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qo (i, k)
+ heso (i, k) = .5 * g * (zo (i, k) + zo (i, k + 1)) + &
+ cp_air * to (i, k) + hlv * qeso (i, k)
+ uo (i, k) = .5 * (uo (i, k) + uo (i, k + 1))
+ vo (i, k) = .5 * (vo (i, k) + vo (i, k + 1))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! look for the level of free convection as cloud base
+ ! search below the index "kbm" for the level of free convection (lfc) where the condition \f$h_b > h^ * \f$ is first met, where \f$h_b, h^ * \f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. set "kbcon" to the index of the lfc.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ if (flg (i)) kbcon (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kbm (i)) then
+ if (k > kb (i) .and. heo (i, kb (i)) > heso (i, k)) then
+ kbcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kbcon (i) == kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if no lfc, return to the calling routine without modifying state variables.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine the vertical pressure velocity at the lfc. after han and pan (2011), determine the maximum pressure thickness between a parcel's starting level and the lfc. if a parcel doesn't reach the lfc within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! pdot (i) = 10. * dot (i, kbcon (i))
+ pdot (i) = 0.01 * dot (i, kbcon (i)) ! now dot is in pa / s
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if pressure depth between parcel source level
+ ! and cloud base is larger than a critical value, cinpcr
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ ptem = 1. - tem
+ ptem1 = .5 * (cinpcrmx - cinpcrmn)
+ cinpcr = cinpcrmx - ptem * ptem1
+ tem1 = pfld (i, kb (i)) - pfld (i, kbcon (i))
+ if (tem1 > cinpcr) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! specify the detrainment rate for the updrafts
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamud (i) = xlamue (i, kbcon (i))
+ ! xlamud (i) = crtlamd
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! determine updraft mass flux for the subcloud layers
+ ! calculate the normalized mass flux for subcloud and in - cloud layers according to pan and wu (1995) equation 1:
+ ! \f[
+ ! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d
+ ! \f]
+ ! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate. the normalized mass flux increases upward below the cloud base and decreases upward above.
+ ! -----------------------------------------------------------------------
+
+ do k = km1, 1, - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < kbcon (i) .and. k >= kb (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k + 1)) - xlamud (i)
+ eta (i, k) = eta (i, k + 1) / (1. + ptem * dz)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute mass flux above cloud base
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k > kbcon (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ ptem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) - xlamud (i)
+ eta (i, k) = eta (i, k - 1) * (1 + ptem * dz)
+ if (eta (i, k) <= 0.) then
+ kmax (i) = k
+ ktconn (i) = k
+ kbm (i) = min (kbm (i), kmax (i))
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft cloud property
+ ! set cloud properties equal to the state variables at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = kb (i)
+ hcko (i, indx) = heo (i, indx)
+ ucko (i, indx) = uo (i, indx)
+ vcko (i, indx) = vo (i, indx)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cm is an enhancement factor in entrainment rates for momentum
+ ! calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. discretization follows appendix b of grell (1993). following han and pan (2006), the convective momentum transport is reduced by the convection - induced pressure gradient force by the constant "pgcon_shal", currently set to 0.55 after zhang and wu (2003).
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kmax (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.5 * xlamud (i) * dz
+ factor = 1. + tem - tem1
+ hcko (i, k) = ((1. - tem1) * hcko (i, k - 1) + tem * 0.5 * &
+ (heo (i, k) + heo (i, k - 1))) / factor
+ dbyo (i, k) = hcko (i, k) - heso (i, k)
+
+ tem = 0.5 * cm * tem
+ factor = 1. + tem
+ ptem = tem + pgcon_shal
+ ptem1 = tem - pgcon_shal
+ ucko (i, k) = ((1. - tem) * ucko (i, k - 1) + ptem * uo (i, k) &
+ + ptem1 * uo (i, k - 1)) / factor
+ vcko (i, k) = ((1. - tem) * vcko (i, k - 1) + ptem * vo (i, k) &
+ + ptem1 * vo (i, k - 1)) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! taking account into convection inhibition due to existence of
+ ! dry layers below cloud base
+ ! with entrainment, recalculate the lfc as the first level where buoyancy is positive. the difference in pressure levels between lfcs calculated with / without entrainment must be less than a threshold (currently 25 hpa) . otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. this is the subcloud dryness trigger modification discussed in han and pan (2011).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ kbcon1 (i) = kmax (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kbm (i)) then
+ if (k >= kbcon (i) .and. dbyo (i, k) > 0.) then
+ kbcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kbcon1 (i) == kmax (i)) cnvflg (i) = .false.
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = pfld (i, kbcon (i)) - pfld (i, kbcon1 (i))
+ if (tem > dthk) then
+ cnvflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! calculate convective inhibition
+ ! calculate additional trigger condition of the convective inhibition (cin) according to han et al.'s (2017) equation 13.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < kbcon1 (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ cina (i) = cina (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ dz1 * g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! turn off convection if the cin is less than a critical value (cinacr) which is inversely proportional to the large - scale vertical velocity.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+
+ if (islimsk (i) == 1) then
+ w1 = w1l
+ w2 = w2l
+ w3 = w3l
+ w4 = w4l
+ else
+ w1 = w1s
+ w2 = w2s
+ w3 = w3s
+ w4 = w4s
+ endif
+ if (pdot (i) <= w4) then
+ tem = (pdot (i) - w4) / (w3 - w4)
+ elseif (pdot (i) >= - w4) then
+ tem = - (pdot (i) + w4) / (w4 - w3)
+ else
+ tem = 0.
+ endif
+
+ val1 = - 1.
+ tem = max (tem, val1)
+ val2 = 1.
+ tem = min (tem, val2)
+ tem = 1. - tem
+ tem1 = .5 * (cinacrmx - cinacrmn)
+ cinacr = cinacrmx - tem * tem1
+
+ ! cinacr = cinacrmx
+ if (cina (i) < cinacr) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! determine first guess cloud top as the level of zero buoyancy
+ ! limited to the level of p / ps = 0.7
+ ! calculate the cloud top as the first level where parcel buoyancy becomes negative; the maximum possible value is at \f$p = 0.7p_{sfc}\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ if (flg (i)) ktcon (i) = kbm (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i) .and. k < kbm (i)) then
+ if (k > kbcon1 (i) .and. dbyo (i, k) < 0.) then
+ ktcon (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify upper limit of mass flux at cloud base
+ ! calculate the maximum value of the cloud base mass flux using the cfl - criterion - based formula of han and pan (2011), equation 7.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! xmbmax (i) = .1
+ !
+ k = kbcon (i)
+ dp = delp (i, k)
+ xmbmax (i) = dp / (g * dt2)
+ !
+ ! tem = dp / (g * dt2)
+ ! xmbmax (i) = min (tem, xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property and precipitation
+ ! set cloud moisture property equal to the enviromental moisture at updraft starting level (kb) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = 0.
+ qcko (i, kb (i)) = qo (i, kb (i))
+ qrcko (i, kb (i)) = qo (i, kb (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the moisture content of the entraining / detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation a.14 in grell (1993). their difference is the amount of convective cloud water (qlk = rain + condensate) . determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo) . calculate and save the negative cloud work function (aa1) due to water loading. above the level of minimum moist static energy, some of the cloud water is detrained into the grid - scale cloud water from every cloud layer with a rate of 0.0005 \f$m^{ - 1}\f$ (dellal) .
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.5 * xlamud (i) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! rhbar (i) = rhbar (i) + qo (i, k) / qeso (i, k)
+
+ ! -----------------------------------------------------------------------
+ ! below lfc check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i) .and. dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0) then
+ ptem = c0t (i, k) + c1_shal
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_shal * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ buo (i, k) = buo (i, k) - g * qlk
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy and drag for updraft velocity
+ ! -----------------------------------------------------------------------
+
+ if (k >= kbcon (i)) then
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ buo (i, k) = buo (i, k) + (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ val = 0.
+ buo (i, k) = buo (i, k) + g * delta * &
+ max (val, (qeso (i, k) - qo (i, k)))
+ drag (i, k) = max (xlamue (i, k), xlamud (i))
+ endif
+
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+ ! do k = 2, km1
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! if (k >= kbcon (i) .and. k < ktcon (i)) then
+ ! dz1 = zo (i, k + 1) - zo (i, k)
+ ! gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ ! rfact = 1. + delta * cp_air * gamma &
+ ! * to (i, k) / hlv
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ ! dz1 * (g / (cp_air * to (i, k))) &
+ ! * dbyo (i, k) / (1. + gamma) &
+ ! * rfact
+ ! val = 0.
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+ ! do i = 1, im
+ ! if (cnvflg (i) .and. aa1 (i) <= 0.) cnvflg (i) = .false.
+ ! enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate cloud work function
+ ! -----------------------------------------------------------------------
+
+
+ ! -----------------------------------------------------------------------
+ ! calculate the cloud work function according to pan and wu (1995) equation 4:
+ ! \f[
+ ! a_u = \int_{z_0}^{z_t}\frac{g}{c_pt (z) }\frac{\eta}{1 + \gamma}[h (z) - h^ * (z) ]dz
+ ! \f]
+ ! (discretized according to grell (1993) equation b.10 using b.2 and b.3 of arakawa and schubert (1974) and assuming \f$\eta = 1\f$) where \f$a_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{l}{c_p}\left (\frac{\partial \overline{q_s}}{\partial t}\right) _p\f$ and other quantities are previously defined.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ aa1 (i) = aa1 (i) + buo (i, k) * dz1
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i) .and. aa1 (i) <= 0.) cnvflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine.
+ ! -----------------------------------------------------------------------
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! estimate the onvective overshooting as the level
+ ! where the [aafac * cloud work function] becomes zero,
+ ! which is the final cloud top
+ ! limited to the level of p / ps = 0.7
+ ! continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to han and pan (2011). convective overshooting stops when \f$ ca_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force. overshooting is also limited to the level where \f$p = 0.7p_{sfc}\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ aa1 (i) = aafac * aa1 (i)
+ endif
+ enddo
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ ktcon1 (i) = kbm (i)
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (flg (i)) then
+ if (k >= ktcon (i) .and. k < kbm (i)) then
+ dz1 = zo (i, k + 1) - zo (i, k)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ rfact = 1. + delta * cp_air * gamma &
+ * to (i, k) / hlv
+ aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * (g / (cp_air * to (i, k))) &
+ dz1 * (g / (cp_air * to (i, k))) &
+ * dbyo (i, k) / (1. + gamma) &
+ * rfact
+ ! val = 0.
+ ! aa1 (i) = aa1 (i) + &
+ ! dz1 * eta (i, k) * g * delta * &
+ ! dz1 * g * delta * &
+ ! max (val, (qeso (i, k) - qo (i, k)))
+ if (aa1 (i) < 0.) then
+ ktcon1 (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud moisture property, detraining cloud water
+ ! and precipitation in overshooting layers
+ ! for the overshooting convection, calculate the moisture content of the entraining / detraining parcel as before. partition convective cloud water and precipitation and detrain convective cloud water in the overshooting layers.
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= ktcon (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = 0.5 * xlamud (i) * dz
+ factor = 1. + tem - tem1
+ qcko (i, k) = ((1. - tem1) * qcko (i, k - 1) + tem * 0.5 * &
+ (qo (i, k) + qo (i, k - 1))) / factor
+ qrcko (i, k) = qcko (i, k)
+
+ dq = eta (i, k) * (qcko (i, k) - qrch)
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ etah = .5 * (eta (i, k) + eta (i, k - 1))
+ dp = delp (i, k)
+ if (ncloud > 0) then
+ ptem = c0t (i, k) + c1_shal
+ qlk = dq / (eta (i, k) + etah * ptem * dz)
+ dellal (i, k) = etah * c1_shal * dz * qlk * g / dp
+ else
+ qlk = dq / (eta (i, k) + etah * c0t (i, k) * dz)
+ endif
+ qcko (i, k) = qlk + qrch
+ pwo (i, k) = etah * c0t (i, k) * dz * qlk
+ cnvwt (i, k) = etah * qlk * g / dp
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity square (wu2)
+ ! calculate updraft velocity square (wu2) according to han et al.'s (2017) equation 7.
+ ! -----------------------------------------------------------------------
+
+ ! bb1 = 2. * (1. + bet1 * cd1)
+ ! bb2 = 2. / (f1 * (1. + gam1))
+
+ ! bb1 = 3.9
+ ! bb2 = 0.67
+
+ ! bb1 = 2.0
+ ! bb2 = 4.0
+
+ bb1 = 4.0
+ bb2 = 0.8
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kbcon1 (i)
+ tem = po (i, k) / (rdgas * to (i, k))
+ wucb = - 0.01 * dot (i, k) / (tem * g)
+ if (wucb > 0.) then
+ wu2 (i, k) = wucb * wucb
+ else
+ wu2 (i, k) = 0.
+ endif
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.25 * bb1 * (drag (i, k) + drag (i, k - 1)) * dz
+ tem1 = 0.5 * bb2 * (buo (i, k) + buo (i, k - 1)) * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ wu2 (i, k) = max (wu2 (i, k), 0.)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity averaged over the whole cumulus
+ ! calculate the mean updraft velocity within the cloud (wc) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ wc (i) = 0.
+ sumx (i) = 0.
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kbcon1 (i) .and. k < ktcon (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = 0.5 * (sqrt (wu2 (i, k)) + sqrt (wu2 (i, k - 1)))
+ wc (i) = wc (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sumx (i) == 0.) then
+ cnvflg (i) = .false.
+ else
+ wc (i) = wc (i) / sumx (i)
+ endif
+ val = 1.e-4
+ if (wc (i) < val) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! exchange ktcon with ktcon1
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = ktcon (i)
+ ktcon (i) = ktcon1 (i)
+ ktcon1 (i) = kk
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! this section is ready for cloud water
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ ! -----------------------------------------------------------------------
+ ! compute liquid and vapor separation at cloud top
+ ! separate the total updraft cloud water at cloud top into vapor and condensate.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = ktcon (i) - 1
+ gamma = el2orc * qeso (i, k) / (to (i, k) ** 2)
+ qrch = qeso (i, k) &
+ + gamma * dbyo (i, k) / (hlv * (1. + gamma))
+ dq = qcko (i, k) - qrch
+
+ ! -----------------------------------------------------------------------
+ ! check if there is excess moisture to release latent heat
+ ! -----------------------------------------------------------------------
+
+ if (dq > 0.) then
+ qlko_ktcon (i) = dq
+ qcko (i, k) = qrch
+ endif
+ endif
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute precipitation efficiency in terms of windshear
+ ! calculate the wind shear and precipitation efficiency according to equation 58 in fritsch and chappell (1980):
+ ! \f[
+ ! e = 1.591 - 0.639\frac{\delta v}{\delta z} + 0.0953\left (\frac{\delta v}{\delta z}\right) ^2 - 0.00496\left (\frac{\delta v}{\delta z}\right) ^3
+ ! \f]
+ ! where \f$\delta v\f$ is the integrated horizontal shear over the cloud depth, \f$\delta z\f$, (the ratio is converted to units of \f$10^{ - 3} s^{ - 1}\f$) . the variable "edt" is \f$1 - e\f$ and is constrained to the range \f$[0, 0.9]\f$.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ shear = sqrt ((uo (i, k) - uo (i, k - 1)) ** 2 &
+ + (vo (i, k) - vo (i, k - 1)) ** 2)
+ vshear (i) = vshear (i) + shear
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ vshear (i) = 1.e3 * vshear (i) / (zi (i, ktcon (i)) - zi (i, kb (i)))
+ e1 = 1.591 - .639 * vshear (i) &
+ + .0953 * (vshear (i) ** 2) - .00496 * (vshear (i) ** 3)
+ edt (i) = 1. - e1
+ val = .9
+ edt (i) = min (edt (i), val)
+ val = .0
+ edt (i) = max (edt (i), val)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! what would the change be, that a cloud with unit mass
+ ! will do to the environment?
+ ! -----------------------------------------------------------------------
+
+ ! -----------------------------------------------------------------------
+ ! calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux.
+ ! calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux for all layers below cloud top from equations b.14 and b.15 from grell (1993), and for the cloud top from b.16 and b.17.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ dellah (i, k) = 0.
+ dellaq (i, k) = 0.
+ dellau (i, k) = 0.
+ dellav (i, k) = 0.
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! changed due to subsidence and entrainment
+ ! -----------------------------------------------------------------------
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k < ktcon (i)) then
+ dp = delp (i, k)
+ dz = zi (i, k) - zi (i, k - 1)
+
+ dv1h = heo (i, k)
+ dv2h = .5 * (heo (i, k) + heo (i, k - 1))
+ dv3h = heo (i, k - 1)
+ dv1q = qo (i, k)
+ dv2q = .5 * (qo (i, k) + qo (i, k - 1))
+ dv3q = qo (i, k - 1)
+
+ tem = 0.5 * (xlamue (i, k) + xlamue (i, k - 1))
+ tem1 = xlamud (i)
+
+ dellah (i, k) = dellah (i, k) + &
+ (eta (i, k) * dv1h - eta (i, k - 1) * dv3h &
+ - tem * eta (i, k - 1) * dv2h * dz &
+ + tem1 * eta (i, k - 1) * .5 * (hcko (i, k) + hcko (i, k - 1)) * dz &
+ ) * g / dp
+
+ dellaq (i, k) = dellaq (i, k) + &
+ (eta (i, k) * dv1q - eta (i, k - 1) * dv3q &
+ - tem * eta (i, k - 1) * dv2q * dz &
+ + tem1 * eta (i, k - 1) * .5 * (qrcko (i, k) + qcko (i, k - 1)) * dz &
+ ) * g / dp
+
+ tem1 = eta (i, k) * (uo (i, k) - ucko (i, k))
+ tem2 = eta (i, k - 1) * (uo (i, k - 1) - ucko (i, k - 1))
+ dellau (i, k) = dellau (i, k) + (tem1 - tem2) * g / dp
+
+ tem1 = eta (i, k) * (vo (i, k) - vcko (i, k))
+ tem2 = eta (i, k - 1) * (vo (i, k - 1) - vcko (i, k - 1))
+ dellav (i, k) = dellav (i, k) + (tem1 - tem2) * g / dp
+
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ indx = ktcon (i)
+ dp = delp (i, indx)
+ dv1h = heo (i, indx - 1)
+ dellah (i, indx) = eta (i, indx - 1) * &
+ (hcko (i, indx - 1) - dv1h) * g / dp
+ dv1q = qo (i, indx - 1)
+ dellaq (i, indx) = eta (i, indx - 1) * &
+ (qcko (i, indx - 1) - dv1q) * g / dp
+ dellau (i, indx) = eta (i, indx - 1) * &
+ (ucko (i, indx - 1) - uo (i, indx - 1)) * g / dp
+ dellav (i, indx) = eta (i, indx - 1) * &
+ (vcko (i, indx - 1) - vo (i, indx - 1)) * g / dp
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! -----------------------------------------------------------------------
+
+ dellal (i, indx) = eta (i, indx - 1) * &
+ qlko_ktcon (i) * g / dp
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute convective turn - over time
+ ! following bechtold et al. (2008), calculate the convective turnover time using the mean updraft velocity (wc) and the cloud depth. it is also proportional to the grid size (gsize) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = zi (i, ktcon1 (i)) - zi (i, kbcon1 (i))
+ dtconv (i) = tem / wc (i)
+ tfac = 1. + gsize (i) / 75000.
+ dtconv (i) = tfac * dtconv (i)
+ dtconv (i) = max (dtconv (i), dtmin)
+ dtconv (i) = max (dtconv (i), dt2)
+ dtconv (i) = min (dtconv (i), dtmax)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate advective time scale (tauadv) using a mean cloud layer wind speed.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ sumx (i) = 0.
+ umean (i) = 0.
+ endif
+ enddo
+
+ do k = 2, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= kbcon1 (i) .and. k < ktcon1 (i)) then
+ dz = zi (i, k) - zi (i, k - 1)
+ tem = sqrt (u1 (i, k) * u1 (i, k) + v1 (i, k) * v1 (i, k))
+ umean (i) = umean (i) + tem * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ umean (i) = umean (i) / sumx (i)
+ umean (i) = max (umean (i), 1.)
+ tauadv (i) = gsize (i) / umean (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute cloud base mass flux as a function of the mean
+ ! updraft velcoity
+ ! from han et al.'s (2017) equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity.
+ ! as discussed in han et al. (2017), when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. in this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kbcon (i)
+ rho = po (i, k) * 100. / (rdgas * to (i, k))
+ tfac = tauadv (i) / dtconv (i)
+ tfac = min (tfac, 1.)
+ xmb (i) = tfac * betaw * rho * wc (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for scale - aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see han et al.'s (2017) equation 4 and 5), following the study by grell and freitas (2014).
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = min (max (xlamue (i, kbcon (i)), 2.e-4), 6.e-4)
+ tem = 0.2 / tem
+ tem1 = 3.14 * tem * tem
+ sigmagfm (i) = tem1 / (gsize (i) ** 2.0)
+ sigmagfm (i) = max (sigmagfm (i), 0.001)
+ sigmagfm (i) = min (sigmagfm (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by arakawa and wu (2013) (also see han et al.'s (2017) equation 1 and 2) . the final cloud base mass flux with scale - aware parameterization is obtained from the mass flux when sigmagfm < < 1, multiplied by the reduction factor (han et al.'s (2017) equation 2) .
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (gsize (i) < dxcrt) then
+ scaldfunc (i) = (1. - sigmagfm (i)) * (1. - sigmagfm (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ xmb (i) = xmb (i) * scaldfunc (i)
+ xmb (i) = min (xmb (i), xmbmax (i))
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! for the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control.
+ ! - recalculate saturation specific humidity.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kmax (i)) then
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! calculate the temperature tendency from the moist static energy and specific humidity tendencies.
+ ! update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux - normalized tendencies by the cloud base mass flux.
+ ! accumulate column - integrated tendencies.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ delhbar (i) = 0.
+ delqbar (i) = 0.
+ deltbar (i) = 0.
+ delubar (i) = 0.
+ delvbar (i) = 0.
+ qcond (i) = 0.
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ dellat = (dellah (i, k) - hlv * dellaq (i, k)) / cp_air
+ t1 (i, k) = t1 (i, k) + dellat * xmb (i) * dt2
+ q1 (i, k) = q1 (i, k) + dellaq (i, k) * xmb (i) * dt2
+ ! tem = 1. / rcs (i)
+ ! u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2 * tem
+ ! v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2 * tem
+ u1 (i, k) = u1 (i, k) + dellau (i, k) * xmb (i) * dt2
+ v1 (i, k) = v1 (i, k) + dellav (i, k) * xmb (i) * dt2
+ dp = delp (i, k)
+ delhbar (i) = delhbar (i) + dellah (i, k) * xmb (i) * dp / g
+ delqbar (i) = delqbar (i) + dellaq (i, k) * xmb (i) * dp / g
+ deltbar (i) = deltbar (i) + dellat * xmb (i) * dp / g
+ delubar (i) = delubar (i) + dellau (i, k) * xmb (i) * dp / g
+ delvbar (i) = delvbar (i) + dellav (i, k) * xmb (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! recalculate saturation specific humidity using the updated temperature.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k > kb (i) .and. k <= ktcon (i)) then
+ qeso (i, k) = 0.01 * mqs (t1 (i, k)) ! mqs is in pa
+ qeso (i, k) = eps * qeso (i, k) / (pfld (i, k) + epsm1 * qeso (i, k))
+ val = 1.e-8
+ qeso (i, k) = max (qeso (i, k), val)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! add up column - integrated convective precipitation by multiplying the normalized value by the cloud base mass flux.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ rntot (i) = 0.
+ delqev (i) = 0.
+ delq2 (i) = 0.
+ flg (i) = cnvflg (i)
+ enddo
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < ktcon (i) .and. k > kb (i)) then
+ rntot (i) = rntot (i) + pwo (i, k) * xmb (i) * .001 * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! evaporating rain
+ ! determine the evaporation of the convective precipitation and update the integrated convective precipitation.
+ ! update state temperature and moisture to account for evaporation of convective precipitation.
+ ! update column - integrated tendencies to account for evaporation of convective precipitation.
+ ! -----------------------------------------------------------------------
+
+ do k = km, 1, - 1
+ do i = 1, im
+ if (k <= kmax (i)) then
+ deltv (i) = 0.
+ delq (i) = 0.
+ qevap (i) = 0.
+ if (cnvflg (i)) then
+ if (k < ktcon (i) .and. k > kb (i)) then
+ rn (i) = rn (i) + pwo (i, k) * xmb (i) * .001 * dt2
+ qr (i, k) = qr (i, k) + pwo (i, k) * xmb (i) * .001 * dt2
+ endif
+ endif
+ if (flg (i) .and. k < ktcon (i)) then
+ evef = edt (i) * evfact_shal
+ if (islimsk (i) == 1) evef = edt (i) * evfactl_shal
+ ! if (islimsk (i) == 1) evef = .07
+ ! if (islimsk (i) == 1) evef = 0.
+ qcond (i) = evef * (q1 (i, k) - qeso (i, k)) &
+ / (1. + el2orc * qeso (i, k) / t1 (i, k) ** 2)
+ dp = delp (i, k)
+ if (rn (i) > 0. .and. qcond (i) < 0.) then
+ qevap (i) = - qcond (i) * (1. - exp (- .32 * sqrt (dt2 * rn (i))))
+ qevap (i) = min (qevap (i), rn (i) * 1000. * g / dp)
+ delq2 (i) = delqev (i) + .001 * qevap (i) * dp / g
+ endif
+ if (rn (i) > 0. .and. qcond (i) < 0. .and. delq2 (i) > rntot (i)) then
+ qevap (i) = 1000. * g * (rntot (i) - delqev (i)) / dp
+ flg (i) = .false.
+ endif
+ if (rn (i) > 0. .and. qevap (i) > 0.) then
+ tem = .001 * dp / g
+ tem1 = qevap (i) * tem
+ if (tem1 > rn (i)) then
+ qevap (i) = rn (i) / tem
+ rn (i) = 0.
+ else
+ rn (i) = rn (i) - tem1
+ endif
+ qr (i, k) = qr (i, k) - qevap (i) * tem
+ q1 (i, k) = q1 (i, k) + qevap (i)
+ t1 (i, k) = t1 (i, k) - elocp * qevap (i)
+ deltv (i) = - elocp * qevap (i) / dt2
+ delq (i) = + qevap (i) / dt2
+ delqev (i) = delqev (i) + .001 * dp * qevap (i) / g
+ endif
+ delqbar (i) = delqbar (i) + delq (i) * dp / g
+ deltbar (i) = deltbar (i) + deltv (i) * dp / g
+ endif
+ endif
+ enddo
+ enddo
+
+ ! do i = 1, im
+ ! if (me == 31 .and. cnvflg (i)) then
+ ! if (cnvflg (i)) then
+ ! print *, ' shallow delhbar, delqbar, deltbar = ', &
+ ! delhbar (i), hlv * delqbar (i), cp_air * deltbar (i)
+ ! print *, ' shallow delubar, delvbar = ', delubar (i), delvbar (i)
+ ! print *, ' precip = ', hlv * rn (i) * 1000. / dt2
+ ! print *, 'pdif = ', pfld (i, kbcon (i)) - pfld (i, ktcon (i))
+ ! endif
+ ! enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (rn (i) < 0. .or. .not.flg (i)) rn (i) = 0.
+ ktop (i) = ktcon (i)
+ kbot (i) = kbcon (i)
+ kcnv (i) = 2
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud water
+ ! calculate shallow convective cloud water.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvw) .and. cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvw (i, k) = cnvwt (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! convective cloud cover
+ ! calculate convective cloud cover, which is used when pdf - based cloud fraction is used (i.e., pdfcld = .true.) .
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (cnvc) .and. cnvflg (i)) then
+ if (k >= kbcon (i) .and. k < ktcon (i)) then
+ cnvc (i, k) = 0.04 * log (1. + 675. * eta (i, k) * xmb (i))
+ cnvc (i, k) = min (cnvc (i, k), 0.2)
+ cnvc (i, k) = max (cnvc (i, k), 0.0)
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! cloud water
+ ! separate detrained cloud water into liquid and ice species as a function of temperature only.
+ ! -----------------------------------------------------------------------
+
+ if (ncloud > 0) then
+
+ do k = 1, km1
+ do i = 1, im
+ if (cnvflg (i)) then
+ ! if (k > kb (i) .and. k <= ktcon (i)) then
+ if (k >= kbcon (i) .and. k <= ktcon (i)) then
+ tem = dellal (i, k) * xmb (i) * dt2
+ ql (i, k) = ql (i, k) + tem
+ endif
+ endif
+ enddo
+ enddo
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! hchuang code change
+ ! calculate and retain the updraft mass flux for dust transport by cumulus convection.
+ ! calculate the updraft convective mass flux.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (present (ud_mf) .and. cnvflg (i)) then
+ if (k >= kb (i) .and. k < ktop (i)) then
+ ud_mf (i, k) = eta (i, k) * xmb (i) * dt2
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! save the updraft convective mass flux at cloud top.
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (present (dt_mf) .and. present (ud_mf) .and. cnvflg (i)) then
+ k = ktop (i) - 1
+ dt_mf (i, k) = ud_mf (i, k)
+ endif
+ enddo
+
+end subroutine sa_sas_shal
+
+end module sa_sas_mod
diff --git a/model/sa_tke_edmf.F90 b/model/sa_tke_edmf.F90
new file mode 100644
index 000000000..c8da06ef1
--- /dev/null
+++ b/model/sa_tke_edmf.F90
@@ -0,0 +1,4835 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! Scale-Aware Turbulent-Kinetic-Energy based Moist-Eddy-Diffusivity-Mass-Flux
+! (SA-TKE-EDMF) Subgrid Vertical Turbulence Mixing Scheme
+! For the convective boundary layer, the scheme adopts EDMF parameterization
+! (Siebesma et al. 2007) to take into account non-local transport by
+! large eddies (mfpblt.f).
+! A new mass-flux parameterizaiton for stratocumulus-top-induced turbulence
+! mixing has been introduced (previously, it was eddy diffusion form) (mfscu.f).
+! For local turbulence mixing, a TKE closure model is used.
+! Developers: Jongil Han, Kun Gao, Linjiong Zhou, and the GFDL FV3 Team
+! References: Han et al. (2016), Han and Bretherton (2019)
+! =======================================================================
+
+! =======================================================================
+! Updates at GFDL:
+! 1) Jul 2019 by Kun Gao
+! goal: to allow for tke advection
+! change: rearange tracers (q1g)
+! TKE no longer needs to be the last tracer
+! 2) Nov 2019 by Kun Gao
+! turn off non-local mixing for hydrometers to avoid unphysical negative values
+! 3) Jun 2020 by Kun Gao
+! a) add option for turning off upper-limter on background diff. in inversion layer
+! over land/ice points (cap_k0_land)
+! b) use different xkzm_m, xkzm_h for land, ocean and sea ice points
+! c) add option for turning off hb19 formula for surface backgroud diff. (do_dk_hb19)
+! 4) May 2022 by Linjiong Zhou
+! put it into the FV3 dynamical core and revise accordingly
+! =======================================================================
+
+module sa_tke_edmf_mod
+
+ use fms_mod, only: check_nml_error
+ use gfdl_mp_mod, only: mqs
+
+ implicit none
+
+ private
+
+ ! -----------------------------------------------------------------------
+ ! public subroutines, functions, and variables
+ ! -----------------------------------------------------------------------
+
+ public :: sa_tke_edmf_init
+ public :: sa_tke_edmf_pbl
+ public :: sa_tke_edmf_sfc
+
+ ! -----------------------------------------------------------------------
+ ! physics constants
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS
+
+ real, parameter :: sbc = 5.670400e-8 ! Stefan-Boltzmann constant (kg/s^3/K^4)
+
+ 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 :: zvir = rvgas / rdgas - 1. ! 0.6077667316114637
+ real, parameter :: eps = rdgas / rvgas ! 0.6219934994582882
+ real, parameter :: epsm1 = rdgas / rvgas - 1. ! -0.3780065005417118
+
+ real, parameter :: t0ice = 273.15 ! freezing temperature (K): ref: GFDL, GFS
+ real, parameter :: tgice = 271.2 ! freezing temperature at sea (K)
+
+ real, parameter :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS
+ real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K)
+
+ real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS
+
+ 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
+
+ ! -----------------------------------------------------------------------
+ ! namelist parameters
+ ! -----------------------------------------------------------------------
+
+ logical :: cap_k0_land = .true. ! flag for applying limter on background diff in inversion
+ logical :: do_dk_hb19 = .false. ! flag for using hb19 formula for background diff
+ logical :: dspheat = .false. ! flag for tke dissipative heating
+ logical :: sfc_gfdl = .false. ! flag for using updated sfc layer scheme
+
+ logical :: redrag = .false. ! flag for reduced drag coeff. over sea
+ logical :: do_z0_moon = .false. ! flag for using z0 scheme in Moon et al. 2007
+ logical :: do_z0_hwrf15 = .false. ! flag for using z0 scheme in 2015 HWRF
+ logical :: do_z0_hwrf17 = .false. ! flag for using z0 scheme in 2017 HWRF
+ logical :: do_z0_hwrf17_hwonly = .false. ! flag for using z0 scheme in 2017 HWRF only under high wind
+
+ integer :: ivegsrc = 2 ! ivegsrc = 0 => USGS,
+ ! ivegsrc = 1 => IGBP (20 category)
+ ! ivegsrc = 2 => UMD (13 category)
+
+ real :: xkzm_mo = 1.0 ! bkgd_vdif_m background vertical diffusion for momentum over ocean
+ real :: xkzm_ho = 1.0 ! bkgd_vdif_h background vertical diffusion for heat q over ocean
+ real :: xkzm_ml = 1.0 ! bkgd_vdif_m background vertical diffusion for momentum over land
+ real :: xkzm_hl = 1.0 ! bkgd_vdif_h background vertical diffusion for heat q over land
+ real :: xkzm_mi = 1.0 ! bkgd_vdif_m background vertical diffusion for momentum over ice
+ real :: xkzm_hi = 1.0 ! bkgd_vdif_h background vertical diffusion for heat q over ice
+ real :: xkzm_s = 1.0 ! bkgd_vdif_s sigma threshold for background mom. diffusion
+ real :: xkzm_lim = 0.01 ! background vertical diffusion limit
+ real :: xkzm_fac = 1.0 ! background vertical diffusion factor
+ real :: xkzinv = 0.15 ! diffusivity in inversion layers
+ real :: xkgdx = 25.e3 ! background vertical diffusion threshold
+ real :: rlmn = 30. ! lower-limter on asymtotic mixing length in satmedmfdiff.f
+ real :: rlmx = 300. ! upper-limter on asymtotic mixing length in satmedmfdiff.f
+
+ real :: czilc = 0.8 ! Zilintkivitch constant
+ real :: z0s_max = .317e-2 ! a limiting value for z0 under high windskk
+ real :: wind_th_hwrf = 33. ! wind speed threshold when z0 level off as in HWRF
+
+ real :: ck0 = 0.4 ! proportionality coefficient for momentum in PBL
+ real :: ck1 = 0.15 ! proportionality coefficient for momentum above PBL
+ real :: ch0 = 0.4 ! proportionality coefficient for heat & q in PBL
+ real :: ch1 = 0.15 ! proportionality coefficient for heat & q above PBL
+
+ ! -----------------------------------------------------------------------
+ ! namelist
+ ! -----------------------------------------------------------------------
+
+ namelist / sa_tke_edmf_nml / &
+ xkzm_mo, xkzm_ho, xkzm_ml, xkzm_hl, xkzm_mi, xkzm_hi, xkzm_s, &
+ xkzm_lim, xkzm_fac, xkzinv, xkgdx, rlmn, rlmx, sfc_gfdl, &
+ cap_k0_land, do_dk_hb19, dspheat, redrag, do_z0_moon, &
+ do_z0_hwrf15, do_z0_hwrf17, do_z0_hwrf17_hwonly, czilc, &
+ z0s_max, wind_th_hwrf, ivegsrc, ck0, ck1, ch0, ch1
+
+contains
+
+! =======================================================================
+! SA-TKE-EDMF initialization
+! =======================================================================
+
+subroutine sa_tke_edmf_init (input_nml_file, logunit)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: logunit
+
+ character (len = *), intent (in) :: input_nml_file (:)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: ios, ierr
+
+ ! -----------------------------------------------------------------------
+ ! read namelist
+ ! -----------------------------------------------------------------------
+
+ read (input_nml_file, nml = sa_tke_edmf_nml, iostat = ios)
+ ierr = check_nml_error (ios, 'sa_tke_edmf_nml')
+
+ ! -----------------------------------------------------------------------
+ ! write namelist to log file
+ ! -----------------------------------------------------------------------
+
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "sa_tke_edmf_mod"
+ write (logunit, nml = sa_tke_edmf_nml)
+
+end subroutine sa_tke_edmf_init
+
+! =======================================================================
+! SA-TKE-EDMF scheme
+! =======================================================================
+
+subroutine sa_tke_edmf_pbl (im, km, ntrac, ntcw, ntiw, ntke, &
+ delt, u1, v1, t1, q1, gsize, islimsk, &
+ radh, rbsoil, zorl, u10m, v10m, fm, fh, &
+ tsea, heat, evap, stress, spd1, kinver, &
+ psk, del, prsi, prsl, prslk, phii, phil, &
+ hpbl, kpbl, dusfc, dvsfc, dtsfc, dqsfc, dkt_out)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, ntrac, ntcw, ntiw, ntke
+ integer, intent (in) :: kinver (im), islimsk (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: radh (im, km), gsize (im), &
+ psk (im), rbsoil (im), &
+ zorl (im), tsea (im), &
+ u10m (im), v10m (im), &
+ fm (im), fh (im), &
+ evap (im), heat (im), &
+ stress (im), spd1 (im), &
+ prsi (im, km + 1), del (im, km), &
+ prsl (im, km), prslk (im, km), &
+ phii (im, km + 1), phil (im, km)
+
+ real, intent (inout) :: u1 (im, km), v1 (im, km), &
+ t1 (im, km), q1 (im, km, ntrac)
+
+ integer, intent (out) :: kpbl (im)
+
+ real, intent (out) :: hpbl (im)
+
+ real, intent (out), optional :: dusfc (im), dvsfc (im), dtsfc (im), dqsfc (im), &
+ dkt_out (im, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, is, k, kk, n, km1, kmpbl, kmscu, ntrac1, ntcw_new
+ integer :: lcld (im), kcld (im), krad (im), mrad (im)
+ integer :: kx1 (im), kpblx (im)
+
+ real :: tke (im, km), tkeh (im, km - 1)
+
+ real :: theta (im, km), thvx (im, km), thlvx (im, km), &
+ qlx (im, km), thetae (im, km), thlx (im, km), &
+ slx (im, km), svx (im, km), qtx (im, km), &
+ tvx (im, km), pix (im, km), radx (im, km - 1), &
+ dku (im, km - 1), dkt (im, km - 1), dkq (im, km - 1), &
+ cku (im, km - 1), ckt (im, km - 1), q1g (im, km, ntrac), &
+ vdt (im, km), udt (im, km), tdt (im, km), qdt (im, km)
+
+ real :: plyr (im, km), rhly (im, km), cfly (im, km), &
+ qstl (im, km)
+
+ real :: dtdz1 (im), gdx (im), &
+ phih (im), phim (im), prn (im, km - 1), &
+ rbdn (im), rbup (im), thermal (im), &
+ ustar (im), wstar (im), hpblx (im), &
+ ust3 (im), wst3 (im), &
+ z0 (im), crb (im), &
+ hgamt (im), hgamq (im), &
+ wscale (im), vpert (im), &
+ zol (im), sflux (im), radj (im), &
+ tx1 (im), tx2 (im)
+
+ real :: radmin (im)
+
+ real :: zi (im, km + 1), zl (im, km), zm (im, km), &
+ xkzo (im, km - 1), xkzmo (im, km - 1), &
+ xkzm_hx (im), xkzm_mx (im), &
+ rdzt (im, km - 1), &
+ al (im, km - 1), ad (im, km), au (im, km - 1), &
+ f1 (im, km), f2 (im, km * (ntrac - 1))
+
+ real :: elm (im, km), ele (im, km), rle (im, km - 1), &
+ ckz (im, km), chz (im, km), &
+ diss (im, km - 1), prod (im, km - 1), &
+ bf (im, km - 1), shr2 (im, km - 1), &
+ xlamue (im, km - 1), xlamde (im, km - 1), &
+ gotvx (im, km), rlam (im, km - 1)
+
+ ! variables for updrafts (thermals)
+ real :: tcko (im, km), qcko (im, km, ntrac), &
+ ucko (im, km), vcko (im, km), &
+ buou (im, km), xmf (im, km)
+
+ ! variables for stratocumulus - top induced downdrafts
+ real :: tcdo (im, km), qcdo (im, km, ntrac), &
+ ucdo (im, km), vcdo (im, km), &
+ buod (im, km), xmfd (im, km)
+
+ logical :: pblflg (im), sfcflg (im), flg (im)
+ logical :: scuflg (im), pcnvflg (im)
+ logical :: mlenflg
+
+ ! pcnvflg: true for unstable pbl
+ real :: aphi16, aphi5, &
+ wfac, cfac, &
+ gamcrt, gamcrq, sfcfrac, &
+ conq, cont, conw, &
+ dsdz2, dsdzt, dkmax, &
+ dsig, dt2, dtodsd, &
+ dtodsu, g, factor, dz, &
+ gocp, gravi, zol1, zolcru, &
+ buop, shrp, dtn, cdtn, &
+ prnum, prmax, prmin, prtke, &
+ prscu, dw2, dw2min, zk, &
+ elmfac, elefac, dspmax, &
+ alp, clwt, cql, &
+ f0, robn, crbmin, crbmax, &
+ es, qs, value, onemrh, &
+ cfh, gamma, elocp, el2orc, &
+ epsi, beta, chx, cqx, &
+ rdt, rdz, qmin, qlmin, &
+ ri, rimin, &
+ rbcr, rbint, tdzmin, &
+ elmx, &
+ ttend, utend, vtend, qtend, &
+ zfac, zfmin, vk, spdk2, &
+ tkmin, dspfac, &
+ zlup, zldn, bsum, &
+ tem, tem1, tem2, &
+ ptem, ptem0, ptem1, ptem2
+
+ real :: ce0, rchck
+
+ real :: qlcr, zstblmax
+
+ real :: h1
+
+ parameter (gravi = 1.0 / grav)
+ parameter (g = grav)
+ parameter (gocp = g / cp_air)
+ parameter (cont = cp_air / g, conq = hlv / g, conw = 1.0 / g)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (wfac = 7.0, cfac = 4.5)
+ parameter (gamcrt = 3., gamcrq = 0., sfcfrac = 0.1)
+ parameter (vk = 0.4, rimin = - 100.)
+ parameter (rbcr = 0.25, zolcru = - 0.02, tdzmin = 1.e-3)
+ parameter (prmin = 0.25, prmax = 4.0, prtke = 1.0, prscu = 0.67)
+ parameter (f0 = 1.e-4, crbmin = 0.15, crbmax = 0.35)
+ parameter (tkmin = 1.e-9, dspfac = 0.5, dspmax = 10.0)
+ parameter (qmin = 1.e-8, qlmin = 1.e-12, zfmin = 1.e-8)
+ parameter (aphi5 = 5., aphi16 = 16.)
+ parameter (elmfac = 1.0, elefac = 1.0, cql = 100.)
+ parameter (dw2min = 1.e-4, dkmax = 1000.)
+ parameter (qlcr = 3.5e-5, zstblmax = 2500.)
+ parameter (h1 = 0.33333333)
+ parameter (ce0 = 0.4)
+ parameter (rchck = 1.5, cdtn = 25.)
+
+ elmx = rlmx
+
+ ! -----------------------------------------------------------------------
+ ! kgao note (jul 2019)
+ ! the code was originally written assuming ntke = ntrac
+ ! in this version ntke does not need to be equal to ntrac
+ ! in the following we rearrange q1g so that tke is the last tracer
+ ! -----------------------------------------------------------------------
+
+ !if (ntrac >= 3) then
+ if (ntke == ntrac) then ! tke is the last tracer
+ q1g (:, :, :) = q1 (:, :, :)
+ else ! tke is not
+ do kk = 1, ntke - 1
+ q1g (:, :, kk) = q1 (:, :, kk)
+ enddo
+ do kk = ntke + 1, ntrac
+ q1g (:, :, kk - 1) = q1 (:, :, kk)
+ enddo
+ q1g (:, :, ntrac) = q1 (:, :, ntke)
+ endif
+ !endif
+
+ dt2 = delt
+ rdt = 1. / dt2
+
+ ntrac1 = ntrac - 1
+ km1 = km - 1
+ kmpbl = km / 2
+ kmscu = km / 2
+
+ do k = 1, km
+ do i = 1, im
+ zi (i, k) = phii (i, k) * gravi
+ zl (i, k) = phil (i, k) * gravi
+ xmf (i, k) = 0.
+ xmfd (i, k) = 0.
+ buou (i, k) = 0.
+ buod (i, k) = 0.
+ ckz (i, k) = ck1
+ chz (i, k) = ch1
+ enddo
+ enddo
+
+ do i = 1, im
+ zi (i, km + 1) = phii (i, km + 1) * gravi
+ enddo
+ do k = 1, km
+ do i = 1, im
+ zm (i, k) = zi (i, k + 1)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! horizontal grid size
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ gdx (i) = gsize (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ tke (i, k) = max (q1 (i, k, ntke), tkmin) ! tke at layer centers
+ enddo
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ tkeh (i, k) = 0.5 * (tke (i, k) + tke (i, k + 1)) ! tke at interfaces
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ rdzt (i, k) = 1.0 / (zl (i, k + 1) - zl (i, k))
+ prn (i, k) = 1.0
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! han and bretherton, 2019
+ ! set background diffusivities as a function of
+ ! horizontal grid size with xkzm_h & xkzm_m for gdx >= xkgdx
+ ! and 0.01 for gdx = 5m, i.e.,
+ ! xkzm_hx = 0.01 + (xkzm_h - 0.01) / (xkgdx - 5.) * (gdx - 5.)
+ ! xkzm_mx = 0.01 + (xkzm_h - 0.01) / (xkgdx - 5.) * (gdx - 5.)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ kx1 (i) = 1
+ tx1 (i) = 1.0 / prsi (i, 1)
+ tx2 (i) = tx1 (i)
+
+ ! -----------------------------------------------------------------------
+ ! kgao change - set surface value of background diff (dk) below
+ ! -----------------------------------------------------------------------
+
+ if (do_dk_hb19) then ! use eq43 in hb2019
+
+ if (gdx (i) >= xkgdx) then ! resolution coarser than xkgdx
+ if (islimsk (i) == 1) then ! land points
+ xkzm_hx (i) = xkzm_hl
+ xkzm_mx (i) = xkzm_ml
+ elseif (islimsk (i) == 2) then! sea ice points
+ xkzm_hx (i) = xkzm_hi
+ xkzm_mx (i) = xkzm_mi
+ else ! ocean points
+ xkzm_hx (i) = xkzm_ho
+ xkzm_mx (i) = xkzm_mo
+ endif
+ else ! resolution finer than xkgdx
+ tem = 1. / (xkgdx - 5.)
+ if (islimsk (i) == 1) then ! land points
+ tem1 = (xkzm_hl - xkzm_lim) * tem
+ tem2 = (xkzm_ml - xkzm_lim) * tem
+ elseif (islimsk (i) == 2) then! sea ice points
+ tem1 = (xkzm_hi - xkzm_lim) * tem
+ tem2 = (xkzm_mi - xkzm_lim) * tem
+ else ! ocean points
+ tem1 = (xkzm_ho - xkzm_lim) * tem
+ tem2 = (xkzm_mo - xkzm_lim) * tem
+ endif
+ ptem = gdx (i) - 5.
+ xkzm_hx (i) = xkzm_lim + tem1 * ptem
+ xkzm_mx (i) = xkzm_lim + tem2 * ptem
+ endif
+
+ else ! use values in the namelist; no res dependency
+
+ if (islimsk (i) == 1) then ! land points
+ xkzm_hx (i) = xkzm_hl
+ xkzm_mx (i) = xkzm_ml
+ elseif (islimsk (i) == 2) then ! sea ice points
+ xkzm_hx (i) = xkzm_hi
+ xkzm_mx (i) = xkzm_mi
+ else ! ocean points
+ xkzm_hx (i) = xkzm_ho
+ xkzm_mx (i) = xkzm_mo
+ endif
+
+ endif
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ xkzo (i, k) = 0.0
+ xkzmo (i, k) = 0.0
+ if (k < kinver (i)) then
+ ! -----------------------------------------------------------------------
+ ! vertical background diffusivity
+ ! -----------------------------------------------------------------------
+ ptem = prsi (i, k + 1) * tx1 (i)
+ tem1 = 1.0 - ptem
+ tem1 = tem1 * tem1 * 10.0
+ xkzo (i, k) = xkzm_hx (i) * min (1.0, exp (- tem1))
+ ! -----------------------------------------------------------------------
+ ! vertical background diffusivity for momentum
+ ! -----------------------------------------------------------------------
+ if (ptem >= xkzm_s) then
+ xkzmo (i, k) = xkzm_mx (i)
+ kx1 (i) = k + 1
+ else
+ if (k == kx1 (i) .and. k > 1) tx2 (i) = 1.0 / prsi (i, k)
+ tem1 = 1.0 - prsi (i, k + 1) * tx2 (i)
+ tem1 = tem1 * tem1 * 5.0
+ xkzmo (i, k) = xkzm_mx (i) * min (1.0, exp (- tem1))
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ z0 (i) = 0.01 * zorl (i)
+ if (present (dusfc)) dusfc (i) = 0.
+ if (present (dvsfc)) dvsfc (i) = 0.
+ if (present (dtsfc)) dtsfc (i) = 0.
+ if (present (dqsfc)) dqsfc (i) = 0.
+ kpbl (i) = 1
+ hpbl (i) = 0.
+ kpblx (i) = 1
+ hpblx (i) = 0.
+ pblflg (i) = .true.
+ sfcflg (i) = .true.
+ if (rbsoil (i) > 0.) sfcflg (i) = .false.
+ pcnvflg (i) = .false.
+ scuflg (i) = .true.
+ if (scuflg (i)) then
+ radmin (i) = 0.
+ mrad (i) = km1
+ krad (i) = 1
+ lcld (i) = km1
+ kcld (i) = km1
+ endif
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ pix (i, k) = psk (i) / prslk (i, k)
+ theta (i, k) = t1 (i, k) * pix (i, k)
+ if (ntiw > 0) then
+ tem = max (q1 (i, k, ntcw), qlmin)
+ tem1 = max (q1 (i, k, ntiw), qlmin)
+ qlx (i, k) = tem + tem1
+ ptem = hlv * tem + (hlv + hlf) * tem1
+ slx (i, k) = cp_air * t1 (i, k) + phil (i, k) - ptem
+ else
+ qlx (i, k) = max (q1 (i, k, ntcw), qlmin)
+ slx (i, k) = cp_air * t1 (i, k) + phil (i, k) - hlv * qlx (i, k)
+ endif
+ tem2 = 1. + zvir * max (q1g (i, k, 1), qmin) - qlx (i, k)
+ thvx (i, k) = theta (i, k) * tem2
+ tvx (i, k) = t1 (i, k) * tem2
+ qtx (i, k) = max (q1g (i, k, 1), qmin) + qlx (i, k)
+ thlx (i, k) = theta (i, k) - pix (i, k) * elocp * qlx (i, k)
+ thlvx (i, k) = thlx (i, k) * (1. + zvir * qtx (i, k))
+ svx (i, k) = cp_air * tvx (i, k)
+ ptem1 = elocp * pix (i, k) * max (q1g (i, k, 1), qmin)
+ thetae (i, k) = theta (i, k) + ptem1
+ gotvx (i, k) = g / tvx (i, k)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! the background vertical diffusivities in the inversion layers are limited
+ ! to be less than or equal to xkzminv
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ tem1 = (tvx (i, k + 1) - tvx (i, k)) * rdzt (i, k)
+
+ if (cap_k0_land) then
+ if (tem1 > 1.e-5) then
+ xkzo (i, k) = min (xkzo (i, k), xkzinv)
+ xkzmo (i, k) = min (xkzmo (i, k), xkzinv)
+ endif
+ else
+ ! -----------------------------------------------------------------------
+ ! kgao note: do not apply upper - limiter over land and sea ice points
+ ! (consistent with change in satmedmfdifq.f in jun 2020)
+ ! -----------------------------------------------------------------------
+ if (tem1 > 0. .and. islimsk (i) == 0) then
+ xkzo (i, k) = min (xkzo (i, k), xkzinv)
+ xkzmo (i, k) = min (xkzmo (i, k), xkzinv)
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute an empirical cloud fraction based on
+ ! xu & randall's (1996, jas) study
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ plyr (i, k) = 0.01 * prsl (i, k) ! pa to mb (hpa)
+ ! compute relative humidity
+ es = 0.01 * mqs (t1 (i, k)) ! mqs in pa
+ ! revise it to a stable format -- Linjiong Zhou, 7/19/2022
+ ! qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ qs = max (qmin, es / plyr (i, k) * eps * (1 + zvir * q1g (i, k, 1)))
+ rhly (i, k) = max (0.0, min (1.0, max (qmin, q1g (i, k, 1)) / qs))
+ qstl (i, k) = qs
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ cfly (i, k) = 0.
+ clwt = 1.0e-6 * (plyr (i, k) * 0.001)
+ if (qlx (i, k) > clwt) then
+ onemrh = max (1.e-10, 1.0 - rhly (i, k))
+ tem1 = min (max ((onemrh * qstl (i, k)) ** 0.49, 0.0001), 1.0)
+ tem1 = cql / tem1
+ value = max (min (tem1 * qlx (i, k), 50.0), 0.0)
+ tem2 = sqrt (sqrt (rhly (i, k)))
+ cfly (i, k) = min (max (tem2 * (1.0 - exp (- value)), 0.0), 1.0)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy modified by clouds
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ tem = 0.5 * (svx (i, k) + svx (i, k + 1))
+ tem1 = 0.5 * (t1 (i, k) + t1 (i, k + 1))
+ tem2 = 0.5 * (qstl (i, k) + qstl (i, k + 1))
+ cfh = min (cfly (i, k + 1), 0.5 * (cfly (i, k) + cfly (i, k + 1)))
+ alp = g / tem
+ gamma = el2orc * tem2 / (tem1 ** 2)
+ epsi = tem1 / elocp
+ beta = (1. + gamma * epsi * (1. + zvir)) / (1. + gamma)
+ chx = cfh * alp * beta + (1. - cfh) * alp
+ cqx = cfh * alp * hlv * (beta - epsi)
+ cqx = cqx + (1. - cfh) * zvir * g
+ ptem1 = (slx (i, k + 1) - slx (i, k)) * rdzt (i, k)
+ ptem2 = (qtx (i, k + 1) - qtx (i, k)) * rdzt (i, k)
+ bf (i, k) = chx * ptem1 + cqx * ptem2
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ dku (i, k) = 0.
+ dkt (i, k) = 0.
+ dkq (i, k) = 0.
+ cku (i, k) = 0.
+ ckt (i, k) = 0.
+ tem = zi (i, k + 1) - zi (i, k)
+ radx (i, k) = tem * radh (i, k)
+ enddo
+ enddo
+
+ do i = 1, im
+ sflux (i) = heat (i) + evap (i) * zvir * theta (i, 1)
+ if (.not.sfcflg (i) .or. sflux (i) <= 0.) pblflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute critical bulk richardson number
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (pblflg (i)) then
+ ! thermal (i) = thvx (i, 1)
+ thermal (i) = thlvx (i, 1)
+ crb (i) = rbcr
+ else
+ thermal (i) = tsea (i) * (1. + zvir * max (q1g (i, 1, 1), qmin))
+ tem = sqrt (u10m (i) ** 2 + v10m (i) ** 2)
+ tem = max (tem, 1.)
+ robn = tem / (f0 * z0 (i))
+ tem1 = 1.e-7 * robn
+ crb (i) = 0.16 * (tem1 ** (- 0.18))
+ crb (i) = max (min (crb (i), crbmax), crbmin)
+ endif
+ enddo
+
+ do i = 1, im
+ dtdz1 (i) = dt2 / (zi (i, 2) - zi (i, 1))
+ enddo
+
+ do i = 1, im
+ ustar (i) = sqrt (stress (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy (bf) and winshear square
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ rdz = rdzt (i, k)
+ ! bf (i, k) = gotvx (i, k) * (thvx (i, k + 1) - thvx (i, k)) * rdz
+ dw2 = (u1 (i, k) - u1 (i, k + 1)) ** 2 + &
+ (v1 (i, k) - v1 (i, k + 1)) ** 2
+ shr2 (i, k) = max (dw2, dw2min) * rdz * rdz
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! find pbl height based on bulk richardson number (mrf pbl scheme)
+ ! and also for diagnostic purpose
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .false.
+ rbup (i) = rbsoil (i)
+ enddo
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (.not.flg (i)) then
+ rbdn (i) = rbup (i)
+ spdk2 = max ((u1 (i, k) ** 2 + v1 (i, k) ** 2), 1.)
+ ! rbup (i) = (thvx (i, k) - thermal (i)) * &
+ ! (g * zl (i, k) / thvx (i, 1)) / spdk2
+ rbup (i) = (thlvx (i, k) - thermal (i)) * &
+ (g * zl (i, k) / thlvx (i, 1)) / spdk2
+ kpblx (i) = k
+ flg (i) = rbup (i) > crb (i)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (kpblx (i) > 1) then
+ k = kpblx (i)
+ if (rbdn (i) >= crb (i)) then
+ rbint = 0.
+ elseif (rbup (i) <= crb (i)) then
+ rbint = 1.
+ else
+ rbint = (crb (i) - rbdn (i)) / (rbup (i) - rbdn (i))
+ endif
+ hpblx (i) = zl (i, k - 1) + rbint * (zl (i, k) - zl (i, k - 1))
+ if (hpblx (i) < zi (i, kpblx (i))) kpblx (i) = kpblx (i) - 1
+ else
+ hpblx (i) = zl (i, 1)
+ kpblx (i) = 1
+ endif
+ hpbl (i) = hpblx (i)
+ kpbl (i) = kpblx (i)
+ if (kpbl (i) <= 1) pblflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute similarity parameters
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ zol (i) = max (rbsoil (i) * fm (i) * fm (i) / fh (i), rimin)
+ if (sfcflg (i)) then
+ zol (i) = min (zol (i), - zfmin)
+ else
+ zol (i) = max (zol (i), zfmin)
+ endif
+
+ zol1 = zol (i) * sfcfrac * hpbl (i) / zl (i, 1)
+ if (sfcflg (i)) then
+ tem = 1.0 / (1. - aphi16 * zol1)
+ phih (i) = sqrt (tem)
+ phim (i) = sqrt (phih (i))
+ else
+ phim (i) = 1. + aphi5 * zol1
+ phih (i) = phim (i)
+ endif
+ enddo
+
+ do i = 1, im
+ if (pblflg (i)) then
+ if (zol (i) < zolcru) then
+ pcnvflg (i) = .true.
+ endif
+ wst3 (i) = gotvx (i, 1) * sflux (i) * hpbl (i)
+ wstar (i) = wst3 (i) ** h1
+ ust3 (i) = ustar (i) ** 3.
+ wscale (i) = (ust3 (i) + wfac * vk * wst3 (i) * sfcfrac) ** h1
+ ptem = ustar (i) / aphi5
+ wscale (i) = max (wscale (i), ptem)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute a thermal excess
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (pcnvflg (i)) then
+ hgamt (i) = heat (i) / wscale (i)
+ hgamq (i) = evap (i) / wscale (i)
+ vpert (i) = hgamt (i) + hgamq (i) * zvir * theta (i, 1)
+ vpert (i) = max (vpert (i), 0.)
+ tem = min (cfac * vpert (i), gamcrt)
+ thermal (i) = thermal (i) + tem !jih jul2020
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! enhance the pbl height by considering the thermal excess
+ ! (overshoot pbl top) -- jih jul2020
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .true.
+ if (pcnvflg (i)) then
+ flg (i) = .false.
+ rbup (i) = rbsoil (i)
+ endif
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (.not.flg (i)) then
+ rbdn (i) = rbup (i)
+ spdk2 = max ((u1 (i, k) ** 2 + v1 (i, k) ** 2), 1.)
+ rbup (i) = (thlvx (i, k) - thermal (i)) * &
+ (g * zl (i, k) / thlvx (i, 1)) / spdk2
+ kpbl (i) = k
+ flg (i) = rbup (i) > crb (i)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (pcnvflg (i)) then
+ k = kpbl (i)
+ if (rbdn (i) >= crb (i)) then
+ rbint = 0.
+ elseif (rbup (i) <= crb (i)) then
+ rbint = 1.
+ else
+ rbint = (crb (i) - rbdn (i)) / (rbup (i) - rbdn (i))
+ endif
+ hpbl (i) = zl (i, k - 1) + rbint * (zl (i, k) - zl (i, k - 1))
+ if (hpbl (i) < zi (i, kpbl (i))) then
+ kpbl (i) = kpbl (i) - 1
+ endif
+ if (kpbl (i) <= 1) then
+ pcnvflg (i) = .false.
+ pblflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! look for stratocumulus
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = scuflg (i)
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ if (flg (i) .and.zl (i, k) >= zstblmax) then
+ lcld (i) = k
+ flg (i) = .false.
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ flg (i) = scuflg (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k <= lcld (i)) then
+ if (qlx (i, k) >= qlcr) then
+ kcld (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (scuflg (i) .and. kcld (i) == km1) scuflg (i) = .false.
+ enddo
+
+ do i = 1, im
+ flg (i) = scuflg (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k <= kcld (i)) then
+ if (qlx (i, k) >= qlcr) then
+ if (radx (i, k) < radmin (i)) then
+ radmin (i) = radx (i, k)
+ krad (i) = k
+ endif
+ else
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (scuflg (i) .and. krad (i) <= 1) scuflg (i) = .false.
+ if (scuflg (i) .and. radmin (i) >= 0.) scuflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute components for mass flux mixing by large thermals
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (pcnvflg (i)) then
+ tcko (i, k) = t1 (i, k)
+ ucko (i, k) = u1 (i, k)
+ vcko (i, k) = v1 (i, k)
+ endif
+ if (scuflg (i)) then
+ tcdo (i, k) = t1 (i, k)
+ ucdo (i, k) = u1 (i, k)
+ vcdo (i, k) = v1 (i, k)
+ endif
+ enddo
+ enddo
+ do kk = 1, ntrac1
+ do k = 1, km
+ do i = 1, im
+ if (pcnvflg (i)) then
+ qcko (i, k, kk) = q1g (i, k, kk)
+ endif
+ if (scuflg (i)) then
+ qcdo (i, k, kk) = q1g (i, k, kk)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! kgao note - change ntcw if q1g is rearranged
+ ! -----------------------------------------------------------------------
+
+ if (ntke > ntcw) then
+ ntcw_new = ntcw
+ else
+ ntcw_new = ntcw - 1
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! edmf parameterization siebesma et al. (2007)
+ ! -----------------------------------------------------------------------
+
+ call mfpblt (im, km, kmpbl, ntcw_new, ntrac1, dt2, &
+ pcnvflg, zl, zm, q1g, t1, u1, v1, plyr, pix, thlx, thvx, &
+ gdx, hpbl, kpbl, vpert, buou, xmf, &
+ tcko, qcko, ucko, vcko, xlamue)
+
+ ! -----------------------------------------------------------------------
+ ! mass - flux parameterization for stratocumulus - top - induced turbulence mixing
+ ! -----------------------------------------------------------------------
+
+ call mfscu (im, km, kmscu, ntcw_new, ntrac1, dt2, &
+ scuflg, zl, zm, q1g, t1, u1, v1, plyr, pix, &
+ thlx, thvx, thlvx, gdx, thetae, radj, &
+ krad, mrad, radmin, buod, xmfd, &
+ tcdo, qcdo, ucdo, vcdo, xlamde)
+
+ ! -----------------------------------------------------------------------
+ ! compute prandtl number and exchange coefficient varying with height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (k < kpbl (i)) then
+ tem = phih (i) / phim (i)
+ ptem = - 3. * (max (zi (i, k + 1) - sfcfrac * hpbl (i), 0.)) ** 2. &
+ / hpbl (i) ** 2.
+ if (pcnvflg (i)) then
+ prn (i, k) = 1. + (tem - 1.) * exp (ptem)
+ else
+ prn (i, k) = tem
+ endif
+ prn (i, k) = min (prn (i, k), prmax)
+ prn (i, k) = max (prn (i, k), prmin)
+
+ ckz (i, k) = ck1 + (ck0 - ck1) * exp (ptem)
+ ckz (i, k) = min (ckz (i, k), ck0)
+ ckz (i, k) = max (ckz (i, k), ck1)
+ chz (i, k) = ch1 + (ch0 - ch1) * exp (ptem)
+ chz (i, k) = min (chz (i, k), ch0)
+ chz (i, k) = max (chz (i, k), ch1)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute an asymtotic mixing length
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ zlup = 0.0
+ bsum = 0.0
+ mlenflg = .true.
+ do n = k, km1
+ if (mlenflg) then
+ dz = zl (i, n + 1) - zl (i, n)
+ ptem = gotvx (i, n) * (thvx (i, n + 1) - thvx (i, k)) * dz
+ ! ptem = gotvx (i, n) * (thlvx (i, n + 1) - thlvx (i, k)) * dz
+ bsum = bsum + ptem
+ zlup = zlup + dz
+ if (bsum >= tke (i, k)) then
+ if (ptem >= 0.) then
+ tem2 = max (ptem, zfmin)
+ else
+ tem2 = min (ptem, - zfmin)
+ endif
+ ptem1 = (bsum - tke (i, k)) / tem2
+ zlup = zlup - ptem1 * dz
+ zlup = max (zlup, 0.)
+ mlenflg = .false.
+ endif
+ endif
+ enddo
+ zldn = 0.0
+ bsum = 0.0
+ mlenflg = .true.
+ do n = k, 1, - 1
+ if (mlenflg) then
+ if (n == 1) then
+ dz = zl (i, 1)
+ tem1 = tsea (i) * (1. + zvir * max (q1g (i, 1, 1), qmin))
+ else
+ dz = zl (i, n) - zl (i, n - 1)
+ tem1 = thvx (i, n - 1)
+ ! tem1 = thlvx (i, n - 1)
+ endif
+ ptem = gotvx (i, n) * (thvx (i, k) - tem1) * dz
+ ! ptem = gotvx (i, n) * (thlvx (i, k) - tem1) * dz
+ bsum = bsum + ptem
+ zldn = zldn + dz
+ if (bsum >= tke (i, k)) then
+ if (ptem >= 0.) then
+ tem2 = max (ptem, zfmin)
+ else
+ tem2 = min (ptem, - zfmin)
+ endif
+ ptem1 = (bsum - tke (i, k)) / tem2
+ zldn = zldn - ptem1 * dz
+ zldn = max (zldn, 0.)
+ mlenflg = .false.
+ endif
+ endif
+ enddo
+
+ tem = 0.5 * (zi (i, k + 1) - zi (i, k))
+ tem1 = min (tem, rlmn)
+
+ ptem2 = min (zlup, zldn)
+ rlam (i, k) = elmfac * ptem2
+ rlam (i, k) = max (rlam (i, k), tem1)
+ rlam (i, k) = min (rlam (i, k), rlmx)
+
+ ptem2 = sqrt (zlup * zldn)
+ ele (i, k) = elefac * ptem2
+ ele (i, k) = max (ele (i, k), tem1)
+ ele (i, k) = min (ele (i, k), elmx)
+
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ tem = vk * zl (i, k)
+ if (zol (i) < 0.) then
+ ptem = 1. - 100. * zol (i)
+ ptem1 = ptem ** 0.2
+ zk = tem * ptem1
+ elseif (zol (i) >= 1.) then
+ zk = tem / 3.7
+ else
+ ptem = 1. + 2.7 * zol (i)
+ zk = tem / ptem
+ endif
+ elm (i, k) = zk * rlam (i, k) / (rlam (i, k) + zk)
+
+ dz = zi (i, k + 1) - zi (i, k)
+ tem = max (gdx (i), dz)
+ elm (i, k) = min (elm (i, k), tem)
+ ele (i, k) = min (ele (i, k), tem)
+
+ enddo
+ enddo
+ do i = 1, im
+ elm (i, km) = elm (i, km1)
+ ele (i, km) = ele (i, km1)
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute eddy diffusivities
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ tem = 0.5 * (elm (i, k) + elm (i, k + 1))
+ tem = tem * sqrt (tkeh (i, k))
+ if (k < kpbl (i)) then
+ if (pblflg (i)) then
+ dku (i, k) = ckz (i, k) * tem
+ dkt (i, k) = dku (i, k) / prn (i, k)
+ else
+ dkt (i, k) = chz (i, k) * tem
+ dku (i, k) = dkt (i, k) * prn (i, k)
+ endif
+ else
+ ri = max (bf (i, k) / shr2 (i, k), rimin)
+ if (ri < 0.) then ! unstable regime
+ dku (i, k) = ck1 * tem
+ dkt (i, k) = rchck * dku (i, k)
+ else ! stable regime
+ dkt (i, k) = ch1 * tem
+ prnum = 1.0 + 2.1 * ri
+ prnum = min (prnum, prmax)
+ dku (i, k) = dkt (i, k) * prnum
+ endif
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ tem1 = ckz (i, k) * tem
+ ptem1 = tem1 / prscu
+ dku (i, k) = max (dku (i, k), tem1)
+ dkt (i, k) = max (dkt (i, k), ptem1)
+ endif
+ endif
+
+ dkq (i, k) = prtke * dkt (i, k)
+
+ dkt (i, k) = min (dkt (i, k), dkmax)
+ dkt (i, k) = max (dkt (i, k), xkzo (i, k))
+ dkq (i, k) = min (dkq (i, k), dkmax)
+ dkq (i, k) = max (dkq (i, k), xkzo (i, k))
+ dku (i, k) = min (dku (i, k), dkmax)
+ dku (i, k) = max (dku (i, k), xkzmo (i, k))
+
+ enddo
+ enddo
+
+ do i = 1, im
+ if (scuflg (i)) then
+ k = krad (i)
+ tem = bf (i, k) / gotvx (i, k)
+ tem1 = max (tem, tdzmin)
+ ptem = radj (i) / tem1
+ dkt (i, k) = dkt (i, k) + ptem
+ dku (i, k) = dku (i, k) + ptem
+ dkq (i, k) = dkq (i, k) + ptem
+ endif
+ enddo
+
+ if (present (dkt_out)) then
+ do k = 1, km1
+ do i = 1, im
+ dkt_out (i, k) = dkt (i, k)
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy and shear productions of tke
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k == 1) then
+ tem = - dkt (i, 1) * bf (i, 1)
+ ! if (pcnvflg (i)) then
+ ! ptem1 = xmf (i, 1) * buou (i, 1)
+ ! else
+ ptem1 = 0.
+ ! endif
+ if (scuflg (i) .and. mrad (i) == 1) then
+ ptem2 = xmfd (i, 1) * buod (i, 1)
+ else
+ ptem2 = 0.
+ endif
+ tem = tem + ptem1 + ptem2
+ buop = 0.5 * (gotvx (i, 1) * sflux (i) + tem)
+
+ tem1 = dku (i, 1) * shr2 (i, 1)
+
+ tem = (u1 (i, 2) - u1 (i, 1)) * rdzt (i, 1)
+ ! if (pcnvflg (i)) then
+ ! ptem = xmf (i, 1) * tem
+ ! ptem1 = 0.5 * ptem * (u1 (i, 2) - ucko (i, 2))
+ ! else
+ ptem1 = 0.
+ ! endif
+ if (scuflg (i) .and. mrad (i) == 1) then
+ ptem = ucdo (i, 1) + ucdo (i, 2) - u1 (i, 1) - u1 (i, 2)
+ ptem = 0.5 * tem * xmfd (i, 1) * ptem
+ else
+ ptem = 0.
+ endif
+ ptem1 = ptem1 + ptem
+
+ tem = (v1 (i, 2) - v1 (i, 1)) * rdzt (i, 1)
+ ! if (pcnvflg (i)) then
+ ! ptem = xmf (i, 1) * tem
+ ! ptem2 = 0.5 * ptem * (v1 (i, 2) - vcko (i, 2))
+ ! else
+ ptem2 = 0.
+ ! endif
+ if (scuflg (i) .and. mrad (i) == 1) then
+ ptem = vcdo (i, 1) + vcdo (i, 2) - v1 (i, 1) - v1 (i, 2)
+ ptem = 0.5 * tem * xmfd (i, 1) * ptem
+ else
+ ptem = 0.
+ endif
+ ptem2 = ptem2 + ptem
+
+ ! tem2 = stress (i) * spd1 (i) / zl (i, 1)
+ tem2 = stress (i) * ustar (i) * phim (i) / (vk * zl (i, 1))
+ shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2)
+ else
+ tem1 = - dkt (i, k - 1) * bf (i, k - 1)
+ tem2 = - dkt (i, k) * bf (i, k)
+ tem = 0.5 * (tem1 + tem2)
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ ptem = 0.5 * (xmf (i, k - 1) + xmf (i, k))
+ ptem1 = ptem * buou (i, k)
+ else
+ ptem1 = 0.
+ endif
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem0 = 0.5 * (xmfd (i, k - 1) + xmfd (i, k))
+ ptem2 = ptem0 * buod (i, k)
+ else
+ ptem2 = 0.
+ endif
+ else
+ ptem2 = 0.
+ endif
+ buop = tem + ptem1 + ptem2
+
+ tem1 = dku (i, k - 1) * shr2 (i, k - 1)
+ tem2 = dku (i, k) * shr2 (i, k)
+ tem = 0.5 * (tem1 + tem2)
+ tem1 = (u1 (i, k + 1) - u1 (i, k)) * rdzt (i, k)
+ tem2 = (u1 (i, k) - u1 (i, k - 1)) * rdzt (i, k - 1)
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ ptem = xmf (i, k) * tem1 + xmf (i, k - 1) * tem2
+ ptem1 = 0.5 * ptem * (u1 (i, k) - ucko (i, k))
+ else
+ ptem1 = 0.
+ endif
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem0 = xmfd (i, k) * tem1 + xmfd (i, k - 1) * tem2
+ ptem2 = 0.5 * ptem0 * (ucdo (i, k) - u1 (i, k))
+ else
+ ptem2 = 0.
+ endif
+ else
+ ptem2 = 0.
+ endif
+ shrp = tem + ptem1 + ptem2
+ tem1 = (v1 (i, k + 1) - v1 (i, k)) * rdzt (i, k)
+ tem2 = (v1 (i, k) - v1 (i, k - 1)) * rdzt (i, k - 1)
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ ptem = xmf (i, k) * tem1 + xmf (i, k - 1) * tem2
+ ptem1 = 0.5 * ptem * (v1 (i, k) - vcko (i, k))
+ else
+ ptem1 = 0.
+ endif
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem0 = xmfd (i, k) * tem1 + xmfd (i, k - 1) * tem2
+ ptem2 = 0.5 * ptem0 * (vcdo (i, k) - v1 (i, k))
+ else
+ ptem2 = 0.
+ endif
+ else
+ ptem2 = 0.
+ endif
+ shrp = shrp + ptem1 + ptem2
+ endif
+ prod (i, k) = buop + shrp
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! first predict tke due to tke production & dissipation (diss)
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ rle (i, k) = ce0 / ele (i, k)
+ enddo
+ enddo
+ kk = max (nint (dt2 / cdtn), 1)
+ dtn = dt2 / float (kk)
+ do n = 1, kk
+ do k = 1, km1
+ do i = 1, im
+ tem = sqrt (tke (i, k))
+ diss (i, k) = rle (i, k) * tke (i, k) * tem
+ tem1 = prod (i, k) + tke (i, k) / dtn
+ diss (i, k) = max (min (diss (i, k), tem1), 0.)
+ tke (i, k) = tke (i, k) + dtn * (prod (i, k) - diss (i, k)) ! no diffusion yet
+ tke (i, k) = max (tke (i, k), tkmin)
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft & downdraft properties for tke
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (pcnvflg (i)) then
+ ! kgao change
+ ! qcko (i, k, ntke) = tke (i, k)
+ qcko (i, k, ntrac) = tke (i, k)
+ endif
+ if (scuflg (i)) then
+ ! kgao change
+ ! qcdo (i, k, ntke) = tke (i, k)
+ qcdo (i, k, ntrac) = tke (i, k)
+ endif
+ enddo
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+ ! kgao change
+ ! qcko (i, k, ntke) = ((1. - tem) * qcko (i, k - 1, ntke) + tem * &
+ ! (tke (i, k) + tke (i, k - 1))) / factor
+ qcko (i, k, ntrac) = ((1. - tem) * qcko (i, k - 1, ntrac) + tem * &
+ (tke (i, k) + tke (i, k - 1))) / factor
+ endif
+ enddo
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (scuflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+ ! kgao change
+ ! qcdo (i, k, ntke) = ((1. - tem) * qcdo (i, k + 1, ntke) + tem * &
+ ! (tke (i, k) + tke (i, k + 1))) / factor
+ qcdo (i, k, ntrac) = ((1. - tem) * qcdo (i, k + 1, ntrac) + tem * &
+ (tke (i, k) + tke (i, k + 1))) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute tridiagonal matrix elements for turbulent kinetic energy
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ad (i, 1) = 1.0
+ f1 (i, 1) = tke (i, 1)
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ rdz = rdzt (i, k)
+ tem1 = dsig * dkq (i, k) * rdz
+ dsdz2 = tem1 * rdz
+ au (i, k) = - dtodsd * dsdz2
+ al (i, k) = - dtodsu * dsdz2
+ ad (i, k) = ad (i, k) - au (i, k)
+ ad (i, k + 1) = 1. - al (i, k)
+ tem2 = dsig * rdz
+
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ ptem = 0.5 * tem2 * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = tke (i, k) + tke (i, k + 1)
+ ! kgao change
+ ! ptem = qcko (i, k, ntke) + qcko (i, k + 1, ntke)
+ ptem = qcko (i, k, ntrac) + qcko (i, k + 1, ntrac)
+ f1 (i, k) = f1 (i, k) - (ptem - tem) * ptem1
+ f1 (i, k + 1) = tke (i, k + 1) + (ptem - tem) * ptem2
+ else
+ f1 (i, k + 1) = tke (i, k + 1)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem = 0.5 * tem2 * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = tke (i, k) + tke (i, k + 1)
+ ! kgao change
+ ! ptem = qcdo (i, k, ntke) + qcdo (i, k + 1, ntke)
+ ptem = qcdo (i, k, ntrac) + qcdo (i, k + 1, ntrac)
+ f1 (i, k) = f1 (i, k) + (ptem - tem) * ptem1
+ f1 (i, k + 1) = f1 (i, k + 1) - (ptem - tem) * ptem2
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! solve tridiagonal problem for tke
+ ! -----------------------------------------------------------------------
+
+ call tridit (im, km, 1, al, ad, au, f1, au, f1)
+
+ ! -----------------------------------------------------------------------
+ ! recover tendency of tke
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ ! fix negative tke
+ f1 (i, k) = max (f1 (i, k), tkmin)
+ q1g (i, k, ntrac) = f1 (i, k)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute tridiagonal matrix elements for heat and moisture (and other tracers, except tke)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ad (i, 1) = 1.
+ f1 (i, 1) = t1 (i, 1) + dtdz1 (i) * heat (i)
+ f2 (i, 1) = q1g (i, 1, 1) + dtdz1 (i) * evap (i)
+ enddo
+ if (ntrac1 >= 2) then
+ do kk = 2, ntrac1
+ is = (kk - 1) * km
+ do i = 1, im
+ f2 (i, 1 + is) = q1g (i, 1, kk)
+ enddo
+ enddo
+ endif
+
+ do k = 1, km1
+ do i = 1, im
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ rdz = rdzt (i, k)
+ tem1 = dsig * dkt (i, k) * rdz
+ dsdzt = tem1 * gocp
+ dsdz2 = tem1 * rdz
+ au (i, k) = - dtodsd * dsdz2
+ al (i, k) = - dtodsu * dsdz2
+ ad (i, k) = ad (i, k) - au (i, k)
+ ad (i, k + 1) = 1. - al (i, k)
+ tem2 = dsig * rdz
+
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ ptem = 0.5 * tem2 * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = t1 (i, k) + t1 (i, k + 1)
+ ptem = tcko (i, k) + tcko (i, k + 1)
+ f1 (i, k) = f1 (i, k) + dtodsd * dsdzt - (ptem - tem) * ptem1
+ f1 (i, k + 1) = t1 (i, k + 1) - dtodsu * dsdzt + (ptem - tem) * ptem2
+ tem = q1g (i, k, 1) + q1g (i, k + 1, 1)
+ ptem = qcko (i, k, 1) + qcko (i, k + 1, 1)
+ f2 (i, k) = f2 (i, k) - (ptem - tem) * ptem1
+ f2 (i, k + 1) = q1g (i, k + 1, 1) + (ptem - tem) * ptem2
+ else
+ f1 (i, k) = f1 (i, k) + dtodsd * dsdzt
+ f1 (i, k + 1) = t1 (i, k + 1) - dtodsu * dsdzt
+ f2 (i, k + 1) = q1g (i, k + 1, 1)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem = 0.5 * tem2 * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ ptem = tcdo (i, k) + tcdo (i, k + 1)
+ tem = t1 (i, k) + t1 (i, k + 1)
+ f1 (i, k) = f1 (i, k) + (ptem - tem) * ptem1
+ f1 (i, k + 1) = f1 (i, k + 1) - (ptem - tem) * ptem2
+ tem = q1g (i, k, 1) + q1g (i, k + 1, 1)
+ ptem = qcdo (i, k, 1) + qcdo (i, k + 1, 1)
+ f2 (i, k) = f2 (i, k) + (ptem - tem) * ptem1
+ f2 (i, k + 1) = f2 (i, k + 1) - (ptem - tem) * ptem2
+ endif
+ endif
+ enddo
+ enddo
+
+ if (ntrac1 >= 2) then
+ do kk = 2, ntrac1
+ is = (kk - 1) * km
+ do k = 1, km1
+ do i = 1, im
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ tem = dsig * rdzt (i, k)
+ ptem = 0.5 * tem * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem1 = qcko (i, k, kk) + qcko (i, k + 1, kk)
+ tem2 = q1g (i, k, kk) + q1g (i, k + 1, kk)
+ ! kgao note - turn off non - local mixing
+ f2 (i, k + is) = f2 (i, k + is) ! - (tem1 - tem2) * ptem1
+ f2 (i, k + 1 + is) = q1g (i, k + 1, kk) ! + (tem1 - tem2) * ptem2
+ else
+ f2 (i, k + 1 + is) = q1g (i, k + 1, kk)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ tem = dsig * rdzt (i, k)
+ ptem = 0.5 * tem * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem1 = qcdo (i, k, kk) + qcdo (i, k + 1, kk)
+ tem2 = q1g (i, k, kk) + q1g (i, k + 1, kk)
+ ! kgao note - turn off non - local mixing
+ f2 (i, k + is) = f2 (i, k + is) ! + (tem1 - tem2) * ptem1
+ f2 (i, k + 1 + is) = f2 (i, k + 1 + is) ! - (tem1 - tem2) * ptem2
+ endif
+ endif
+
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! solve tridiagonal problem for heat and moisture
+ ! -----------------------------------------------------------------------
+
+ call tridin (im, km, ntrac1, al, ad, au, f1, f2, au, f1, f2)
+
+ ! -----------------------------------------------------------------------
+ ! recover tendencies of heat and moisture
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ tdt (i, k) = (f1 (i, k) - t1 (i, k)) * rdt
+ qdt (i, k) = (f2 (i, k) - q1g (i, k, 1)) * rdt
+ if (present (dtsfc)) dtsfc (i) = dtsfc (i) + cont * del (i, k) * tdt (i, k)
+ if (present (dqsfc)) dqsfc (i) = dqsfc (i) + conq * del (i, k) * qdt (i, k)
+ t1 (i, k) = f1 (i, k)
+ q1g (i, k, 1) = f2 (i, k)
+ enddo
+ enddo
+
+ if (ntrac1 >= 2) then
+ do kk = 2, ntrac1
+ is = (kk - 1) * km
+ do k = 1, km
+ do i = 1, im
+ q1g (i, k, kk) = f2 (i, k + is)
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! kgao note - rearrange tracer tendencies
+ ! -----------------------------------------------------------------------
+
+ !if (ntrac >= 3) then
+ if (ntke == ntrac) then ! tke is the last tracer
+ q1 (:, :, :) = q1g (:, :, :)
+ else ! tke is not
+ do kk = 1, ntke - 1
+ q1 (:, :, kk) = q1g (:, :, kk)
+ enddo
+ q1 (:, :, ntke) = q1g (:, :, ntrac)
+ do kk = ntke + 1, ntrac
+ q1 (:, :, kk) = q1g (:, :, kk - 1)
+ enddo
+ endif
+ !endif
+
+ ! -----------------------------------------------------------------------
+ ! add tke dissipative heating to temperature tendency
+ ! -----------------------------------------------------------------------
+
+ if (dspheat) then
+ do k = 1, km1
+ do i = 1, im
+ ! tem = min (diss (i, k), dspmax)
+ ! ttend = tem / cp_air
+ ttend = diss (i, k) / cp_air
+ t1 (i, k) = t1 (i, k) + dspfac * ttend * dt2
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute tridiagonal matrix elements for momentum
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ad (i, 1) = 1.0 + dtdz1 (i) * stress (i) / spd1 (i)
+ f1 (i, 1) = u1 (i, 1)
+ f2 (i, 1) = v1 (i, 1)
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ rdz = rdzt (i, k)
+ tem1 = dsig * dku (i, k) * rdz
+ dsdz2 = tem1 * rdz
+ au (i, k) = - dtodsd * dsdz2
+ al (i, k) = - dtodsu * dsdz2
+ ad (i, k) = ad (i, k) - au (i, k)
+ ad (i, k + 1) = 1. - al (i, k)
+ tem2 = dsig * rdz
+
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ ptem = 0.5 * tem2 * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = u1 (i, k) + u1 (i, k + 1)
+ ptem = ucko (i, k) + ucko (i, k + 1)
+ f1 (i, k) = f1 (i, k) - (ptem - tem) * ptem1
+ f1 (i, k + 1) = u1 (i, k + 1) + (ptem - tem) * ptem2
+ tem = v1 (i, k) + v1 (i, k + 1)
+ ptem = vcko (i, k) + vcko (i, k + 1)
+ f2 (i, k) = f2 (i, k) - (ptem - tem) * ptem1
+ f2 (i, k + 1) = v1 (i, k + 1) + (ptem - tem) * ptem2
+ else
+ f1 (i, k + 1) = u1 (i, k + 1)
+ f2 (i, k + 1) = v1 (i, k + 1)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem = 0.5 * tem2 * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = u1 (i, k) + u1 (i, k + 1)
+ ptem = ucdo (i, k) + ucdo (i, k + 1)
+ f1 (i, k) = f1 (i, k) + (ptem - tem) * ptem1
+ f1 (i, k + 1) = f1 (i, k + 1) - (ptem - tem) * ptem2
+ tem = v1 (i, k) + v1 (i, k + 1)
+ ptem = vcdo (i, k) + vcdo (i, k + 1)
+ f2 (i, k) = f2 (i, k) + (ptem - tem) * ptem1
+ f2 (i, k + 1) = f2 (i, k + 1) - (ptem - tem) * ptem2
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! solve tridiagonal problem for momentum
+ ! -----------------------------------------------------------------------
+
+ call tridi2 (im, km, al, ad, au, f1, f2, au, f1, f2)
+
+ ! -----------------------------------------------------------------------
+ ! recover tendencies of momentum
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ udt (i, k) = (f1 (i, k) - u1 (i, k)) * rdt
+ vdt (i, k) = (f2 (i, k) - v1 (i, k)) * rdt
+ if (present (dusfc)) dusfc (i) = dusfc (i) + conw * del (i, k) * udt (i, k)
+ if (present (dvsfc)) dvsfc (i) = dvsfc (i) + conw * del (i, k) * vdt (i, k)
+ u1 (i, k) = f1 (i, k)
+ v1 (i, k) = f2 (i, k)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! pbl height for diagnostic purpose
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ hpbl (i) = hpblx (i)
+ kpbl (i) = kpblx (i)
+ enddo
+
+ return
+
+end subroutine sa_tke_edmf_pbl
+
+! =======================================================================
+! subroutine to calcualte surface variables for PBL
+! =======================================================================
+
+subroutine sa_tke_edmf_sfc (im, lsoil, ps, u1, v1, t1, q1, &
+ delt, tsurf, prsl1, prslki, evap, hflx, fm, fh, &
+ z1, snwdph, zorl, ztrl, islimsk, ustar, sigmaf, &
+ vegtype, shdmax, sfcemis, dlwflx, sfcnsw, &
+ sfcdsw, srflag, hice, fice, tice, weasd, &
+ tprcp, stc, qsurf, cmm, chh, gflux, ep, &
+ u10m_out, v10m_out, t2m_out, q2m_out, &
+ cm_out, ch_out, rb_out, stress_out, wind_out)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, lsoil
+
+ integer, intent (in) :: islimsk (im), vegtype (im)
+
+ real, intent (in) :: delt
+
+ real, intent (in) :: ps (im), u1 (im), v1 (im), t1 (im), q1 (im), &
+ prslki (im), z1 (im), prsl1 (im), sigmaf (im), shdmax (im), &
+ sfcemis (im), dlwflx (im), sfcnsw (im), sfcdsw (im), srflag (im)
+
+ real, intent (inout) :: fm (im), fh (im), zorl (im), ztrl (im), ustar (im), snwdph (im), &
+ hice (im), fice (im), tice (im), weasd (im), tprcp (im), stc (im, lsoil), &
+ evap (im), hflx (im), tsurf (im), qsurf (im), cmm (im), chh (im), &
+ gflux (im), ep (im)
+
+ real, intent (out), optional :: u10m_out (im), v10m_out (im), &
+ t2m_out (im), q2m_out (im), cm_out (im), ch_out (im), rb_out (im), &
+ stress_out (im), wind_out (im)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ logical :: mom4ice = .false.
+
+ integer :: lsm = 1
+
+ real :: fm10 (im), fh2 (im), u10m (im), v10m (im), t2m (im), q2m (im), &
+ cm (im), ch (im), rb (im), stress (im), wind (im), snowmt (im)
+
+ ! -----------------------------------------------------------------------
+ ! calculate surface exchange coefficients and near-surface wind
+ ! -----------------------------------------------------------------------
+
+ if ( sfc_gfdl ) then
+
+ call sfc_exch_gfdl (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, ztrl, cm, ch, rb, &
+ prsl1, prslki, islimsk, stress, fm, fh, &
+ ustar, wind, fm10, fh2, sigmaf, vegtype, shdmax)
+
+ else
+
+ call sfc_exch (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, cm, ch, rb, &
+ prsl1, prslki, islimsk, stress, fm, fh, &
+ ustar, wind, fm10, fh2, sigmaf, vegtype, shdmax)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! surface energy balance over ocean
+ ! -----------------------------------------------------------------------
+
+ call sfc_ocea (im, ps, u1, v1, t1, q1, tsurf, cm, ch, &
+ prsl1, prslki, islimsk, qsurf, cmm, chh, gflux, evap, hflx, ep)
+
+ ! -----------------------------------------------------------------------
+ ! surface energy balance over land
+ ! -----------------------------------------------------------------------
+
+ ! TBD
+
+ ! -----------------------------------------------------------------------
+ ! surface energy balance over seaice
+ ! -----------------------------------------------------------------------
+
+ call sfc_seai (im, lsoil, ps, u1, v1, t1, q1, delt, &
+ sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, &
+ cm, ch, prsl1, prslki, islimsk, mom4ice, lsm, &
+ hice, fice, tice, weasd, tsurf, tprcp, stc, ep, &
+ snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx)
+
+ ! -----------------------------------------------------------------------
+ ! update near surface fields
+ ! -----------------------------------------------------------------------
+
+ call sfc_updt (im, ps, u1, v1, t1, q1, &
+ tsurf, qsurf, u10m, v10m, t2m, q2m, &
+ prslki, evap, fm, fh, fm10, fh2)
+
+ ! -----------------------------------------------------------------------
+ ! optional output
+ ! -----------------------------------------------------------------------
+
+ if (present (u10m_out)) u10m_out = u10m
+ if (present (v10m_out)) v10m_out = v10m
+ if (present (t2m_out)) t2m_out = t2m
+ if (present (q2m_out)) q2m_out = q2m
+ if (present (cm_out)) cm_out = cm
+ if (present (ch_out)) ch_out = ch
+ if (present (rb_out)) rb_out = rb
+ if (present (stress_out)) stress_out = stress
+ if (present (wind_out)) wind_out = wind
+
+end subroutine sa_tke_edmf_sfc
+
+! =======================================================================
+! subroutine to calculate surface exchange coefficients and near-surface wind
+! =======================================================================
+
+subroutine sfc_exch (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, cm, ch, rb, &
+ prsl1, prslki, islimsk, stress, fm, fh, &
+ ustar, wind, fm10, fh2, sigmaf, vegtype, shdmax)
+
+ implicit none
+
+ integer im
+ real, dimension (im) :: ps, u1, v1, t1, q1, z1, &
+ tsurf, zorl, cm, ch, rb, &
+ prsl1, prslki, stress, &
+ fm, fh, ustar, wind, ddvel, &
+ fm10, fh2, sigmaf, shdmax, &
+ snwdph
+ integer, dimension (im) :: vegtype, islimsk
+
+ logical flag_iter (im) ! added by s.lu
+
+ ! locals
+
+ integer i
+
+ real :: aa, aa0, bb, bb0, dtv, adtv, qs1, &
+ hl1, hl12, pm, ph, pm10, ph2, rat, &
+ thv1, tvs, z1i, z0, z0max, ztmax, &
+ fms, fhs, hl0, hl0inf, hlinf, &
+ hl110, hlt, hltinf, olinf, &
+ restar, tem1, tem2, ztmax1, &
+ z0_adj, wind_th_moon, ustar_th, a, b, c, & !kgao
+ u10m, v10m, ws10m !kgao
+
+ real, parameter :: &
+ charnock = .014, ca = .4, & ! ca - von karman constant
+ alpha = 5., a0 = - 3.975, a1 = 12.32, alpha4 = 4.0 * alpha, &
+ b1 = - 7.755, b2 = 6.041, alpha2 = alpha + alpha, beta = 1.0, &
+ a0p = - 7.941, a1p = 24.75, b1p = - 8.705, b2p = 7.899, &
+ vis = 1.4e-5, rnu = 1.51e-5, visi = 1.0 / vis, &
+ log01 = log (0.01), log05 = log (0.05), log07 = log (0.07), &
+ ztmin1 = - 999.0, &
+ ! following is added by kgao
+ bs0 = - 8.367276172397277e-12, &
+ bs1 = 1.7398510865876079e-09, &
+ bs2 = - 1.331896578363359e-07, &
+ bs3 = 4.507055294438727e-06, &
+ bs4 = - 6.508676881906914e-05, &
+ bs5 = 0.00044745137674732834, &
+ bs6 = - 0.0010745704660847233, &
+ cf0 = 2.1151080765239772e-13, &
+ cf1 = - 3.2260663894433345e-11, &
+ cf2 = - 3.329705958751961e-10, &
+ cf3 = 1.7648562021709124e-07, &
+ cf4 = 7.107636825694182e-06, &
+ cf5 = - 0.0013914681964973246, &
+ cf6 = 0.0406766967657759, &
+ p13 = - 1.296521881682694e-02, &
+ p12 = 2.855780863283819e-01, &
+ p11 = - 1.597898515251717e+00, &
+ p10 = - 8.396975715683501e+00, &
+ p25 = 3.790846746036765e-10, &
+ p24 = 3.281964357650687e-09, &
+ p23 = 1.962282433562894e-07, &
+ p22 = - 1.240239171056262e-06, &
+ p21 = 1.739759082358234e-07, &
+ p20 = 2.147264020369413e-05, &
+ p35 = 1.840430200185075e-07, &
+ p34 = - 2.793849676757154e-05, &
+ p33 = 1.735308193700643e-03, &
+ p32 = - 6.139315534216305e-02, &
+ p31 = 1.255457892775006e+00, &
+ p30 = - 1.663993561652530e+01, &
+ p40 = 4.579369142033410e-04
+
+ ! parameter (charnock = .014, ca = .4) !c ca is the von karman constant
+ ! parameter (alpha = 5., a0 = - 3.975, a1 = 12.32, b1 = - 7.755, b2 = 6.041)
+ ! parameter (a0p = - 7.941, a1p = 24.75, b1p = - 8.705, b2p = 7.899, vis = 1.4e-5)
+
+ ! real aa1, bb1, bb2, cc, cc1, cc2, arnu
+ ! parameter (aa1 = - 1.076, bb1 = .7045, cc1 = - .05808)
+ ! parameter (bb2 = - .1954, cc2 = .009999)
+ ! parameter (arnu = .135 * rnu)
+
+ ! z0s_max = .196e-2 for u10_crit = 25 m / s
+ ! z0s_max = .317e-2 for u10_crit = 30 m / s
+ ! z0s_max = .479e-2 for u10_crit = 35 m / s
+
+ ! mbek -- toga - coare flux algorithm
+ ! parameter (rnu = 1.51e-5, arnu = 0.11 * rnu)
+
+ ! initialize variables. all units are supposedly m.k.s. unless specified
+ ! ps is in pascals, wind is wind speed,
+ ! surface roughness length is converted to m from cm
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+ if (flag_iter (i)) then
+ wind (i) = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+ tem1 = 1.0 + zvir * max (q1 (i), 1.e-8)
+ thv1 = t1 (i) * prslki (i) * tem1
+ tvs = 0.5 * (tsurf (i) + tsurf (i)) * tem1
+ qs1 = mqs (t1 (i))
+ qs1 = max (1.0e-8, eps * qs1 / (prsl1 (i) + epsm1 * qs1))
+
+ z0 = 0.01 * zorl (i)
+ z0max = max (1.0e-6, min (z0, z1 (i)))
+ z1i = 1.0 / z1 (i)
+
+ ! compute stability dependent exchange coefficients
+ ! this portion of the code is presently suppressed
+
+
+ if (islimsk (i) == 0) then ! over ocean
+ ustar (i) = sqrt (grav * z0 / charnock)
+
+ ! ** test xubin's new z0
+
+ ! ztmax = z0max
+
+ restar = max (ustar (i) * z0max * visi, 0.000001)
+
+ ! restar = log (restar)
+ ! restar = min (restar, 5.)
+ ! restar = max (restar, - 5.)
+ ! rat = aa1 + (bb1 + cc1 * restar) * restar
+ ! rat = rat / (1. + (bb2 + cc2 * restar) * restar))
+ ! rat taken from zeng, zhao and dickinson 1997
+
+ rat = min (7.0, 2.67 * sqrt (sqrt (restar)) - 2.57)
+ ztmax = z0max * exp (- rat)
+
+ else ! over land and sea ice
+ ! ** xubin's new z0 over land and sea ice
+ tem1 = 1.0 - shdmax (i)
+ tem2 = tem1 * tem1
+ tem1 = 1.0 - tem2
+
+ if (ivegsrc == 1) then
+
+ if (vegtype (i) == 10) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 6) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 7) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 16) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ elseif (ivegsrc == 2) then
+
+ if (vegtype (i) == 7) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 8) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 9) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 11) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ endif
+ z0max = max (z0max, 1.0e-6)
+
+ ! czilc = 10.0 ** (- (0.40 / 0.07) * z0) ! fei's canopy height dependance of czil
+ ! czilc = 0.8
+
+ tem1 = 1.0 - sigmaf (i)
+ ztmax = z0max * exp (- tem1 * tem1 &
+ * czilc * ca * sqrt (ustar (i) * (0.01 / 1.5e-05)))
+
+ endif ! end of if (islimsk (i) == 0) then
+
+ ztmax = max (ztmax, 1.0e-6)
+ tem1 = z0max / z1 (i)
+ if (abs (1.0 - tem1) > 1.0e-6) then
+ ztmax1 = - beta * log (tem1) / (alpha2 * (1. - tem1))
+ else
+ ztmax1 = 99.0
+ endif
+ if (z0max < 0.05 .and. snwdph (i) < 10.0) ztmax1 = 99.0
+
+
+ ! compute stability indices (rb and hlinf)
+
+ dtv = thv1 - tvs
+ adtv = max (abs (dtv), 0.001)
+ dtv = sign (1., dtv) * adtv
+ rb (i) = max (- 5000.0, (grav + grav) * dtv * z1 (i) &
+ / ((thv1 + tvs) * wind (i) * wind (i)))
+ tem1 = 1.0 / z0max
+ tem2 = 1.0 / ztmax
+ fm (i) = log ((z0max + z1 (i)) * tem1)
+ fh (i) = log ((ztmax + z1 (i)) * tem2)
+ fm10 (i) = log ((z0max + 10.) * tem1)
+ fh2 (i) = log ((ztmax + 2.) * tem2)
+ hlinf = rb (i) * fm (i) * fm (i) / fh (i)
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+
+ ! stable case
+
+ if (dtv >= 0.0) then
+ hl1 = hlinf
+ if (hlinf > .25) then
+ tem1 = hlinf * z1i
+ hl0inf = z0max * tem1
+ hltinf = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hlinf)
+ aa0 = sqrt (1. + alpha4 * hl0inf)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hltinf)
+ pm = aa0 - aa + log ((aa + 1.) / (aa0 + 1.))
+ ph = bb0 - bb + log ((bb + 1.) / (bb0 + 1.))
+ fms = fm (i) - pm
+ fhs = fh (i) - ph
+ hl1 = fms * fms * rb (i) / fhs
+ hl1 = min (max (hl1, ztmin1), ztmax1)
+ endif
+
+ ! second iteration
+
+ tem1 = hl1 * z1i
+ hl0 = z0max * tem1
+ hlt = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hl1)
+ aa0 = sqrt (1. + alpha4 * hl0)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hlt)
+ pm = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ ph = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ aa = sqrt (1. + alpha4 * hl110)
+ pm10 = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ! aa = sqrt (1. + alpha4 * hl12)
+ bb = sqrt (1. + alpha4 * hl12)
+ ph2 = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+
+ ! unstable case - check for unphysical obukhov length
+
+ else ! dtv < 0 case
+ olinf = z1 (i) / hlinf
+ tem1 = 50.0 * z0max
+ if (abs (olinf) <= tem1) then
+ hlinf = - z1 (i) / tem1
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+ endif
+
+ ! get pm and ph
+
+ if (hlinf >= - 0.5) then
+ hl1 = hlinf
+ pm = (a0 + a1 * hl1) * hl1 / (1. + (b1 + b2 * hl1) * hl1)
+ ph = (a0p + a1p * hl1) * hl1 / (1. + (b1p + b2p * hl1) * hl1)
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = (a0 + a1 * hl110) * hl110 / (1. + (b1 + b2 * hl110) * hl110)
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = (a0p + a1p * hl12) * hl12 / (1. + (b1p + b2p * hl12) * hl12)
+ else ! hlinf < 0.05
+ hl1 = - hlinf
+ tem1 = 1.0 / sqrt (hl1)
+ pm = log (hl1) + 2. * sqrt (tem1) - .8776
+ ph = log (hl1) + .5 * tem1 + 1.386
+ ! pm = log (hl1) + 2.0 * hl1 ** (- .25) - .8776
+ ! ph = log (hl1) + 0.5 * hl1 ** (- .5) + 1.386
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = log (hl110) + 2.0 / sqrt (sqrt (hl110)) - .8776
+ ! pm10 = log (hl110) + 2. * hl110 ** (- .25) - .8776
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = log (hl12) + 0.5 / sqrt (hl12) + 1.386
+ ! ph2 = log (hl12) + .5 * hl12 ** (- .5) + 1.386
+ endif
+
+ endif ! end of if (dtv >= 0) then loop
+
+ ! finish the exchange coefficient computation to provide fm and fh
+
+ fm (i) = fm (i) - pm
+ fh (i) = fh (i) - ph
+ fm10 (i) = fm10 (i) - pm10
+ fh2 (i) = fh2 (i) - ph2
+ cm (i) = ca * ca / (fm (i) * fm (i))
+ ch (i) = ca * ca / (fm (i) * fh (i))
+ tem1 = 0.00001 / z1 (i)
+ cm (i) = max (cm (i), tem1)
+ ch (i) = max (ch (i), tem1)
+ stress (i) = cm (i) * wind (i) * wind (i)
+ ustar (i) = sqrt (stress (i))
+
+ ! update z0 over ocean
+
+ if (islimsk (i) == 0) then
+
+ z0 = (charnock / grav) * ustar (i) * ustar (i)
+
+ ! mbek -- toga - coare flux algorithm
+ ! z0 = (charnock / grav) * ustar (i) * ustar (i) + arnu / ustar (i)
+ ! new implementation of z0
+ ! cc = ustar (i) * z0 / rnu
+ ! pp = cc / (1. + cc)
+ ! ff = grav * arnu / (charnock * ustar (i) ** 3)
+ ! z0 = arnu / (ustar (i) * ff ** pp)
+
+ ! -------------------------- modify z0 by kgao
+
+ ! diagnose 10m wind (same as sfc_diag.f)
+
+ u10m = u1 (i) * fm10 (i) / fm (i)
+ v10m = v1 (i) * fm10 (i) / fm (i)
+ ws10m = sqrt (u10m * u10m + v10m * v10m)
+
+ ! option - uri / gfdl (hwrf 2015)
+ ! note there is discontinuity at 10m / s in original formulation
+ ! needs to be fixed
+
+ if (do_z0_hwrf15) then
+ if (ws10m <= 5.0) then
+ z0 = 0.0185 / 9.8 * (7.59e-4 * ws10m ** 2 + 2.46e-2 * ws10m) ** 2
+ elseif (ws10m > 5.0 .and. ws10m <= 10.) then
+ z0 = 0.00000235 * (ws10m ** 2 - 25.) + 3.805129199617346e-05
+ elseif (ws10m > 10.0 .and. ws10m <= 60.) then
+ z0 = bs6 + bs5 * ws10m + bs4 * ws10m ** 2 + bs3 * ws10m ** 3 &
+ + bs2 * ws10m ** 4 + bs1 * ws10m ** 5 + bs0 * ws10m ** 6
+ else
+ z0 = cf6 + cf5 * ws10m + cf4 * ws10m ** 2 + cf3 * ws10m ** 3 &
+ + cf2 * ws10m ** 4 + cf1 * ws10m ** 5 + cf0 * ws10m ** 6
+ endif
+ endif
+
+ ! option - hwrf 2017
+
+ if (do_z0_hwrf17) then
+ if (ws10m <= 6.5) then
+ z0 = exp (p10 + p11 * ws10m + p12 * ws10m ** 2 + p13 * ws10m ** 3)
+ elseif (ws10m > 6.5 .and. ws10m <= 15.7) then
+ z0 = p25 * ws10m ** 5 + p24 * ws10m ** 4 + p23 * ws10m ** 3 &
+ + p22 * ws10m ** 2 + p21 * ws10m + p20
+ elseif (ws10m > 15.7 .and. ws10m <= 53.) then
+ z0 = exp (p35 * ws10m ** 5 + p34 * ws10m ** 4 + p33 * ws10m ** 3 &
+ + p32 * ws10m ** 2 + p31 * ws10m + p30)
+ else
+ z0 = p40
+ endif
+ endif
+
+ ! option - gfs (low wind) + hwrf 2017 (high wind)
+
+ if (do_z0_hwrf17_hwonly) then
+
+ if (ws10m > wind_th_hwrf .and. ws10m <= 53.) then
+ z0 = exp (p35 * ws10m ** 5 + p34 * ws10m ** 4 + p33 * ws10m ** 3 &
+ + p32 * ws10m ** 2 + p31 * ws10m + p30)
+ elseif (ws10m > 53.) then
+ z0 = p40
+ endif
+
+ endif
+
+ ! option - gfs (low wind) + moon et al (high wind)
+
+ if (do_z0_moon) then
+ wind_th_moon = 20.
+ a = 0.56
+ b = - 20.255
+ c = wind_th_moon - 2.458
+ ustar_th = (- b - sqrt (b * b - 4 * a * c)) / (2 * a)
+
+ z0_adj = 0.001 * (0.085 * wind_th_moon - 0.58) - &
+ (charnock / grav) * ustar_th * ustar_th
+
+ ws10m = 2.458 + ustar (i) * (20.255 - 0.56 * ustar (i)) ! eq (7) moon et al. 2007
+ if (ws10m > wind_th_moon) then ! no modification in low wind conditions
+ z0 = 0.001 * (0.085 * ws10m - 0.58) - z0_adj ! eq (8b) moon et al. 2007 modified by kgao
+ endif
+ endif
+
+ ! ---------------------------- modify z0 end
+
+ if (redrag) then
+ zorl (i) = 100.0 * max (min (z0, z0s_max), 1.e-7)
+ else
+ zorl (i) = 100.0 * max (min (z0, .1), 1.e-7)
+ endif
+ endif
+ endif ! end of if (flagiter) loop
+ enddo
+
+end subroutine sfc_exch
+
+! =======================================================================
+! subroutine to calculate surface exchange coefficients and near-surface wind
+! Oct 2019 - a clean and updated version by Kun Gao at GFDL (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine sfc_exch_gfdl (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, ztrl, cm, ch, rb, &
+ prsl1, prslki, islimsk, &
+ stress, fm, fh, &
+ ustar, wind, fm10, fh2, &
+ sigmaf, vegtype, shdmax)
+
+ implicit none
+
+ ! --- input / output
+
+ integer im
+
+ real, dimension (im) :: ps, u1, v1, t1, q1, z1, &
+ zorl, ztrl, cm, ch, rb, &
+ prsl1, prslki, stress, &
+ fm, fh, ustar, wind, ddvel, &
+ fm10, fh2, sigmaf, shdmax, &
+ tsurf, snwdph
+
+ integer, dimension (im) :: vegtype, islimsk
+
+ logical flag_iter (im)
+
+ ! --- local
+
+ integer i
+
+ real :: aa, aa0, bb, bb0, dtv, adtv, qs1, &
+ hl1, hl12, pm, ph, pm10, ph2, rat, &
+ thv1, tvs, z1i, z0, zt, z0max, ztmax, &
+ fms, fhs, hl0, hl0inf, hlinf, &
+ hl110, hlt, hltinf, olinf, &
+ restar, czilc, tem1, tem2, &
+ u10m, v10m, ws10m, ws10m_moon, &
+ z0_1, zt_1, fm1, fh1, ustar_1, ztmax_1
+
+ real, parameter :: &
+ charnock = .014, ca = .4, &
+ vis = 1.4e-5, rnu = 1.51e-5, visi = 1.0 / vis, &
+ log01 = log (0.01), log05 = log (0.05), log07 = log (0.07), &
+ ztmin1 = - 999.0
+
+ ! ================================================
+ ! main program starts here
+ ! ================================================
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+
+ if (flag_iter (i)) then
+
+ ! --- get variables at model lowest layer and surface (water / ice / land)
+
+ wind (i) = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+ tem1 = 1.0 + zvir * max (q1 (i), 1.e-8)
+ thv1 = t1 (i) * prslki (i) * tem1
+ tvs = 0.5 * (tsurf (i) + tsurf (i)) * tem1
+ qs1 = mqs (t1 (i))
+ qs1 = max (1.0e-8, eps * qs1 / (prsl1 (i) + epsm1 * qs1))
+
+ ! (sea / land / ice mask = 0 / 1 / 2)
+ if (islimsk (i) == 1 .or. islimsk (i) == 2) then ! over land or sea ice
+
+ ! ================================================
+ ! if over land or sea ice:
+ ! step 1 - get z0 / zt
+ ! step 2 - call similarity
+ ! ================================================
+
+ ! --- get surface roughness for momentum (z0)
+
+ z0 = 0.01 * zorl (i)
+ z0max = max (1.0e-6, min (z0, z1 (i)))
+
+ !xubin's new z0 over land and sea ice
+ tem1 = 1.0 - shdmax (i) ! shdmax is max vegetation area fraction
+ tem2 = tem1 * tem1
+ tem1 = 1.0 - tem2
+
+ if (ivegsrc == 1) then
+
+ if (vegtype (i) == 10) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 6) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 7) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 16) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ elseif (ivegsrc == 2) then
+
+ if (vegtype (i) == 7) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 8) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 9) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 11) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ z0max = max (z0max, 1.0e-6)
+
+ endif
+
+ ! --- get surface roughness for heat (zt)
+
+ ! czilc = 10.0 ** (- (0.40 / 0.07) * z0) ! let czilc depend on canopy height
+ czilc = 0.8
+
+ tem1 = 1.0 - sigmaf (i)
+ ztmax = z0max * exp (- tem1 * tem1 * &
+ czilc * ca * sqrt (ustar (i) * (0.01 / 1.5e-05)))
+
+ ztmax = max (ztmax, 1.0e-6)
+
+ ! --- call similarity
+
+ call monin_obukhov_similarity &
+ (z1 (i), snwdph (i), thv1, wind (i), z0max, ztmax, tvs, &
+ rb (i), fm (i), fh (i), fm10 (i), fh2 (i), &
+ cm (i), ch (i), stress (i), ustar (i))
+
+ elseif (islimsk (i) == 0) then ! over water
+
+ ! ================================================
+ ! if over water (redesigned by kun gao)
+ ! iteration 1
+ ! step 1 get z0 / zt from previous step
+ ! step 2 call similarity
+ ! iteration 2
+ ! step 1 update z0 / zt
+ ! step 2 call similarity
+ ! ================================================
+
+ ! === iteration 1
+
+ ! --- get z0 / zt
+ z0 = 0.01 * zorl (i)
+ zt = 0.01 * ztrl (i)
+
+ z0max = max (1.0e-6, min (z0, z1 (i)))
+ ztmax = max (zt, 1.0e-6)
+
+ ! --- call similarity
+ call monin_obukhov_similarity &
+ (z1 (i), snwdph (i), thv1, wind (i), z0max, ztmax, tvs, &
+ rb (i), fm (i), fh (i), fm10 (i), fh2 (i), &
+ cm (i), ch (i), stress (i), ustar (i))
+
+ ! === iteration 2
+
+ ! --- get z0 / zt following the old sfc_diff.f
+ z0 = (charnock / grav) * ustar (i) * ustar (i)
+ if (redrag) then
+ z0 = max (min (z0, z0s_max), 1.e-7)
+ else
+ z0 = max (min (z0, .1), 1.e-7)
+ endif
+
+ ! zt calculations copied from old sfc_diff.f
+ !ustar (i) = sqrt (grav * z0 / charnock)
+ !restar = max (ustar (i) * z0max * visi, 0.000001)
+ !rat = min (7.0, 2.67 * sqrt (sqrt (restar)) - 2.57)
+ !ztmax = z0max * exp (- rat)
+
+ ustar_1 = sqrt (grav * z0 / charnock)
+ restar = max (ustar_1 * z0max * visi, 0.000001)
+ rat = min (7.0, 2.67 * sqrt (sqrt (restar)) - 2.57)
+ zt = z0max * exp (- rat) ! zeng, zhao and dickinson 1997 (eq 25)
+
+ ! --- update z0 / zt with new options
+ ! only z0 options in the following
+ ! will add zt options in the future
+
+ u10m = u1 (i) * fm10 (i) / fm (i)
+ v10m = v1 (i) * fm10 (i) / fm (i)
+ ws10m = sqrt (u10m * u10m + v10m * v10m)
+
+ if (do_z0_hwrf15) then
+ ! option 1: hwrf15, originally developed by uri / gfdl
+ call cal_z0_hwrf15 (ws10m, z0)
+ call cal_zt_hwrf15 (ws10m, zt)
+
+ elseif (do_z0_hwrf17) then
+ ! option 2: hwrf17
+ call cal_z0_hwrf17 (ws10m, z0)
+ call cal_zt_hwrf17 (ws10m, zt)
+
+ elseif (do_z0_hwrf17_hwonly) then
+ ! option 3: hwrf17 under high wind only
+ if (ws10m > wind_th_hwrf) then
+ call cal_z0_hwrf17 (ws10m, z0)
+ z0 = max (min (z0, z0s_max), 1.e-7) ! must apply limiter here
+ endif
+
+ elseif (do_z0_moon) then
+ ! option 4: moon et al 2007 under high winds (same as in hiram)
+ ws10m_moon = 2.458 + ustar (i) * (20.255 - 0.56 * ustar (i)) ! eq (7) moon et al. 2007
+ if (ws10m_moon > 20.) then
+ call cal_z0_moon (ws10m_moon, z0)
+ z0 = max (min (z0, z0s_max), 1.e-7) ! must apply limiter here
+ endif
+ endif
+
+ z0max = max (z0, 1.0e-6)
+ ztmax = max (zt, 1.0e-6)
+
+ ! --- call similarity
+ call monin_obukhov_similarity &
+ (z1 (i), snwdph (i), thv1, wind (i), z0max, ztmax, tvs, &
+ rb (i), fm (i), fh (i), fm10 (i), fh2 (i), &
+ cm (i), ch (i), stress (i), ustar (i))
+
+ zorl (i) = 100.0 * z0max
+ ztrl (i) = 100.0 * ztmax
+
+ endif ! end of if (islimsk) loop
+ endif ! end of if (flagiter) loop
+ enddo ! end of do i = 1, im loop
+
+ return
+
+end subroutine sfc_exch_gfdl
+
+! =======================================================================
+! Originally developed by URI/GFDL
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_z0_hwrf15 (ws10m, z0)
+
+ real :: ws10m, z0
+
+ real, parameter :: &
+ a0 = - 8.367276172397277e-12, &
+ a1 = 1.7398510865876079e-09, &
+ a2 = - 1.331896578363359e-07, &
+ a3 = 4.507055294438727e-06, &
+ a4 = - 6.508676881906914e-05, &
+ a5 = 0.00044745137674732834, &
+ a6 = - 0.0010745704660847233, &
+ b0 = 2.1151080765239772e-13, &
+ b1 = - 3.2260663894433345e-11, &
+ b2 = - 3.329705958751961e-10, &
+ b3 = 1.7648562021709124e-07, &
+ b4 = 7.107636825694182e-06, &
+ b5 = - 0.0013914681964973246, &
+ b6 = 0.0406766967657759
+
+ if (ws10m <= 5.0) then
+ z0 = 0.0185 / 9.8 * (7.59e-4 * ws10m ** 2 + 2.46e-2 * ws10m) ** 2
+ elseif (ws10m > 5.0 .and. ws10m <= 10.) then
+ z0 = 0.00000235 * (ws10m ** 2 - 25.) + 3.805129199617346e-05
+ elseif (ws10m > 10.0 .and. ws10m <= 60.) then
+ z0 = a6 + a5 * ws10m + a4 * ws10m ** 2 + a3 * ws10m ** 3 + &
+ a2 * ws10m ** 4 + a1 * ws10m ** 5 + a0 * ws10m ** 6
+ else
+ z0 = b6 + b5 * ws10m + b4 * ws10m ** 2 + b3 * ws10m ** 3 + &
+ b2 * ws10m ** 4 + b1 * ws10m ** 5 + b0 * ws10m ** 6
+ endif
+
+end subroutine cal_z0_hwrf15
+
+! =======================================================================
+! Originally developed by URI/GFDL
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_zt_hwrf15 (ws10m, zt)
+
+ real :: ws10m, zt
+
+ real, parameter :: &
+ a0 = 2.51715926619e-09, &
+ a1 = - 1.66917514012e-07, &
+ a2 = 4.57345863551e-06, &
+ a3 = - 6.64883696932e-05, &
+ a4 = 0.00054390175125, &
+ a5 = - 0.00239645231325, &
+ a6 = 0.00453024927761, &
+ b0 = - 1.72935914649e-14, &
+ b1 = 2.50587455802e-12, &
+ b2 = - 7.90109676541e-11, &
+ b3 = - 4.40976353607e-09, &
+ b4 = 3.68968179733e-07, &
+ b5 = - 9.43728336756e-06, &
+ b6 = 8.90731312383e-05, &
+ c0 = 4.68042680888e-14, &
+ c1 = - 1.98125754931e-11, &
+ c2 = 3.41357133496e-09, &
+ c3 = - 3.05130605309e-07, &
+ c4 = 1.48243563819e-05, &
+ c5 = - 0.000367207751936, &
+ c6 = 0.00357204479347
+
+ if (ws10m <= 7.0) then
+ zt = 0.0185 / 9.8 * (7.59e-4 * ws10m ** 2 + 2.46e-2 * ws10m) ** 2
+ elseif (ws10m > 7.0 .and. ws10m <= 15.) then
+ zt = a6 + a5 * ws10m + a4 * ws10m ** 2 + a3 * ws10m ** 3 + &
+ a2 * ws10m ** 4 + a1 * ws10m ** 5 + a0 * ws10m ** 6
+ elseif (ws10m > 15.0 .and. ws10m <= 60.) then
+ zt = b6 + b5 * ws10m + b4 * ws10m ** 2 + b3 * ws10m ** 3 + &
+ b2 * ws10m ** 4 + b1 * ws10m ** 5 + b0 * ws10m ** 6
+ else
+ zt = c6 + c5 * ws10m + c4 * ws10m ** 2 + c3 * ws10m ** 3 + &
+ c2 * ws10m ** 4 + c1 * ws10m ** 5 + c0 * ws10m ** 6
+ endif
+
+end subroutine cal_zt_hwrf15
+
+! =======================================================================
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_z0_hwrf17 (ws10m, z0)
+
+ real :: ws10m, z0
+
+ real, parameter :: &
+ p13 = - 1.296521881682694e-02, &
+ p12 = 2.855780863283819e-01, &
+ p11 = - 1.597898515251717e+00, &
+ p10 = - 8.396975715683501e+00, &
+ p25 = 3.790846746036765e-10, &
+ p24 = 3.281964357650687e-09, &
+ p23 = 1.962282433562894e-07, &
+ p22 = - 1.240239171056262e-06, &
+ p21 = 1.739759082358234e-07, &
+ p20 = 2.147264020369413e-05, &
+ p35 = 1.840430200185075e-07, &
+ p34 = - 2.793849676757154e-05, &
+ p33 = 1.735308193700643e-03, &
+ p32 = - 6.139315534216305e-02, &
+ p31 = 1.255457892775006e+00, &
+ p30 = - 1.663993561652530e+01, &
+ p40 = 4.579369142033410e-04
+
+ if (ws10m <= 6.5) then
+ z0 = exp (p10 + p11 * ws10m + p12 * ws10m ** 2 + p13 * ws10m ** 3)
+ elseif (ws10m > 6.5 .and. ws10m <= 15.7) then
+ z0 = p25 * ws10m ** 5 + p24 * ws10m ** 4 + p23 * ws10m ** 3 + &
+ p22 * ws10m ** 2 + p21 * ws10m + p20
+ elseif (ws10m > 15.7 .and. ws10m <= 53.) then
+ z0 = exp (p35 * ws10m ** 5 + p34 * ws10m ** 4 + p33 * ws10m ** 3 + &
+ p32 * ws10m ** 2 + p31 * ws10m + p30)
+ else
+ z0 = p40
+ endif
+
+end subroutine cal_z0_hwrf17
+
+! =======================================================================
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_zt_hwrf17 (ws10m, zt)
+
+ real :: ws10m, zt
+
+ real, parameter :: p00 = 1.100000000000000e-04, &
+ p15 = - 9.144581627678278e-10, p14 = 7.020346616456421e-08, &
+ p13 = - 2.155602086883837e-06, p12 = 3.333848806567684e-05, &
+ p11 = - 2.628501274963990e-04, p10 = 8.634221567969181e-04, &
+ p25 = - 8.654513012535990e-12, p24 = 1.232380050058077e-09, &
+ p23 = - 6.837922749505057e-08, p22 = 1.871407733439947e-06, &
+ p21 = - 2.552246987137160e-05, p20 = 1.428968311457630e-04, &
+ p35 = 3.207515102100162e-12, p34 = - 2.945761895342535e-10, &
+ p33 = 8.788972147364181e-09, p32 = - 3.814457439412957e-08, &
+ p31 = - 2.448983648874671e-06, p30 = 3.436721779020359e-05, &
+ p45 = - 3.530687797132211e-11, p44 = 3.939867958963747e-09, &
+ p43 = - 1.227668406985956e-08, p42 = - 1.367469811838390e-05, &
+ p41 = 5.988240863928883e-04, p40 = - 7.746288511324971e-03, &
+ p56 = - 1.187982453329086e-13, p55 = 4.801984186231693e-11, &
+ p54 = - 8.049200462388188e-09, p53 = 7.169872601310186e-07, &
+ p52 = - 3.581694433758150e-05, p51 = 9.503919224192534e-04, &
+ p50 = - 1.036679430885215e-02, &
+ p60 = 4.751256171799112e-05
+
+ if (ws10m >= 0.0 .and. ws10m < 5.9) then
+ zt = p00
+ elseif (ws10m >= 5.9 .and. ws10m <= 15.4) then
+ zt = p10 + ws10m * (p11 + ws10m * (p12 + ws10m * (p13 + &
+ ws10m * (p14 + ws10m * p15))))
+ elseif (ws10m > 15.4 .and. ws10m <= 21.6) then
+ zt = p20 + ws10m * (p21 + ws10m * (p22 + ws10m * (p23 + &
+ ws10m * (p24 + ws10m * p25))))
+ elseif (ws10m > 21.6 .and. ws10m <= 42.2) then
+ zt = p30 + ws10m * (p31 + ws10m * (p32 + ws10m * (p33 + &
+ ws10m * (p34 + ws10m * p35))))
+ elseif (ws10m > 42.2 .and. ws10m <= 53.3) then
+ zt = p40 + ws10m * (p41 + ws10m * (p42 + ws10m * (p43 + &
+ ws10m * (p44 + ws10m * p45))))
+ elseif (ws10m > 53.3 .and. ws10m <= 80.0) then
+ zt = p50 + ws10m * (p51 + ws10m * (p52 + ws10m * (p53 + &
+ ws10m * (p54 + ws10m * (p55 + ws10m * p56)))))
+ elseif (ws10m > 80.0) then
+ zt = p60
+ endif
+
+end subroutine cal_zt_hwrf17
+
+! =======================================================================
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_z0_moon (ws10m, z0)
+
+ real :: ws10m, z0
+
+ real :: ustar_th, z0_adj
+
+ real, parameter :: &
+ charnock = .014, &
+ wind_th_moon = 20., &
+ a = 0.56, &
+ b = - 20.255, &
+ c = wind_th_moon - 2.458
+
+ ustar_th = (- b - sqrt (b * b - 4 * a * c)) / (2 * a)
+
+ z0_adj = 0.001 * (0.085 * wind_th_moon - 0.58) - &
+ (charnock / grav) * ustar_th * ustar_th
+
+ z0 = 0.001 * (0.085 * ws10m - 0.58) - z0_adj ! eq (8b) moon et al. 2007 modified by kgao
+
+end subroutine cal_z0_moon
+
+! =======================================================================
+! Monin Obukhov Similarity
+! =======================================================================
+
+subroutine monin_obukhov_similarity ( &
+ z1, snwdph, thv1, wind, z0max, ztmax, tvs, &
+ rb, fm, fh, fm10, fh2, cm, ch, stress, ustar)
+
+ ! --- input
+ ! z1 - lowest model level height
+ ! snwdph - surface snow thickness
+ ! wind - wind speed at lowest model layer
+ ! thv1 - virtual potential temp at lowest model layer
+ ! tvs - surface temp
+ ! z0max - surface roughness length for momentum
+ ! ztmax - surface roughness length for heat
+ !
+ ! --- output
+ ! rb - a bulk richardson number
+ ! fm, fh - similarity function defined at lowest model layer
+ ! fm10, fh2 - similarity function defined at 10m (for momentum) and 2m (for heat)
+ ! cm, ch - surface exchange coefficients for momentum and heat
+ ! stress - surface wind stress
+ ! ustar - surface frictional velocity
+
+ ! --- inputs:
+ real, intent (in) :: z1, snwdph, thv1, wind, z0max, ztmax, tvs
+
+ ! --- outputs:
+ real, intent (out) :: rb, fm, fh, fm10, fh2, cm, ch, stress, ustar
+
+ ! --- locals:
+
+ real, parameter :: alpha = 5., a0 = - 3.975, &
+ a1 = 12.32, alpha4 = 4.0 * alpha, &
+ b1 = - 7.755, b2 = 6.041, alpha2 = alpha + alpha, beta = 1.0, &
+ a0p = - 7.941, a1p = 24.75, b1p = - 8.705, b2p = 7.899, &
+ ztmin1 = - 999.0, ca = .4
+
+ real :: aa, aa0, bb, bb0, dtv, adtv, &
+ hl1, hl12, pm, ph, pm10, ph2, &
+ z1i, &
+ fms, fhs, hl0, hl0inf, hlinf, &
+ hl110, hlt, hltinf, olinf, &
+ tem1, tem2, ztmax1
+
+ z1i = 1.0 / z1
+
+ tem1 = z0max / z1
+ if (abs (1.0 - tem1) > 1.0e-6) then
+ ztmax1 = - beta * log (tem1) / (alpha2 * (1. - tem1))
+ else
+ ztmax1 = 99.0
+ endif
+ if (z0max < 0.05 .and. snwdph < 10.0) ztmax1 = 99.0
+
+ !
+ ! compute stability indices (rb and hlinf)
+ !
+ dtv = thv1 - tvs
+ adtv = max (abs (dtv), 0.001)
+ dtv = sign (1., dtv) * adtv
+ rb = max (- 5000.0, (grav + grav) * dtv * z1 / &
+ ((thv1 + tvs) * wind * wind))
+ tem1 = 1.0 / z0max
+ tem2 = 1.0 / ztmax
+ fm = log ((z0max + z1) * tem1)
+ fh = log ((ztmax + z1) * tem2)
+ fm10 = log ((z0max + 10.) * tem1)
+ fh2 = log ((ztmax + 2.) * tem2)
+ hlinf = rb * fm * fm / fh
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+ !
+ ! stable case
+ !
+ if (dtv >= 0.0) then
+ hl1 = hlinf
+ if (hlinf > .25) then
+ tem1 = hlinf * z1i
+ hl0inf = z0max * tem1
+ hltinf = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hlinf)
+ aa0 = sqrt (1. + alpha4 * hl0inf)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hltinf)
+ pm = aa0 - aa + log ((aa + 1.) / (aa0 + 1.))
+ ph = bb0 - bb + log ((bb + 1.) / (bb0 + 1.))
+ fms = fm - pm
+ fhs = fh - ph
+ hl1 = fms * fms * rb / fhs
+ hl1 = min (max (hl1, ztmin1), ztmax1)
+ endif
+ !
+ ! second iteration
+ !
+ tem1 = hl1 * z1i
+ hl0 = z0max * tem1
+ hlt = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hl1)
+ aa0 = sqrt (1. + alpha4 * hl0)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hlt)
+ pm = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ ph = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ aa = sqrt (1. + alpha4 * hl110)
+ pm10 = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ! aa = sqrt (1. + alpha4 * hl12)
+ bb = sqrt (1. + alpha4 * hl12)
+ ph2 = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+ !
+ ! unstable case - check for unphysical obukhov length
+ !
+ else ! dtv < 0 case
+ olinf = z1 / hlinf
+ tem1 = 50.0 * z0max
+ if (abs (olinf) <= tem1) then
+ hlinf = - z1 / tem1
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+ endif
+ !
+ ! get pm and ph
+ !
+ if (hlinf >= - 0.5) then
+ hl1 = hlinf
+ pm = (a0 + a1 * hl1) * hl1 / (1. + (b1 + b2 * hl1) * hl1)
+ ph = (a0p + a1p * hl1) * hl1 / (1. + (b1p + b2p * hl1) * hl1)
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = (a0 + a1 * hl110) * hl110 / (1. + (b1 + b2 * hl110) * hl110)
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = (a0p + a1p * hl12) * hl12 / (1. + (b1p + b2p * hl12) * hl12)
+ else ! hlinf < 0.05
+ hl1 = - hlinf
+ tem1 = 1.0 / sqrt (hl1)
+ pm = log (hl1) + 2. * sqrt (tem1) - .8776
+ ph = log (hl1) + .5 * tem1 + 1.386
+ ! pm = log (hl1) + 2.0 * hl1 ** (- .25) - .8776
+ ! ph = log (hl1) + 0.5 * hl1 ** (- .5) + 1.386
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = log (hl110) + 2.0 / sqrt (sqrt (hl110)) - .8776
+ ! pm10 = log (hl110) + 2. * hl110 ** (- .25) - .8776
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = log (hl12) + 0.5 / sqrt (hl12) + 1.386
+ ! ph2 = log (hl12) + .5 * hl12 ** (- .5) + 1.386
+ endif
+
+ endif ! end of if (dtv >= 0) then loop
+ !
+ ! finish the exchange coefficient computation to provide fm and fh
+ !
+ fm = fm - pm
+ fh = fh - ph
+ fm10 = fm10 - pm10
+ fh2 = fh2 - ph2
+ cm = ca * ca / (fm * fm)
+ ch = ca * ca / (fm * fh)
+ tem1 = 0.00001 / z1
+ cm = max (cm, tem1)
+ ch = max (ch, tem1)
+ stress = cm * wind * wind
+ ustar = sqrt (stress)
+
+ return
+
+end subroutine monin_obukhov_similarity
+
+! =======================================================================
+! subroutine to surface energy balance over ocean
+!
+! program history log:
+! 2005 -- created from the original progtm to account for ocean only
+! oct 2006 -- h. wei added cmm and chh to the output
+! apr 2009 -- y. - t. hou modified to match the modified gbphys.f
+! reformatted the code and added program documentation
+! sep 2009 -- s. moorthi removed rcl and made pa as pressure unit
+! and furthur reformatted the code
+!
+! inputs: size
+! im - integer, horizontal dimension 1
+! ps - real, surface pressure im
+! u1, v1 - real, u / v component of surface layer wind im
+! t1 - real, surface layer mean temperature (k) im
+! q1 - real, surface layer mean specific humidity im
+! tsurf - real, ground surface skin temperature (k) im
+! cm - real, surface exchange coeff for momentum (m / s) im
+! ch - real, surface exchange coeff heat & moisture (m / s) im
+! prsl1 - real, surface layer mean pressure im
+! prslki - real, im
+! islimsk - integer, sea / land / ice mask (= 0 / 1 / 2) im
+! ddvel - real, wind enhancement due to convection (m / s) im
+! flag_iter - logical, im
+!
+! outputs: size
+! qsurf - real, specific humidity at sfc im
+! cmm - real, im
+! chh - real, im
+! gflux - real, ground heat flux (zero for ocean) im
+! evap - real, evaporation from latent heat flux im
+! hflx - real, sensible heat flux im
+! ep - real, potential evaporation im
+! =======================================================================
+
+subroutine sfc_ocea (im, ps, u1, v1, t1, q1, tsurf, cm, ch, &
+ prsl1, prslki, islimsk, qsurf, cmm, chh, gflux, evap, hflx, ep)
+
+ implicit none
+
+ ! --- constant parameters:
+ real, parameter :: cpinv = 1.0 / cp_air, &
+ hvapi = 1.0 / hlv, &
+ elocp = hlv / cp_air
+
+ ! --- inputs:
+ integer, intent (in) :: im
+
+ real, dimension (im), intent (in) :: ps, u1, v1, &
+ t1, q1, tsurf, cm, ch, prsl1, prslki
+ integer, dimension (im), intent (in) :: islimsk
+
+ ! --- outputs:
+ real, dimension (im), intent (inout) :: qsurf, &
+ cmm, chh, gflux, evap, hflx, ep
+
+ ! --- locals:
+
+ real :: q0, qss, rch, rho, wind, tem, ddvel (im)
+
+ integer :: i
+
+ logical :: flag (im), flag_iter (im)
+ !
+ ! ===> ... begin here
+ !
+ ! --- ... flag for open water
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+ flag (i) = (islimsk (i) == 0 .and. flag_iter (i))
+
+ ! --- ... initialize variables. all units are supposedly m.k.s. unless specified
+ ! ps is in pascals, wind is wind speed,
+ ! rho is density, qss is sat. hum. at surface
+
+ if (flag (i)) then
+
+ wind = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+
+ q0 = max (q1 (i), 1.0e-8)
+ rho = prsl1 (i) / (rdgas * t1 (i) * (1.0 + zvir * q0))
+
+ qss = mqs (tsurf (i))
+ qss = eps * qss / (ps (i) + epsm1 * qss)
+
+ evap (i) = 0.0
+ hflx (i) = 0.0
+ ep (i) = 0.0
+ gflux (i) = 0.0
+
+ ! --- ... rcp = rho cp_air ch v
+
+ rch = rho * cp_air * ch (i) * wind
+ cmm (i) = cm (i) * wind
+ chh (i) = rho * ch (i) * wind
+
+ ! --- ... sensible and latent heat flux over open water
+
+ hflx (i) = rch * (tsurf (i) - t1 (i) * prslki (i))
+
+ evap (i) = elocp * rch * (qss - q0)
+ qsurf (i) = qss
+
+ tem = 1.0 / rho
+ hflx (i) = hflx (i) * tem * cpinv
+ evap (i) = evap (i) * tem * hvapi
+ endif
+ enddo
+
+end subroutine sfc_ocea
+
+! =======================================================================
+! subroutine to surface energy balance over land
+! =======================================================================
+
+! =======================================================================
+! subroutine to surface energy balance over seaice
+!
+! program history log:
+! 2005 -- xingren wu created from original progtm and added
+! two - layer ice model
+! 200x -- sarah lu added flag_iter
+! oct 2006 -- h. wei added cmm and chh to output
+! 2007 -- x. wu modified for mom4 coupling (i.e. mom4ice)
+! 2007 -- s. moorthi micellaneous changes
+! may 2009 -- y. - t. hou modified to include surface emissivity
+! effect on lw radiation. replaced the confusing
+! slrad with sfc net sw sfcnsw (dn - up) . reformatted
+! the code and add program documentation block.
+! sep 2009 -- s. moorthi removed rcl, changed pressure units and
+! further optimized
+! jan 2015 -- x. wu change "cimin = 0.15" for both
+! uncoupled and coupled case
+!
+! inputs: size
+! im, km - integer, horiz dimension and num of soil layers 1
+! ps - real, surface pressure im
+! u1, v1 - real, u / v component of surface layer wind im
+! t1 - real, surface layer mean temperature (k) im
+! q1 - real, surface layer mean specific humidity im
+! delt - real, time interval (second) 1
+! sfcemis - real, sfc lw emissivity (fraction) im
+! dlwflx - real, total sky sfc downward lw flux (w / m ** 2) im
+! sfcnsw - real, total sky sfc netsw flx into ground (w / m ** 2) im
+! sfcdsw - real, total sky sfc downward sw flux (w / m ** 2) im
+! srflag - real, snow / rain flag for precipitation im
+! cm - real, surface exchange coeff for momentum (m / s) im
+! ch - real, surface exchange coeff heat & moisture (m / s) im
+! prsl1 - real, surface layer mean pressure im
+! prslki - real, im
+! islimsk - integer, sea / land / ice mask (= 0 / 1 / 2) im
+! ddvel - real, im
+! flag_iter - logical, im
+! mom4ice - logical, im
+! islimsk - integer, flag for land surface model scheme 1
+! = 0: use osu scheme; = 1: use noah scheme
+!
+! input / outputs:
+! hice - real, sea - ice thickness im
+! fice - real, sea - ice concentration im
+! tice - real, sea - ice surface temperature im
+! weasd - real, water equivalent accumulated snow depth (mm) im
+! tsurf - real, ground surface skin temperature (k) im
+! tprcp - real, total precipitation im
+! stc - real, soil temp (k) im, km
+! ep - real, potential evaporation im
+!
+! outputs:
+! snwdph - real, water equivalent snow depth (mm) im
+! qsurf - real, specific humidity at sfc im
+! snowmt - real, snow melt (m) im
+! gflux - real, soil heat flux (w / m ** 2) im
+! cmm - real, im
+! chh - real, im
+! evap - real, evaperation from latent heat flux im
+! hflx - real, sensible heat flux im
+! =======================================================================
+
+subroutine sfc_seai (im, km, ps, u1, v1, t1, q1, delt, &
+ sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, &
+ cm, ch, prsl1, prslki, islimsk, mom4ice, lsm, &
+ hice, fice, tice, weasd, tsurf, tprcp, stc, ep, &
+ snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx)
+
+ implicit none
+
+ ! --- constant parameters:
+ integer, parameter :: kmi = 2 ! 2 - layer of ice
+ real, parameter :: cpinv = 1.0 / cp_air
+ real, parameter :: hvapi = 1.0 / hlv
+ real, parameter :: elocp = hlv / cp_air
+ real, parameter :: himax = 8.0 ! maximum ice thickness allowed
+ real, parameter :: himin = 0.1 ! minimum ice thickness required
+ real, parameter :: hsmax = 2.0 ! maximum snow depth allowed
+ real, parameter :: timin = 173.0 ! minimum temperature allowed for snow / ice
+ real, parameter :: albfw = 0.06 ! albedo for lead
+ real, parameter :: dsi = 1.0 / 0.33
+
+ ! --- inputs:
+ integer, intent (in) :: im, km, lsm
+
+ real, dimension (im), intent (in) :: ps, u1, v1, &
+ t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, &
+ prsl1, prslki
+
+ integer, dimension (im), intent (in) :: islimsk
+ real, intent (in) :: delt
+
+ logical, intent (in) :: mom4ice
+
+ ! --- input / outputs:
+ real, dimension (im), intent (inout) :: hice, &
+ fice, tice, weasd, tsurf, tprcp, ep
+
+ real, dimension (im, km), intent (inout) :: stc
+
+ ! --- outputs:
+ real, dimension (im), intent (inout) :: snwdph, &
+ qsurf, snowmt, gflux, cmm, chh, evap, hflx
+
+ ! --- locals:
+ real, dimension (im) :: ffw, evapi, evapw, &
+ sneti, snetw, hfd, hfi, &
+ ! hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, &
+ focn, snof, hi_save, hs_save, rch, rho, &
+ snowd, theta1, ddvel
+
+ real :: t12, t14, tem, stsice (im, kmi), &
+ hflxi, hflxw, q0, qs1, wind, qssi, qssw
+ real, parameter :: cimin = 0.15 ! --- minimum ice concentration
+
+ integer :: i, k
+
+ logical :: flag (im), flag_iter (im)
+ !
+ ! ===> ... begin here
+ !
+ ! --- ... set flag for sea - ice
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+ flag (i) = (islimsk (i) >= 2) .and. flag_iter (i)
+ if (flag_iter (i) .and. islimsk (i) < 2) then
+ hice (i) = 0.0
+ fice (i) = 0.0
+ endif
+ enddo
+
+ ! --- ... update sea ice temperature
+
+ do k = 1, kmi
+ do i = 1, im
+ if (flag (i)) then
+ stsice (i, k) = stc (i, k)
+ endif
+ enddo
+ enddo
+ !
+ if (mom4ice) then
+ do i = 1, im
+ if (flag (i)) then
+ hi_save (i) = hice (i)
+ hs_save (i) = weasd (i) * 0.001
+ endif
+ enddo
+ elseif (lsm > 0) then ! --- ... snow - rain detection
+ do i = 1, im
+ if (flag (i)) then
+ if (srflag (i) == 1.0) then
+ ep (i) = 0.0
+ weasd (i) = weasd (i) + 1.e3 * tprcp (i)
+ tprcp (i) = 0.0
+ endif
+ endif
+ enddo
+ endif
+
+ ! --- ... initialize variables. all units are supposedly m.k.s. unless specifie
+ ! psurf is in pascals, wind is wind speed, theta1 is adiabatic surface
+ ! temp from level 1, rho is density, qs1 is sat. hum. at level1 and qss
+ ! is sat. hum. at surface
+ ! convert slrad to the civilized unit from langley minute - 1 k - 4
+
+ do i = 1, im
+ if (flag (i)) then
+ ! psurf (i) = 1000.0 * ps (i)
+ ! ps1 (i) = 1000.0 * prsl1 (i)
+
+ ! dlwflx has been given a negative sign for downward longwave
+ ! sfcnsw is the net shortwave flux (direction: dn - up)
+
+ wind = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+
+ q0 = max (q1 (i), 1.0e-8)
+ theta1 (i) = t1 (i) * prslki (i)
+ rho (i) = prsl1 (i) / (rdgas * t1 (i) * (1.0 + zvir * q0))
+ qs1 = mqs (t1 (i))
+ qs1 = max (eps * qs1 / (prsl1 (i) + epsm1 * qs1), 1.e-8)
+ q0 = min (qs1, q0)
+
+ ffw (i) = 1.0 - fice (i)
+ if (fice (i) < cimin) then
+ print *, 'warning: ice fraction is low:', fice (i)
+ fice (i) = cimin
+ ffw (i) = 1.0 - fice (i)
+ tice (i) = tgice
+ tsurf (i) = tgice
+ print *, 'fix ice fraction: reset it to:', fice (i)
+ endif
+
+ qssi = mqs (tice (i))
+ qssi = eps * qssi / (ps (i) + epsm1 * qssi)
+ qssw = mqs (tgice)
+ qssw = eps * qssw / (ps (i) + epsm1 * qssw)
+
+ ! --- ... snow depth in water equivalent is converted from mm to m unit
+
+ if (mom4ice) then
+ snowd (i) = weasd (i) * 0.001 / fice (i)
+ else
+ snowd (i) = weasd (i) * 0.001
+ endif
+ ! flagsnw (i) = .false.
+
+ ! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and
+ ! soil is allowed to interact with the atmosphere.
+ ! we should eventually move to a linear combination of soil and
+ ! snow under the condition of patchy snow.
+
+ ! --- ... rcp = rho cp_air ch v
+
+ cmm (i) = cm (i) * wind
+ chh (i) = rho (i) * ch (i) * wind
+ rch (i) = chh (i) * cp_air
+
+ ! --- ... sensible and latent heat flux over open water & sea ice
+
+ evapi (i) = elocp * rch (i) * (qssi - q0)
+ evapw (i) = elocp * rch (i) * (qssw - q0)
+ ! evap (i) = fice (i) * evapi (i) + ffw (i) * evapw (i)
+
+ ! if (lprnt) write (0, *) ' tice = ', tice (ipr)
+
+ snetw (i) = sfcdsw (i) * (1.0 - albfw)
+ snetw (i) = min (3.0 * sfcnsw (i) / (1.0 + 2.0 * ffw (i)), snetw (i))
+ sneti (i) = (sfcnsw (i) - ffw (i) * snetw (i)) / fice (i)
+
+ t12 = tice (i) * tice (i)
+ t14 = t12 * t12
+
+ ! --- ... hfi = net non - solar and upir heat flux @ ice surface
+
+ hfi (i) = - dlwflx (i) + sfcemis (i) * sbc * t14 + evapi (i) &
+ + rch (i) * (tice (i) - theta1 (i))
+ hfd (i) = 4.0 * sfcemis (i) * sbc * tice (i) * t12 &
+ + (1.0 + elocp * eps * hlv * qs1 / (rdgas * t12)) * rch (i)
+
+ t12 = tgice * tgice
+ t14 = t12 * t12
+
+ ! --- ... hfw = net heat flux @ water surface (within ice)
+
+ ! hfw (i) = - dlwflx (i) + sfcemis (i) * sbc * t14 + evapw (i) &
+ ! + rch (i) * (tgice - theta1 (i)) - snetw (i)
+
+ focn (i) = 2.0 ! heat flux from ocean - should be from ocn model
+ snof (i) = 0.0 ! snowfall rate - snow accumulates in gbphys
+
+ hice (i) = max (min (hice (i), himax), himin)
+ snowd (i) = min (snowd (i), hsmax)
+
+ if (snowd (i) > (2.0 * hice (i))) then
+ print *, 'warning: too much snow :', snowd (i)
+ snowd (i) = hice (i) + hice (i)
+ print *, 'fix: decrease snow depth to:', snowd (i)
+ endif
+ endif
+ enddo
+
+ ! if (lprnt) write (0, *) ' tice2 = ', tice (ipr)
+ call ice3lay &
+ ! --- inputs: !
+ (im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, &
+ ! --- outputs: !
+ snowd, hice, stsice, tice, snof, snowmt, gflux) !
+
+ ! if (lprnt) write (0, *) ' tice3 = ', tice (ipr)
+ if (mom4ice) then
+ do i = 1, im
+ if (flag (i)) then
+ hice (i) = hi_save (i)
+ snowd (i) = hs_save (i)
+ endif
+ enddo
+ endif
+
+ do i = 1, im
+ if (flag (i)) then
+ if (tice (i) < timin) then
+ print *, 'warning: snow / ice temperature is too low:', tice (i), ' i = ', i
+ tice (i) = timin
+ print *, 'fix snow / ice temperature: reset it to:', tice (i)
+ endif
+
+ if (stsice (i, 1) < timin) then
+ print *, 'warning: layer 1 ice temp is too low:', stsice (i, 1), ' i = ', i
+ stsice (i, 1) = timin
+ print *, 'fix layer 1 ice temp: reset it to:', stsice (i, 1)
+ endif
+
+ if (stsice (i, 2) < timin) then
+ print *, 'warning: layer 2 ice temp is too low:', stsice (i, 2)
+ stsice (i, 2) = timin
+ print *, 'fix layer 2 ice temp: reset it to:', stsice (i, 2)
+ endif
+
+ tsurf (i) = tice (i) * fice (i) + tgice * ffw (i)
+ endif
+ enddo
+
+ do k = 1, kmi
+ do i = 1, im
+ if (flag (i)) then
+ stc (i, k) = min (stsice (i, k), t0ice)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (flag (i)) then
+ ! --- ... calculate sensible heat flux (& evap over sea ice)
+
+ hflxi = rch (i) * (tice (i) - theta1 (i))
+ hflxw = rch (i) * (tgice - theta1 (i))
+ hflx (i) = fice (i) * hflxi + ffw (i) * hflxw
+ evap (i) = fice (i) * evapi (i) + ffw (i) * evapw (i)
+ !
+ ! --- ... the rest of the output
+
+ qsurf (i) = q1 (i) + evap (i) / (elocp * rch (i))
+
+ ! --- ... convert snow depth back to mm of water equivalent
+
+ weasd (i) = snowd (i) * 1000.0
+ snwdph (i) = weasd (i) * dsi ! snow depth in mm
+
+ tem = 1.0 / rho (i)
+ hflx (i) = hflx (i) * tem * cpinv
+ evap (i) = evap (i) * tem * hvapi
+ endif
+ enddo
+
+end subroutine sfc_seai
+
+! =======================================================================
+! Three-Layer Sea Ice Vertical Thermodynamics
+!
+! based on: m. winton, "a reformulated three-layer sea ice model",
+! journal of atmospheric and oceanic technology, 2000
+!
+!
+! -> +---------+ <- tice - diagnostic surface temperature ( <= 0c )
+! / | |
+! snowd | snow | <- 0-heat capacity snow layer
+! \ | |
+! => +---------+
+! / | |
+! / | | <- t1 - upper 1/2 ice temperature; this layer has
+! / | | a variable (t/s dependent) heat capacity
+! hice |...ice...|
+! \ | |
+! \ | | <- t2 - lower 1/2 ice temp. (fixed heat capacity)
+! \ | |
+! -> +---------+ <- base of ice fixed at seawater freezing temp.
+!
+! inputs: size
+! im, kmi - integer, horiz dimension and num of ice layers 1
+! fice - real, sea - ice concentration im
+! flag - logical, ice mask flag 1
+! hfi - real, net non - solar and heat flux @ surface (w / m^2) im
+! hfd - real, heat flux derivatice @ sfc (w / m^2 / deg - c) im
+! sneti - real, net solar incoming at top (w / m^2) im
+! focn - real, heat flux from ocean (w / m^2) im
+! delt - real, timestep (sec) 1
+!
+! input / outputs:
+! snowd - real, surface pressure im
+! hice - real, sea - ice thickness im
+! stsice - real, temp @ midpt of ice levels (deg c) im, km
+! tice - real, surface temperature (deg c) im
+! snof - real, snowfall rate (m / sec) im
+!
+! outputs:
+! snowmt - real, snow melt during delt (m) im
+! gflux - real, conductive heat flux (w / m^2) im
+!
+! locals:
+! hdi - real, ice - water interface (m)
+! hsni - real, snow - ice (m)
+!
+! =======================================================================
+
+subroutine ice3lay &
+ !...................................
+ ! --- inputs:
+ (im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, &
+ ! --- input / outputs:
+ snowd, hice, stsice, tice, snof, &
+ ! --- outputs:
+ snowmt, gflux)
+
+ implicit none
+
+ ! --- constant parameters: (properties of ice, snow, and seawater)
+ real, parameter :: ds = 330.0 ! snow (ov sea ice) density (kg / m^3)
+ real, parameter :: dw = 1000.0 ! fresh water density (kg / m^3)
+ real, parameter :: dsdw = ds / dw
+ real, parameter :: dwds = dw / ds
+ real, parameter :: ks = 0.31 ! conductivity of snow (w / mk)
+ real, parameter :: i0 = 0.3 ! ice surface penetrating solar fraction
+ real, parameter :: ki = 2.03 ! conductivity of ice (w / mk)
+ real, parameter :: di = 917.0 ! density of ice (kg / m^3)
+ real, parameter :: didw = di / dw
+ real, parameter :: dsdi = ds / di
+ real, parameter :: ci = 2054.0 ! heat capacity of fresh ice (j / kg / k)
+ real, parameter :: li = 3.34e5 ! latent heat of fusion (j / kg - ice)
+ real, parameter :: si = 1.0 ! salinity of sea ice
+ real, parameter :: mu = 0.054 ! relates freezing temp to salinity
+ real, parameter :: tfi = - mu * si ! sea ice freezing temp = - mu * salinity
+ real, parameter :: tfw = - 1.8 ! tfw - seawater freezing temp (c)
+ real, parameter :: tfi0 = tfi - 0.0001
+ real, parameter :: dici = di * ci
+ real, parameter :: dili = di * li
+ real, parameter :: dsli = ds * li
+ real, parameter :: ki4 = ki * 4.0
+
+ ! --- inputs:
+ integer, intent (in) :: im, kmi
+
+ real, dimension (im), intent (in) :: fice, hfi, hfd, sneti, focn
+
+ real, intent (in) :: delt
+
+ logical, dimension (im), intent (in) :: flag
+
+ ! --- input / outputs:
+ real, dimension (im), intent (inout) :: snowd, hice, tice, snof
+
+ real, dimension (im, kmi), intent (inout) :: stsice
+
+ ! --- outputs:
+ real, dimension (im), intent (out) :: snowmt, gflux
+
+ ! --- locals:
+
+ real :: dt2, dt4, dt6, h1, h2, dh, wrk, wrk1, &
+ dt2i, hdi, hsni, ai, bi, a1, b1, a10, b10, &
+ c1, ip, k12, k32, tsf, f1, tmelt, bmelt
+
+ integer :: i
+ !
+ ! ===> ... begin here
+ !
+ dt2 = 2.0 * delt
+ dt4 = 4.0 * delt
+ dt6 = 6.0 * delt
+ dt2i = 1.0 / dt2
+
+ do i = 1, im
+ if (flag (i)) then
+ snowd (i) = snowd (i) * dwds
+ hdi = (dsdw * snowd (i) + didw * hice (i))
+
+ if (hice (i) < hdi) then
+ snowd (i) = snowd (i) + hice (i) - hdi
+ hsni = (hdi - hice (i)) * dsdi
+ hice (i) = hice (i) + hsni
+ endif
+
+ snof (i) = snof (i) * dwds
+ tice (i) = tice (i) - t0ice
+ stsice (i, 1) = min (stsice (i, 1) - t0ice, tfi0) ! degc
+ stsice (i, 2) = min (stsice (i, 2) - t0ice, tfi0) ! degc
+
+ ip = i0 * sneti (i) ! ip + v (in winton ip = - i0 * sneti as sol - v)
+ if (snowd (i) > 0.0) then
+ tsf = 0.0
+ ip = 0.0
+ else
+ tsf = tfi
+ ip = i0 * sneti (i) ! ip + v here (in winton ip = - i0 * sneti)
+ endif
+ tice (i) = min (tice (i), tsf)
+
+ ! --- ... compute ice temperature
+
+ bi = hfd (i)
+ ai = hfi (i) - sneti (i) + ip - tice (i) * bi ! + v sol input here
+ k12 = ki4 * ks / (ks * hice (i) + ki4 * snowd (i))
+ k32 = (ki + ki) / hice (i)
+
+ wrk = 1.0 / (dt6 * k32 + dici * hice (i))
+ a10 = dici * hice (i) * dt2i + k32 * (dt4 * k32 + dici * hice (i)) * wrk
+ b10 = - di * hice (i) * (ci * stsice (i, 1) + li * tfi / stsice (i, 1)) &
+ * dt2i - ip &
+ - k32 * (dt4 * k32 * tfw + dici * hice (i) * stsice (i, 2)) * wrk
+
+ wrk1 = k12 / (k12 + bi)
+ a1 = a10 + bi * wrk1
+ b1 = b10 + ai * wrk1
+ c1 = dili * tfi * dt2i * hice (i)
+
+ stsice (i, 1) = - (sqrt (b1 * b1 - 4.0 * a1 * c1) + b1) / (a1 + a1)
+ tice (i) = (k12 * stsice (i, 1) - ai) / (k12 + bi)
+
+ if (tice (i) > tsf) then
+ a1 = a10 + k12
+ b1 = b10 - k12 * tsf
+ stsice (i, 1) = - (sqrt (b1 * b1 - 4.0 * a1 * c1) + b1) / (a1 + a1)
+ tice (i) = tsf
+ tmelt = (k12 * (stsice (i, 1) - tsf) - (ai + bi * tsf)) * delt
+ else
+ tmelt = 0.0
+ snowd (i) = snowd (i) + snof (i) * delt
+ endif
+
+ stsice (i, 2) = (dt2 * k32 * (stsice (i, 1) + tfw + tfw) &
+ + dici * hice (i) * stsice (i, 2)) * wrk
+
+ bmelt = (focn (i) + ki4 * (stsice (i, 2) - tfw) / hice (i)) * delt
+
+ ! --- ... resize the ice ...
+
+ h1 = 0.5 * hice (i)
+ h2 = 0.5 * hice (i)
+
+ ! --- ... top ...
+
+ if (tmelt <= snowd (i) * dsli) then
+ snowmt (i) = tmelt / dsli
+ snowd (i) = snowd (i) - snowmt (i)
+ else
+ snowmt (i) = snowd (i)
+ h1 = h1 - (tmelt - snowd (i) * dsli) &
+ / (di * (ci - li / stsice (i, 1)) * (tfi - stsice (i, 1)))
+ snowd (i) = 0.0
+ endif
+
+ ! --- ... and bottom
+
+ if (bmelt < 0.0) then
+ dh = - bmelt / (dili + dici * (tfi - tfw))
+ stsice (i, 2) = (h2 * stsice (i, 2) + dh * tfw) / (h2 + dh)
+ h2 = h2 + dh
+ else
+ h2 = h2 - bmelt / (dili + dici * (tfi - stsice (i, 2)))
+ endif
+
+ ! --- ... if ice remains, even up 2 layers, else, pass negative energy back in snow
+
+ hice (i) = h1 + h2
+
+ if (hice (i) > 0.0) then
+ if (h1 > 0.5 * hice (i)) then
+ f1 = 1.0 - (h2 + h2) / hice (i)
+ stsice (i, 2) = f1 * (stsice (i, 1) + li * tfi / (ci * stsice (i, 1))) &
+ + (1.0 - f1) * stsice (i, 2)
+
+ if (stsice (i, 2) > tfi) then
+ hice (i) = hice (i) - h2 * ci * (stsice (i, 2) - tfi) / (li * delt)
+ stsice (i, 2) = tfi
+ endif
+ else
+ f1 = (h1 + h1) / hice (i)
+ stsice (i, 1) = f1 * (stsice (i, 1) + li * tfi / (ci * stsice (i, 1))) &
+ + (1.0 - f1) * stsice (i, 2)
+ stsice (i, 1) = (stsice (i, 1) - sqrt (stsice (i, 1) * stsice (i, 1) &
+ - 4.0 * tfi * li / ci)) * 0.5
+ endif
+
+ k12 = ki4 * ks / (ks * hice (i) + ki4 * snowd (i))
+ gflux (i) = k12 * (stsice (i, 1) - tice (i))
+ else
+ snowd (i) = snowd (i) + (h1 * (ci * (stsice (i, 1) - tfi) &
+ - li * (1.0 - tfi / stsice (i, 1))) &
+ + h2 * (ci * (stsice (i, 2) - tfi) - li)) / li
+
+ hice (i) = max (0.0, snowd (i) * dsdi)
+ snowd (i) = 0.0
+ stsice (i, 1) = tfw
+ stsice (i, 2) = tfw
+ gflux (i) = 0.0
+ endif ! endif_hice_block
+
+ gflux (i) = fice (i) * gflux (i)
+ snowmt (i) = snowmt (i) * dsdw
+ snowd (i) = snowd (i) * dsdw
+ tice (i) = tice (i) + t0ice
+ stsice (i, 1) = stsice (i, 1) + t0ice
+ stsice (i, 2) = stsice (i, 2) + t0ice
+ endif ! endif_flag_block
+ enddo ! enddo_i_loop
+
+end subroutine ice3lay
+
+! =======================================================================
+! subroutine to update near surface fields
+! =======================================================================
+
+subroutine sfc_updt (im, ps, u1, v1, t1, q1, &
+ tsurf, qsurf, u10m, v10m, t2m, q2m, &
+ prslki, evap, fm, fh, fm10, fh2)
+
+ implicit none
+
+ integer im
+ real, dimension (im) :: ps, u1, v1, t1, q1, tsurf, qsurf, &
+ u10m, v10m, t2m, q2m, prslki, evap, &
+ fm, fh, fm10, fh2
+
+ ! locals
+
+ real, parameter :: qmin = 1.0e-8
+ integer k, i
+
+ real :: fhi, qss, wrk, f10m (im)
+ ! real :: sig2k, fhi, qss
+
+ ! real, parameter :: g = grav
+
+ ! estimate sigma ** k at 2 m
+
+ ! sig2k = 1. - 4. * g * 2. / (cp_air * 280.)
+
+ ! initialize variables. all units are supposedly m.k.s. unless specified
+ ! ps is in pascals
+
+ do i = 1, im
+ f10m (i) = fm10 (i) / fm (i)
+ ! f10m (i) = min (f10m (i), 1.)
+ u10m (i) = f10m (i) * u1 (i)
+ v10m (i) = f10m (i) * v1 (i)
+ fhi = fh2 (i) / fh (i)
+ ! t2m (i) = tsurf (i) * (1. - fhi) + t1 (i) * prslki (i) * fhi
+ ! sig2k = 1. - (grav + grav) / (cp_air * t2m (i))
+ ! t2m (i) = t2m (i) * sig2k
+ wrk = 1.0 - fhi
+
+ t2m (i) = tsurf (i) * wrk + t1 (i) * prslki (i) * fhi - (grav + grav) / cp_air
+
+ if (evap (i) >= 0.) then ! for evaporation > 0, use inferred qsurf to deduce q2m
+ q2m (i) = qsurf (i) * wrk + max (qmin, q1 (i)) * fhi
+ else ! for dew formation, use saturated q at tsurf
+ qss = mqs (tsurf (i))
+ qss = eps * qss / (ps (i) + epsm1 * qss)
+ q2m (i) = qss * wrk + max (qmin, q1 (i)) * fhi
+ endif
+ qss = mqs (t2m (i))
+ qss = eps * qss / (ps (i) + epsm1 * qss)
+ q2m (i) = min (q2m (i), qss)
+ enddo
+
+end subroutine sfc_updt
+
+! =======================================================================
+! solve tridiagonal problem for tke
+! =======================================================================
+
+subroutine tridit (l, n, nt, cl, cm, cu, rt, au, at)
+
+ implicit none
+
+ integer :: is, k, kk, n, nt, l, i
+
+ real :: fk (l)
+
+ real :: cl (l, 2:n), cm (l, n), cu (l, n - 1), &
+ rt (l, n * nt), &
+ au (l, n - 1), at (l, n * nt), &
+ fkk (l, 2:n - 1)
+
+ do i = 1, l
+ fk (i) = 1. / cm (i, 1)
+ au (i, 1) = fk (i) * cu (i, 1)
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ at (i, 1 + is) = fk (i) * rt (i, 1 + is)
+ enddo
+ enddo
+ do k = 2, n - 1
+ do i = 1, l
+ fkk (i, k) = 1. / (cm (i, k) - cl (i, k) * au (i, k - 1))
+ au (i, k) = fkk (i, k) * cu (i, k)
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = 2, n - 1
+ do i = 1, l
+ at (i, k + is) = fkk (i, k) * (rt (i, k + is) - cl (i, k) * at (i, k + is - 1))
+ enddo
+ enddo
+ enddo
+ do i = 1, l
+ fk (i) = 1. / (cm (i, n) - cl (i, n) * au (i, n - 1))
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ at (i, n + is) = fk (i) * (rt (i, n + is) - cl (i, n) * at (i, n + is - 1))
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ at (i, k + is) = at (i, k + is) - au (i, k) * at (i, k + is + 1)
+ enddo
+ enddo
+ enddo
+
+end subroutine tridit
+
+! =======================================================================
+! edmf parameterization siebesma et al. (2007)
+! =======================================================================
+
+subroutine mfpblt (im, km, kmpbl, ntcw, ntrac1, delt, &
+ cnvflg, zl, zm, q1, t1, u1, v1, plyr, pix, thlx, thvx, &
+ gdx, hpbl, kpbl, vpert, buo, xmf, &
+ tcko, qcko, ucko, vcko, xlamue)
+
+ implicit none
+
+ integer, intent (in) :: im, km, kmpbl, ntcw, ntrac1
+ integer :: kpbl (im)
+
+ logical :: cnvflg (im)
+
+ real :: delt
+ real :: q1 (im, km, ntrac1), &
+ t1 (im, km), u1 (im, km), v1 (im, km), &
+ plyr (im, km), pix (im, km), thlx (im, km), &
+ thvx (im, km), zl (im, km), zm (im, km), &
+ gdx (im), &
+ hpbl (im), vpert (im), &
+ buo (im, km), xmf (im, km), &
+ tcko (im, km), qcko (im, km, ntrac1), &
+ ucko (im, km), vcko (im, km), &
+ xlamue (im, km - 1)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, j, k, n, ndc
+ integer :: kpblx (im), kpbly (im)
+
+ real :: dt2, dz, ce0, cm, &
+ factor, gocp, &
+ g, b1, f1, &
+ bb1, bb2, &
+ alp, a1, pgcon, &
+ qmin, qlmin, xmmx, rbint, &
+ tem, tem1, tem2, &
+ ptem, ptem1, ptem2
+
+ real :: elocp, el2orc, qs, es, &
+ tlu, gamma, qlu, &
+ thup, thvu, dq
+
+ real :: rbdn (im), rbup (im), hpblx (im), &
+ xlamuem (im, km - 1)
+
+ real :: wu2 (im, km), thlu (im, km), &
+ qtx (im, km), qtu (im, km)
+
+ real :: xlamavg (im), sigma (im), &
+ scaldfunc (im), sumx (im)
+
+ logical :: totflg, flg (im)
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (gocp = g / cp_air)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (ce0 = 0.4, cm = 1.0)
+ parameter (qmin = 1.e-8, qlmin = 1.e-12)
+ parameter (alp = 1.0, pgcon = 0.55)
+ parameter (a1 = 0.13, b1 = 0.5, f1 = 0.15)
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ dt2 = delt
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ buo (i, k) = 0.
+ wu2 (i, k) = 0.
+ qtx (i, k) = q1 (i, k, 1) + q1 (i, k, ntcw)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute thermal excess
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ptem = alp * vpert (i)
+ ptem = min (ptem, 3.0)
+ thlu (i, 1) = thlx (i, 1) + ptem
+ qtu (i, 1) = qtx (i, 1)
+ buo (i, 1) = g * ptem / thvx (i, 1)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ if (k < kpbl (i)) then
+ ptem = 1. / (zm (i, k) + dz)
+ tem = max ((hpbl (i) - zm (i, k) + dz), dz)
+ ptem1 = 1. / tem
+ xlamue (i, k) = ce0 * (ptem + ptem1)
+ else
+ xlamue (i, k) = ce0 / dz
+ endif
+ xlamuem (i, k) = cm * xlamue (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy for updraft air parcel
+ ! -----------------------------------------------------------------------
+
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ thlu (i, k) = ((1. - tem) * thlu (i, k - 1) + tem * &
+ (thlx (i, k - 1) + thlx (i, k))) / factor
+ qtu (i, k) = ((1. - tem) * qtu (i, k - 1) + tem * &
+ (qtx (i, k - 1) + qtx (i, k))) / factor
+
+ tlu = thlu (i, k) / pix (i, k)
+ es = 0.01 * mqs (tlu) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtu (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tlu ** 2)
+ qlu = dq / (1. + gamma)
+ qtu (i, k) = qs + qlu
+ tem1 = 1. + zvir * qs - qlu
+ thup = thlu (i, k) + pix (i, k) * elocp * qlu
+ thvu = thup * tem1
+ else
+ tem1 = 1. + zvir * qtu (i, k)
+ thvu = thlu (i, k) * tem1
+ endif
+ buo (i, k) = g * (thvu / thvx (i, k) - 1.)
+
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity square (wu2)
+ ! -----------------------------------------------------------------------
+
+ ! tem = 1. - 2. * f1
+ ! bb1 = 2. * b1 / tem
+ ! bb2 = 2. / tem
+ ! from soares et al. (2004, qjrms)
+ ! bb1 = 2.
+ ! bb2 = 4.
+
+ ! from bretherton et al. (2004, mwr)
+ ! bb1 = 4.
+ ! bb2 = 2.
+
+ ! from our tuning
+ bb1 = 2.0
+ bb2 = 4.0
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zm (i, 1)
+ tem = 0.5 * bb1 * xlamue (i, 1) * dz
+ tem1 = bb2 * buo (i, 1) * dz
+ ptem1 = 1. + tem
+ wu2 (i, 1) = tem1 / ptem1
+ endif
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zm (i, k) - zm (i, k - 1)
+ tem = 0.25 * bb1 * (xlamue (i, k) + xlamue (i, k - 1)) * dz
+ tem1 = bb2 * buo (i, k) * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! update pbl height as the height where updraft velocity vanishes
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .true.
+ kpbly (i) = kpbl (i)
+ if (cnvflg (i)) then
+ flg (i) = .false.
+ rbup (i) = wu2 (i, 1)
+ endif
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (.not.flg (i)) then
+ rbdn (i) = rbup (i)
+ rbup (i) = wu2 (i, k)
+ kpblx (i) = k
+ flg (i) = rbup (i) .le.0.
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kpblx (i)
+ if (rbdn (i) <= 0.) then
+ rbint = 0.
+ elseif (rbup (i) >= 0.) then
+ rbint = 1.
+ else
+ rbint = rbdn (i) / (rbdn (i) - rbup (i))
+ endif
+ hpblx (i) = zm (i, k - 1) + rbint * (zm (i, k) - zm (i, k - 1))
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kpbl (i) > kpblx (i)) then
+ kpbl (i) = kpblx (i)
+ hpbl (i) = hpblx (i)
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! update entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. kpbly (i) > kpblx (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ if (k < kpbl (i)) then
+ ptem = 1. / (zm (i, k) + dz)
+ tem = max ((hpbl (i) - zm (i, k) + dz), dz)
+ ptem1 = 1. / tem
+ xlamue (i, k) = ce0 * (ptem + ptem1)
+ else
+ xlamue (i, k) = ce0 / dz
+ endif
+ xlamuem (i, k) = cm * xlamue (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate averaged over the whole pbl
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ xlamavg (i) = 0.
+ sumx (i) = 0.
+ enddo
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k < kpbl (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ xlamavg (i) = xlamavg (i) + xlamue (i, k) * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamavg (i) = xlamavg (i) / sumx (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! updraft mass flux as a function of updraft velocity profile
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k < kpbl (i)) then
+ if (wu2 (i, k) > 0.) then
+ tem = sqrt (wu2 (i, k))
+ else
+ tem = 0.
+ endif
+ xmf (i, k) = a1 * tem
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft fraction as a function of mean entrainment rate
+ ! (grell & freitas, 2014)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = 0.2 / xlamavg (i)
+ tem1 = 3.14 * tem * tem
+ sigma (i) = tem1 / (gdx (i) * gdx (i))
+ sigma (i) = max (sigma (i), 0.001)
+ sigma (i) = min (sigma (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute scale - aware function based on arakawa & wu (2013)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sigma (i) > a1) then
+ scaldfunc (i) = (1. - sigma (i)) * (1. - sigma (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final scale - aware updraft mass flux
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k < kpbl (i)) then
+ xmf (i, k) = scaldfunc (i) * xmf (i, k)
+ dz = zl (i, k + 1) - zl (i, k)
+ xmmx = dz / dt2
+ xmf (i, k) = min (xmf (i, k), xmmx)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft property using updated entranment rate
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ thlu (i, 1) = thlx (i, 1)
+ endif
+ enddo
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! ptem1 = max (qcko (i, 1, ntcw), 0.)
+ ! tlu = thlu (i, 1) / pix (i, 1)
+ ! tcko (i, 1) = tlu + elocp * ptem1
+ ! endif
+ ! enddo
+
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ thlu (i, k) = ((1. - tem) * thlu (i, k - 1) + tem * &
+ (thlx (i, k - 1) + thlx (i, k))) / factor
+ qtu (i, k) = ((1. - tem) * qtu (i, k - 1) + tem * &
+ (qtx (i, k - 1) + qtx (i, k))) / factor
+
+ tlu = thlu (i, k) / pix (i, k)
+ es = 0.01 * mqs (tlu) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtu (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tlu ** 2)
+ qlu = dq / (1. + gamma)
+ qtu (i, k) = qs + qlu
+ qcko (i, k, 1) = qs
+ qcko (i, k, ntcw) = qlu
+ tcko (i, k) = tlu + elocp * qlu
+ else
+ qcko (i, k, 1) = qtu (i, k)
+ qcko (i, k, ntcw) = 0.
+ tcko (i, k) = tlu
+ endif
+
+ endif
+ enddo
+ enddo
+
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamuem (i, k - 1) * dz
+ factor = 1. + tem
+ ptem = tem + pgcon
+ ptem1 = tem - pgcon
+ ucko (i, k) = ((1. - tem) * ucko (i, k - 1) + ptem * u1 (i, k) + &
+ ptem1 * u1 (i, k - 1)) / factor
+ vcko (i, k) = ((1. - tem) * vcko (i, k - 1) + ptem * v1 (i, k) + &
+ ptem1 * v1 (i, k - 1)) / factor
+ endif
+ enddo
+ enddo
+
+ if (ntcw > 2) then
+
+ do n = 2, ntcw - 1
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ qcko (i, k, n) = ((1. - tem) * qcko (i, k - 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k - 1, n))) / factor
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ndc = ntrac1 - ntcw
+
+ if (ndc > 0) then
+
+ do n = ntcw + 1, ntrac1
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ qcko (i, k, n) = ((1. - tem) * qcko (i, k - 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k - 1, n))) / factor
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ return
+
+end subroutine mfpblt
+
+! =======================================================================
+! mass - flux parameterization for stratocumulus - top - induced turbulence mixing
+! =======================================================================
+
+subroutine mfscu (im, km, kmscu, ntcw, ntrac1, delt, &
+ cnvflg, zl, zm, q1, t1, u1, v1, plyr, pix, &
+ thlx, thvx, thlvx, gdx, thetae, radj, &
+ krad, mrad, radmin, buo, xmfd, &
+ tcdo, qcdo, ucdo, vcdo, xlamde)
+
+ implicit none
+
+ integer, intent (in) :: im, km, kmscu, ntcw, ntrac1
+ integer :: krad (im), mrad (im)
+
+ logical :: cnvflg (im)
+
+ real :: delt
+ real :: q1 (im, km, ntrac1), t1 (im, km), &
+ u1 (im, km), v1 (im, km), &
+ plyr (im, km), pix (im, km), &
+ thlx (im, km), &
+ thvx (im, km), thlvx (im, km), &
+ gdx (im), radj (im), &
+ zl (im, km), zm (im, km), &
+ thetae (im, km), radmin (im), &
+ buo (im, km), xmfd (im, km), &
+ tcdo (im, km), qcdo (im, km, ntrac1), &
+ ucdo (im, km), vcdo (im, km), &
+ xlamde (im, km - 1)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, j, indx, k, n, kk, ndc
+
+ integer :: krad1 (im), mradx (im), mrady (im)
+
+ real :: dt2, dz, ce0, cm, &
+ gocp, factor, g, tau, &
+ b1, f1, bb1, bb2, &
+ a1, a2, a11, a22, &
+ cteit, pgcon, &
+ qmin, qlmin, &
+ xmmx, tem, tem1, tem2, &
+ ptem, ptem1, ptem2
+
+ real :: elocp, el2orc, qs, es, &
+ tld, gamma, qld, thdn, &
+ thvd, dq
+
+ real :: wd2 (im, km), thld (im, km), &
+ qtx (im, km), qtd (im, km), &
+ thlvd (im), hrad (im), &
+ xlamdem (im, km - 1), ra1 (im), ra2 (im)
+
+ real :: xlamavg (im), sigma (im), &
+ scaldfunc (im), sumx (im)
+
+ logical :: totflg, flg (im)
+
+ real :: actei, cldtime
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (gocp = g / cp_air)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (ce0 = 0.4, cm = 1.0, pgcon = 0.55)
+ parameter (qmin = 1.e-8, qlmin = 1.e-12)
+ parameter (b1 = 0.45, f1 = 0.15)
+ parameter (a1 = 0.12, a2 = 0.5)
+ parameter (a11 = 0.2, a22 = 1.0)
+ parameter (cldtime = 500.)
+ parameter (actei = 0.7)
+ ! parameter (actei = 0.23)
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ dt2 = delt
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ buo (i, k) = 0.
+ wd2 (i, k) = 0.
+ qtx (i, k) = q1 (i, k, 1) + q1 (i, k, ntcw)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ hrad (i) = zm (i, krad (i))
+ krad1 (i) = krad (i) - 1
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad (i)
+ tem = zm (i, k + 1) - zm (i, k)
+ tem1 = cldtime * radmin (i) / tem
+ tem1 = max (tem1, - 3.0)
+ thld (i, k) = thlx (i, k) + tem1
+ qtd (i, k) = qtx (i, k)
+ thlvd (i) = thlvx (i, k) + tem1
+ buo (i, k) = - g * tem1 / thvx (i, k)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify downdraft fraction
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ra1 (i) = a1
+ ra2 (i) = a11
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the condition for cloud - top instability is met,
+ ! increase downdraft fraction
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad (i)
+ tem = thetae (i, k) - thetae (i, k + 1)
+ tem1 = qtx (i, k) - qtx (i, k + 1)
+ if (tem > 0. .and. tem1 > 0.) then
+ cteit = cp_air * tem / (hlv * tem1)
+ if (cteit > actei) then
+ ra1 (i) = a2
+ ra2 (i) = a22
+ endif
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute radiative flux jump at stratocumulus top
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ radj (i) = - ra2 (i) * radmin (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! first - quess level of downdraft extension (mrad)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ mrad (i) = krad (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k < krad (i)) then
+ if (thlvd (i) <= thlvx (i, k)) then
+ mrad (i) = k
+ else
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = krad (i) - mrad (i)
+ if (kk < 1) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmscu
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ if (k >= mrad (i) .and. k < krad (i)) then
+ if (mrad (i) == 1) then
+ ptem = 1. / (zm (i, k) + dz)
+ else
+ ptem = 1. / (zm (i, k) - zm (i, mrad (i) - 1) + dz)
+ endif
+ tem = max ((hrad (i) - zm (i, k) + dz), dz)
+ ptem1 = 1. / tem
+ xlamde (i, k) = ce0 * (ptem + ptem1)
+ else
+ xlamde (i, k) = ce0 / dz
+ endif
+ xlamdem (i, k) = cm * xlamde (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy for downdraft air parcel
+ ! -----------------------------------------------------------------------
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ thld (i, k) = ((1. - tem) * thld (i, k + 1) + tem * &
+ (thlx (i, k) + thlx (i, k + 1))) / factor
+ qtd (i, k) = ((1. - tem) * qtd (i, k + 1) + tem * &
+ (qtx (i, k) + qtx (i, k + 1))) / factor
+
+ tld = thld (i, k) / pix (i, k)
+ es = 0.01 * mqs (tld) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtd (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tld ** 2)
+ qld = dq / (1. + gamma)
+ qtd (i, k) = qs + qld
+ tem1 = 1. + zvir * qs - qld
+ thdn = thld (i, k) + pix (i, k) * elocp * qld
+ thvd = thdn * tem1
+ else
+ tem1 = 1. + zvir * qtd (i, k)
+ thvd = thld (i, k) * tem1
+ endif
+ buo (i, k) = g * (1. - thvd / thvx (i, k))
+
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft velocity square (wd2)
+ ! -----------------------------------------------------------------------
+
+ ! tem = 1. - 2. * f1
+ ! bb1 = 2. * b1 / tem
+ ! bb2 = 2. / tem
+ ! from soares et al. (2004, qjrms)
+ ! bb1 = 2.
+ ! bb2 = 4.
+
+ ! from bretherton et al. (2004, mwr)
+ ! bb1 = 4.
+ ! bb2 = 2.
+
+ ! from our tuning
+ bb1 = 2.0
+ bb2 = 4.0
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad1 (i)
+ dz = zm (i, k + 1) - zm (i, k)
+ ! tem = 0.25 * bb1 * (xlamde (i, k) + xlamde (i, k + 1)) * dz
+ tem = 0.5 * bb1 * xlamde (i, k) * dz
+ tem1 = bb2 * buo (i, k + 1) * dz
+ ptem1 = 1. + tem
+ wd2 (i, k) = tem1 / ptem1
+ endif
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad1 (i)) then
+ dz = zm (i, k + 1) - zm (i, k)
+ tem = 0.25 * bb1 * (xlamde (i, k) + xlamde (i, k + 1)) * dz
+ tem1 = bb2 * buo (i, k + 1) * dz
+ ptem = (1. - tem) * wd2 (i, k + 1)
+ ptem1 = 1. + tem
+ wd2 (i, k) = (ptem + tem1) / ptem1
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ mrady (i) = mrad (i)
+ if (flg (i)) mradx (i) = krad (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k < krad (i)) then
+ if (wd2 (i, k) > 0.) then
+ mradx (i) = k
+ else
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (mrad (i) < mradx (i)) then
+ mrad (i) = mradx (i)
+ endif
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = krad (i) - mrad (i)
+ if (kk < 1) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! update entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmscu
+ do i = 1, im
+ if (cnvflg (i) .and. mrady (i) < mradx (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ if (k >= mrad (i) .and. k < krad (i)) then
+ if (mrad (i) == 1) then
+ ptem = 1. / (zm (i, k) + dz)
+ else
+ ptem = 1. / (zm (i, k) - zm (i, mrad (i) - 1) + dz)
+ endif
+ tem = max ((hrad (i) - zm (i, k) + dz), dz)
+ ptem1 = 1. / tem
+ xlamde (i, k) = ce0 * (ptem + ptem1)
+ else
+ xlamde (i, k) = ce0 / dz
+ endif
+ xlamdem (i, k) = cm * xlamde (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate averaged over the whole downdraft layers
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ xlamavg (i) = 0.
+ sumx (i) = 0.
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k >= mrad (i) .and. k < krad (i))) then
+ dz = zl (i, k + 1) - zl (i, k)
+ xlamavg (i) = xlamavg (i) + xlamde (i, k) * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamavg (i) = xlamavg (i) / sumx (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft mass flux
+ ! -----------------------------------------------------------------------
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k >= mrad (i) .and. k < krad (i))) then
+ if (wd2 (i, k) > 0.) then
+ tem = sqrt (wd2 (i, k))
+ else
+ tem = 0.
+ endif
+ xmfd (i, k) = ra1 (i) * tem
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft fraction as a function of mean entrainment rate
+ ! (grell & freitas, 2014)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = 0.2 / xlamavg (i)
+ tem1 = 3.14 * tem * tem
+ sigma (i) = tem1 / (gdx (i) * gdx (i))
+ sigma (i) = max (sigma (i), 0.001)
+ sigma (i) = min (sigma (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute scale - aware function based on arakawa & wu (2013)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sigma (i) > ra1 (i)) then
+ scaldfunc (i) = (1. - sigma (i)) * (1. - sigma (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final scale - aware downdraft mass flux
+ ! -----------------------------------------------------------------------
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k >= mrad (i) .and. k < krad (i))) then
+ xmfd (i, k) = scaldfunc (i) * xmfd (i, k)
+ dz = zl (i, k + 1) - zl (i, k)
+ xmmx = dz / dt2
+ xmfd (i, k) = min (xmfd (i, k), xmmx)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft property using updated entranment rate
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad (i)
+ thld (i, k) = thlx (i, k)
+ endif
+ enddo
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! k = krad (i)
+ ! ptem1 = max (qcdo (i, k, ntcw), 0.)
+ ! tld = thld (i, k) / pix (i, k)
+ ! tcdo (i, k) = tld + elocp * ptem1
+ ! qcdo (i, k, 1) = qcdo (i, k, 1) + 0.2 * qcdo (i, k, 1)
+ ! qcdo (i, k, ntcw) = qcdo (i, k, ntcw) + 0.2 * qcdo (i, k, ntcw)
+ ! endif
+ ! enddo
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k >= mrad (i) .and. k < krad (i))) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ thld (i, k) = ((1. - tem) * thld (i, k + 1) + tem * &
+ (thlx (i, k) + thlx (i, k + 1))) / factor
+ qtd (i, k) = ((1. - tem) * qtd (i, k + 1) + tem * &
+ (qtx (i, k) + qtx (i, k + 1))) / factor
+
+ tld = thld (i, k) / pix (i, k)
+ es = 0.01 * mqs (tld) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtd (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tld ** 2)
+ qld = dq / (1. + gamma)
+ qtd (i, k) = qs + qld
+ qcdo (i, k, 1) = qs
+ qcdo (i, k, ntcw) = qld
+ tcdo (i, k) = tld + elocp * qld
+ else
+ qcdo (i, k, 1) = qtd (i, k)
+ qcdo (i, k, ntcw) = 0.
+ tcdo (i, k) = tld
+ endif
+
+ endif
+ enddo
+ enddo
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamdem (i, k) * dz
+ factor = 1. + tem
+ ptem = tem - pgcon
+ ptem1 = tem + pgcon
+
+ ucdo (i, k) = ((1. - tem) * ucdo (i, k + 1) + ptem * u1 (i, k + 1) &
+ + ptem1 * u1 (i, k)) / factor
+ vcdo (i, k) = ((1. - tem) * vcdo (i, k + 1) + ptem * v1 (i, k + 1) &
+ + ptem1 * v1 (i, k)) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ if (ntcw > 2) then
+
+ do n = 2, ntcw - 1
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ qcdo (i, k, n) = ((1. - tem) * qcdo (i, k + 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k + 1, n))) / factor
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ndc = ntrac1 - ntcw
+
+ if (ndc > 0) then
+
+ do n = ntcw + 1, ntrac1
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ qcdo (i, k, n) = ((1. - tem) * qcdo (i, k + 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k + 1, n))) / factor
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ return
+
+end subroutine mfscu
+
+! =======================================================================
+! routine to solve the tridiagonal system to calculate temperature and
+! moisture at \f$ t + \delta t \f$; part of two - part process to
+! calculate time tendencies due to vertical diffusion.
+! =======================================================================
+
+subroutine tridi2 (l, n, cl, cm, cu, r1, r2, au, a1, a2)
+
+ implicit none
+
+ integer :: k, n, l, i
+
+ real :: fk
+
+ real :: cl (l, 2:n), cm (l, n), cu (l, n - 1), r1 (l, n), r2 (l, n), &
+ au (l, n - 1), a1 (l, n), a2 (l, n)
+
+ do i = 1, l
+ fk = 1. / cm (i, 1)
+ au (i, 1) = fk * cu (i, 1)
+ a1 (i, 1) = fk * r1 (i, 1)
+ a2 (i, 1) = fk * r2 (i, 1)
+ enddo
+ do k = 2, n - 1
+ do i = 1, l
+ fk = 1. / (cm (i, k) - cl (i, k) * au (i, k - 1))
+ au (i, k) = fk * cu (i, k)
+ a1 (i, k) = fk * (r1 (i, k) - cl (i, k) * a1 (i, k - 1))
+ a2 (i, k) = fk * (r2 (i, k) - cl (i, k) * a2 (i, k - 1))
+ enddo
+ enddo
+ do i = 1, l
+ fk = 1. / (cm (i, n) - cl (i, n) * au (i, n - 1))
+ a1 (i, n) = fk * (r1 (i, n) - cl (i, n) * a1 (i, n - 1))
+ a2 (i, n) = fk * (r2 (i, n) - cl (i, n) * a2 (i, n - 1))
+ enddo
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ a1 (i, k) = a1 (i, k) - au (i, k) * a1 (i, k + 1)
+ a2 (i, k) = a2 (i, k) - au (i, k) * a2 (i, k + 1)
+ enddo
+ enddo
+
+end subroutine tridi2
+
+! =======================================================================
+! routine to solve the tridiagonal system to calculate u - and v -
+! momentum at \f$ t + \delta t \f$; part of two - part process to
+! calculate time tendencies due to vertical diffusion.
+! =======================================================================
+
+subroutine tridin (l, n, nt, cl, cm, cu, r1, r2, au, a1, a2)
+
+ implicit none
+
+ integer :: is, k, kk, n, nt, l, i
+
+ real :: fk (l)
+
+ real :: cl (l, 2:n), cm (l, n), cu (l, n - 1), &
+ r1 (l, n), r2 (l, n * nt), &
+ au (l, n - 1), a1 (l, n), a2 (l, n * nt), &
+ fkk (l, 2:n - 1)
+
+ do i = 1, l
+ fk (i) = 1. / cm (i, 1)
+ au (i, 1) = fk (i) * cu (i, 1)
+ a1 (i, 1) = fk (i) * r1 (i, 1)
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ a2 (i, 1 + is) = fk (i) * r2 (i, 1 + is)
+ enddo
+ enddo
+ do k = 2, n - 1
+ do i = 1, l
+ fkk (i, k) = 1. / (cm (i, k) - cl (i, k) * au (i, k - 1))
+ au (i, k) = fkk (i, k) * cu (i, k)
+ a1 (i, k) = fkk (i, k) * (r1 (i, k) - cl (i, k) * a1 (i, k - 1))
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = 2, n - 1
+ do i = 1, l
+ a2 (i, k + is) = fkk (i, k) * (r2 (i, k + is) - cl (i, k) * a2 (i, k + is - 1))
+ enddo
+ enddo
+ enddo
+ do i = 1, l
+ fk (i) = 1. / (cm (i, n) - cl (i, n) * au (i, n - 1))
+ a1 (i, n) = fk (i) * (r1 (i, n) - cl (i, n) * a1 (i, n - 1))
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ a2 (i, n + is) = fk (i) * (r2 (i, n + is) - cl (i, n) * a2 (i, n + is - 1))
+ enddo
+ enddo
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ a1 (i, k) = a1 (i, k) - au (i, k) * a1 (i, k + 1)
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ a2 (i, k + is) = a2 (i, k + is) - au (i, k) * a2 (i, k + is + 1)
+ enddo
+ enddo
+ enddo
+
+end subroutine tridin
+
+end module sa_tke_edmf_mod
diff --git a/model/sa_tke_edmf_new.F90 b/model/sa_tke_edmf_new.F90
new file mode 100644
index 000000000..e1cd4e880
--- /dev/null
+++ b/model/sa_tke_edmf_new.F90
@@ -0,0 +1,5182 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+! =======================================================================
+! A New Scale-Aware Turbulent-Kinetic-Energy based Moist-Eddy-Diffusivity-Mass-Flux
+! (SA-TKE-EDMF-NEW) Subgrid Vertical Turbulence Mixing Scheme
+! For the convective boundary layer, the scheme adopts EDMF parameterization
+! (Siebesma et al. 2007) to take into account non-local transport by
+! large eddies (mfpbltq.f).
+! A new mass-flux parameterizaiton for stratocumulus-top-induced turbulence
+! mixing has been introduced (previously, it was eddy diffusion form) (mfscuq.f).
+! For local turbulence mixing, a TKE closure model is used.
+! Developers: Jongil Han, Kun Gao, Linjiong Zhou, and the GFDL FV3 Team
+! References: Han et al. (2016), Han and Bretherton (2019)
+! =======================================================================
+
+! =======================================================================
+! Updates at GFDL:
+! 1) May 2019 by Jongil Han
+! goals: to have better low-level inversion,
+! to reduce the cold bias in lower troposphere,
+! to reduce the negative wind speed bias in upper troposphere
+! changes: reduce the minimum and maximum characteristic mixing lengths,
+! reduce core downdraft and updraft fractions,
+! change of updraft top height calculation,
+! reduce the background diffusivity with increasing surface layer stability (for inversion)
+! 2) Jul 2019 by Kun Gao
+! goal: to allow for tke advection
+! change: rearange tracers (q1g)
+! TKE no longer needs to be the last tracer
+! 3) Nov 2019 by Kun Gao
+! turn off non-local mixing for hydrometers to avoid unphysical negative values
+! 4) Jan 2020 by Kun Gao
+! add rlmn2 parameter (set to 10.) to be consistent with emc's version
+! 5) Jun 2020 by Kun Gao
+! a) add option for turning off upper-limter on background diff. in inversion layer
+! over land/ice points (cap_k0_land)
+! b) use different xkzm_m, xkzm_h for land, ocean and sea ice points
+! c) add option for turning off hb19 formula for surface backgroud diff. (do_dk_hb19)
+! 6) Jul 2020 by Jongil Han to significant revisions to improve scu
+! a) revised xkzo and rlmnz in inversion layer
+! b) limited updraft overshooting
+! 7) Oct 2024 by Linjiong Zhou
+! put it into the FV3 dynamical core and revise accordingly
+! =======================================================================
+
+module sa_tke_edmf_new_mod
+
+ use fms_mod, only: check_nml_error
+ use gfdl_mp_mod, only: mqs
+
+ implicit none
+
+ private
+
+ ! -----------------------------------------------------------------------
+ ! public subroutines, functions, and variables
+ ! -----------------------------------------------------------------------
+
+ public :: sa_tke_edmf_new_init
+ public :: sa_tke_edmf_new_pbl
+ public :: sa_tke_edmf_new_sfc
+
+ ! -----------------------------------------------------------------------
+ ! physics constants
+ ! -----------------------------------------------------------------------
+
+ real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS
+
+ real, parameter :: sbc = 5.670400e-8 ! Stefan-Boltzmann constant (kg/s^3/K^4)
+
+ 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 :: zvir = rvgas / rdgas - 1. ! 0.6077667316114637
+ real, parameter :: eps = rdgas / rvgas ! 0.6219934994582882
+ real, parameter :: epsm1 = rdgas / rvgas - 1. ! -0.3780065005417118
+
+ real, parameter :: t0ice = 273.15 ! freezing temperature (K): ref: GFDL, GFS
+ real, parameter :: tgice = 271.2 ! freezing temperature at sea (K)
+
+ real, parameter :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS
+ real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K)
+
+ real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS
+
+ 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
+
+ ! -----------------------------------------------------------------------
+ ! namelist parameters
+ ! -----------------------------------------------------------------------
+
+ logical :: cap_k0_land = .true. ! flag for applying limter on background diff in inversion
+ logical :: do_dk_hb19 = .false. ! flag for using hb19 formula for background diff
+ logical :: dspheat = .false. ! flag for tke dissipative heating
+ logical :: sfc_gfdl = .false. ! flag for using updated sfc layer scheme
+
+ logical :: use_lup_only = .false. ! flag for using l_up as l2
+ logical :: use_l1_sfc = .false. ! flag for using l1 as l at lowest layer
+ logical :: use_tke_pbl = .false. ! flag for adjusting entrainment/detrainment rate
+ logical :: use_shear_pbl = .false. ! flag for considering shear effect on updraft/downdraft diagnosis
+
+ logical :: redrag = .false. ! flag for reduced drag coeff. over sea
+ logical :: do_z0_moon = .false. ! flag for using z0 scheme in Moon et al. 2007
+ logical :: do_z0_hwrf15 = .false. ! flag for using z0 scheme in 2015 HWRF
+ logical :: do_z0_hwrf17 = .false. ! flag for using z0 scheme in 2017 HWRF
+ logical :: do_z0_hwrf17_hwonly = .false. ! flag for using z0 scheme in 2017 HWRF only under high wind
+
+ integer :: ivegsrc = 2 ! ivegsrc = 0 => USGS,
+ ! ivegsrc = 1 => IGBP (20 category)
+ ! ivegsrc = 2 => UMD (13 category)
+
+ integer :: l2_diag_opt = 0 ! flag for choosing a diagnosis method for l2
+ integer :: l1l2_blend_opt = 0 ! flag for choosing a blending method for l1 and l2
+
+ real :: xkzm_mo = 1.0 ! bkgd_vdif_m background vertical diffusion for momentum over ocean
+ real :: xkzm_ho = 1.0 ! bkgd_vdif_h background vertical diffusion for heat q over ocean
+ real :: xkzm_ml = 1.0 ! bkgd_vdif_m background vertical diffusion for momentum over land
+ real :: xkzm_hl = 1.0 ! bkgd_vdif_h background vertical diffusion for heat q over land
+ real :: xkzm_mi = 1.0 ! bkgd_vdif_m background vertical diffusion for momentum over ice
+ real :: xkzm_hi = 1.0 ! bkgd_vdif_h background vertical diffusion for heat q over ice
+ real :: xkzm_s = 1.0 ! bkgd_vdif_s sigma threshold for background mom. diffusion
+ real :: xkzm_lim = 0.01 ! background vertical diffusion limit
+ real :: xkzm_fac = 1.0 ! background vertical diffusion factor
+ real :: xkzinv = 0.15 ! diffusivity in inversion layers
+ real :: xkgdx = 25.e3 ! background vertical diffusion threshold
+ real :: rlmn = 30. ! lower-limter on asymtotic mixing length in satmedmfdiff.f
+ real :: rlmx = 300. ! upper-limter on asymtotic mixing length in satmedmfdiff.f
+
+ real :: zolcru = - 0.02 ! a threshold for activating the surface-driven updraft transports
+ real :: dspfac = 0.5 ! tke dissipative heating factor
+ real :: bl_upfr = 0.13 ! updraft fraction in boundary layer mass flux scheme
+ real :: bl_dnfr = 0.1 ! downdraft fraction in boundary layer mass flux scheme
+ real :: cs0 = 0.2 ! a parameter that controls the shear effect on the mixing length
+
+ real :: czilc = 0.8 ! Zilintkivitch constant
+ real :: z0s_max = .317e-2 ! a limiting value for z0 under high windskk
+ real :: wind_th_hwrf = 33. ! wind speed threshold when z0 level off as in HWRF
+
+ real :: ck0 = 0.4 ! proportionality coefficient for momentum in PBL
+ real :: ck1 = 0.15 ! proportionality coefficient for momentum above PBL
+ real :: ch0 = 0.4 ! proportionality coefficient for heat & q in PBL
+ real :: ch1 = 0.15 ! proportionality coefficient for heat & q above PBL
+
+ ! -----------------------------------------------------------------------
+ ! namelist
+ ! -----------------------------------------------------------------------
+
+ namelist / sa_tke_edmf_new_nml / &
+ xkzm_mo, xkzm_ho, xkzm_ml, xkzm_hl, xkzm_mi, xkzm_hi, xkzm_s, &
+ xkzm_lim, xkzm_fac, xkzinv, xkgdx, rlmn, rlmx, sfc_gfdl, &
+ cap_k0_land, do_dk_hb19, dspheat, redrag, do_z0_moon, &
+ do_z0_hwrf15, do_z0_hwrf17, do_z0_hwrf17_hwonly, czilc, &
+ z0s_max, wind_th_hwrf, ivegsrc, ck0, ck1, ch0, ch1, &
+ zolcru, dspfac, bl_upfr, bl_dnfr, cs0, l2_diag_opt, l1l2_blend_opt, &
+ use_lup_only, use_l1_sfc, use_tke_pbl, use_shear_pbl
+
+contains
+
+! =======================================================================
+! SA-TKE-EDMF-NEW initialization
+! =======================================================================
+
+subroutine sa_tke_edmf_new_init (input_nml_file, logunit)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: logunit
+
+ character (len = *), intent (in) :: input_nml_file (:)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: ios, ierr
+
+ ! -----------------------------------------------------------------------
+ ! read namelist
+ ! -----------------------------------------------------------------------
+
+ read (input_nml_file, nml = sa_tke_edmf_new_nml, iostat = ios)
+ ierr = check_nml_error (ios, 'sa_tke_edmf_new_nml')
+
+ ! -----------------------------------------------------------------------
+ ! write namelist to log file
+ ! -----------------------------------------------------------------------
+
+ write (logunit, *) " ================================================================== "
+ write (logunit, *) "sa_tke_edmf_new_mod"
+ write (logunit, nml = sa_tke_edmf_new_nml)
+
+end subroutine sa_tke_edmf_new_init
+
+! =======================================================================
+! SA-TKE-EDMF-NEW scheme
+! =======================================================================
+
+subroutine sa_tke_edmf_new_pbl (im, km, ntrac, ntcw, ntiw, ntke, &
+ delt, u1, v1, t1, q1, gsize, islimsk, &
+ radh, rbsoil, sigmaf, zorl, u10m, v10m, fm, fh, &
+ tsea, heat, evap, stress, spd1, kinver, &
+ psk, del, prsi, prsl, prslk, phii, phil, &
+ hpbl, kpbl, dusfc, dvsfc, dtsfc, dqsfc, dkt_out, &
+ flux_up, flux_dn)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, km, ntrac, ntcw, ntiw, ntke
+ integer, intent (in) :: kinver (im), islimsk (im)
+
+ real, intent (in) :: delt
+ real, intent (in) :: radh (im, km), gsize (im), &
+ psk (im), rbsoil (im), &
+ zorl (im), tsea (im), &
+ u10m (im), v10m (im), &
+ fm (im), fh (im), &
+ evap (im), heat (im), &
+ stress (im), spd1 (im), &
+ prsi (im, km + 1), del (im, km), &
+ prsl (im, km), prslk (im, km), &
+ phii (im, km + 1), phil (im, km), &
+ sigmaf (im)
+
+ real, intent (inout) :: u1 (im, km), v1 (im, km), &
+ t1 (im, km), q1 (im, km, ntrac)
+
+ integer, intent (out) :: kpbl (im)
+
+ real, intent (out) :: hpbl (im)
+
+ real, intent (out), optional :: dusfc (im), dvsfc (im), dtsfc (im), dqsfc (im), &
+ dkt_out (im, km), flux_up (im, km), flux_dn (im, km)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, is, k, kk, n, ndt, km1, kmpbl, kmscu, ntrac1, kps, ntcw_new
+ integer :: lcld (im), kcld (im), krad (im), mrad (im)
+ integer :: kx1 (im), kpblx (im)
+
+ real :: tke (im, km), tkeh (im, km - 1), e2 (im, 0:km)
+
+ real :: theta (im, km), thvx (im, km), thlvx (im, km), &
+ qlx (im, km), thetae (im, km), thlx (im, km), &
+ slx (im, km), svx (im, km), qtx (im, km), &
+ tvx (im, km), pix (im, km), radx (im, km - 1), &
+ dku (im, km - 1), dkt (im, km - 1), dkq (im, km - 1), &
+ cku (im, km - 1), ckt (im, km - 1), q1g (im, km, ntrac), &
+ vdt (im, km), udt (im, km), tdt (im, km), qdt (im, km)
+
+ real :: plyr (im, km), rhly (im, km), cfly (im, km), &
+ qstl (im, km)
+
+ real :: dtdz1 (im), gdx (im), &
+ phih (im), phim (im), &
+ phims (im), prn (im, km - 1), &
+ rbdn (im), rbup (im), thermal (im), &
+ ustar (im), wstar (im), hpblx (im), &
+ ust3 (im), wst3 (im), &
+ z0 (im), crb (im), &
+ hgamt (im), hgamq (im), &
+ wscale (im), vpert (im), &
+ zol (im), sflux (im), &
+ tx1 (im), tx2 (im), &
+ vez0fun (im), tkemean (im), sumx (im), &
+ zvfun (im)
+
+ real :: vegflo, vegfup, z0lo, z0up, vc0, zc0, csmf, z0fun
+
+ real :: radmin (im)
+
+ real :: zi (im, km + 1), zl (im, km), zm (im, km), &
+ xkzo (im, km), xkzmo (im, km), &
+ xkzm_hx (im), xkzm_mx (im), &
+ ri (im, km - 1), tkmnz (im, km - 1), &
+ rdzt (im, km - 1), rlmnz (im, km), &
+ al (im, km - 1), ad (im, km), au (im, km - 1), &
+ f1 (im, km), f2 (im, km * (ntrac - 1))
+
+ real :: elm (im, km), ele (im, km), &
+ ckz (im, km), chz (im, km), frik (im), &
+ diss (im, km - 1), prod (im, km - 1), &
+ bf (im, km - 1), shr2 (im, km - 1), wush (im, km), &
+ xlamue (im, km - 1), xlamde (im, km - 1), &
+ gotvx (im, km), rlam (im, km - 1)
+
+ ! variables for updrafts (thermals)
+ real :: tcko (im, km), qcko (im, km, ntrac), &
+ ucko (im, km), vcko (im, km), &
+ buou (im, km), xmf (im, km)
+
+ ! variables for stratocumulus - top induced downdrafts
+ real :: tcdo (im, km), qcdo (im, km, ntrac), &
+ ucdo (im, km), vcdo (im, km), &
+ buod (im, km), xmfd (im, km)
+
+ logical :: pblflg (im), sfcflg (im), flg (im)
+ logical :: scuflg (im), pcnvflg (im)
+ logical :: mlenflg
+
+ ! pcnvflg: true for unstable pbl
+ real :: aphi16, aphi5, &
+ wfac, cfac, &
+ gamcrt, gamcrq, sfcfrac, &
+ conq, cont, conw, &
+ dsdz2, dsdzt, dkmax, &
+ dsig, dt2, dtodsd, &
+ dtodsu, g, factor, dz, &
+ gocp, gravi, zol1, &
+ buop, shrp, dtn, &
+ prnum, prmax, prmin, prtke, &
+ prscu, pr0, &
+ dw2, dw2min, zk, &
+ elmfac, elefac, dspmax, &
+ alp, clwt, cql, &
+ f0, robn, crbmin, crbmax, &
+ es, qs, value, onemrh, &
+ cfh, gamma, elocp, el2orc, &
+ epsi, beta, chx, cqx, &
+ rdt, rdz, qmin, qlmin, &
+ rimin, rbcr, rbint, tdzmin, &
+ rlmn, rlmn1, rlmn2, &
+ elmx, &
+ ttend, utend, vtend, qtend, &
+ zfac, zfmin, vk, spdk2, &
+ tkmin, tkminx, &
+ zlup, zldn, bsum, &
+ tem, tem1, tem2, tem3, &
+ ptem, ptem0, ptem1, ptem2
+
+ real :: ck0, ck1, ch0, ch1, ce0, rchck
+
+ real :: qlcr, zstblmax, hcrinv
+
+ real :: h1
+
+ parameter (gravi = 1.0 / grav)
+ parameter (g = grav)
+ parameter (gocp = g / cp_air)
+ parameter (cont = cp_air / g, conq = hlv / g, conw = 1.0 / g) ! for del in pa
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (wfac = 7.0, cfac = 4.5)
+ parameter (gamcrt = 3., gamcrq = 0., sfcfrac = 0.1)
+ parameter (vk = 0.4, rimin = - 100.)
+ parameter (rbcr = 0.25, tdzmin = 1.e-3)
+ parameter (rlmn = 30., rlmn1 = 5., rlmn2 = 10.)
+ parameter (prmin = 0.25, prmax = 4.0)
+ parameter (pr0 = 1.0, prtke = 1.0, prscu = 0.67)
+ parameter (f0 = 1.e-4, crbmin = 0.15, crbmax = 0.35)
+ parameter (tkmin = 1.e-9, tkminx = 0.2, dspmax = 10.0)
+ parameter (qmin = 1.e-8, qlmin = 1.e-12, zfmin = 1.e-8)
+ parameter (aphi5 = 5., aphi16 = 16.)
+ parameter (elmfac = 1.0, elefac = 1.0, cql = 100.)
+ parameter (dw2min = 1.e-4, dkmax = 1000.)
+ parameter (qlcr = 3.5e-5, zstblmax = 2500.) !, xkzinv = 0.1)
+ parameter (h1 = 0.33333333, hcrinv = 250.)
+ parameter (ck0 = 0.4, ck1 = 0.15, ch0 = 0.4, ch1 = 0.15)
+ parameter (ce0 = 0.4)
+ parameter (rchck = 1.5, ndt = 20)
+ parameter (vegflo = 0.1, vegfup = 1.0, z0lo = 0.1, z0up = 1.0)
+ parameter (vc0 = 1.0, zc0 = 1.0)
+ parameter (csmf = 0.5)
+
+ elmx = rlmx
+
+ if (present (dkt_out)) dkt_out = 0.
+ if (present (flux_up)) flux_up = 0.
+ if (present (flux_dn)) flux_dn = 0.
+
+ ! -----------------------------------------------------------------------
+ ! kgao note (jul 2019)
+ ! the code was originally written assuming ntke = ntrac
+ ! in this version ntke does not need to be equal to ntrac
+ ! in the following we rearrange q1g so that tke is the last tracer
+ ! -----------------------------------------------------------------------
+
+ !if (ntrac >= 3) then
+ if (ntke == ntrac) then ! tke is the last tracer
+ q1g (:, :, :) = q1 (:, :, :)
+ else ! tke is not
+ do kk = 1, ntke - 1
+ q1g (:, :, kk) = q1 (:, :, kk)
+ enddo
+ do kk = ntke + 1, ntrac
+ q1g (:, :, kk - 1) = q1 (:, :, kk)
+ enddo
+ q1g (:, :, ntrac) = q1 (:, :, ntke)
+ endif
+ !endif
+
+ dt2 = delt
+ rdt = 1. / dt2
+
+ ntrac1 = ntrac - 1
+ km1 = km - 1
+ kmpbl = km / 2
+ kmscu = km / 2
+
+ do k = 1, km
+ do i = 1, im
+ zi (i, k) = phii (i, k) * gravi
+ zl (i, k) = phil (i, k) * gravi
+ xmf (i, k) = 0.
+ xmfd (i, k) = 0.
+ buou (i, k) = 0.
+ buod (i, k) = 0.
+ ckz (i, k) = ck1
+ chz (i, k) = ch1
+ rlmnz (i, k) = rlmn
+ enddo
+ enddo
+
+ do i = 1, im
+ frik (i) = 1.0
+ enddo
+ do i = 1, im
+ zi (i, km + 1) = phii (i, km + 1) * gravi
+ enddo
+ do k = 1, km
+ do i = 1, im
+ zm (i, k) = zi (i, k + 1)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! horizontal grid size
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ gdx (i) = gsize (i)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ tke (i, k) = max (q1 (i, k, ntke), tkmin) ! tke at layer centers
+ enddo
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ tkeh (i, k) = 0.5 * (tke (i, k) + tke (i, k + 1)) ! tke at interfaces
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ rdzt (i, k) = 1.0 / (zl (i, k + 1) - zl (i, k))
+ prn (i, k) = pr0
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! han and bretherton, 2019
+ ! set background diffusivities as a function of
+ ! horizontal grid size with xkzm_h & xkzm_m for gdx >= xkgdx
+ ! and 0.01 for gdx = 5m, i.e.,
+ ! xkzm_hx = 0.01 + (xkzm_h - 0.01) / (xkgdx - 5.) * (gdx - 5.)
+ ! xkzm_mx = 0.01 + (xkzm_h - 0.01) / (xkgdx - 5.) * (gdx - 5.)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ kx1 (i) = 1
+ tx1 (i) = 1.0 / prsi (i, 1)
+ tx2 (i) = tx1 (i)
+
+ ! -----------------------------------------------------------------------
+ ! kgao change - set surface value of background diff (dk) below
+ ! -----------------------------------------------------------------------
+
+ !if (gdx (i) >= xkgdx) then
+ ! xkzm_hx (i) = xkzm_h
+ ! xkzm_mx (i) = xkzm_m
+ !else
+ ! tem = 1. / (xkgdx - 5.)
+ ! tem1 = (xkzm_h - 0.01) * tem
+ ! tem2 = (xkzm_m - 0.01) * tem
+ ! ptem = gdx (i) - 5.
+ ! xkzm_hx (i) = 0.01 + tem1 * ptem
+ ! xkzm_mx (i) = 0.01 + tem2 * ptem
+ !endif
+
+ if (do_dk_hb19) then ! use eq43 in hb2019
+
+ if (gdx (i) >= xkgdx) then ! resolution coarser than xkgdx
+ if (islimsk (i) == 1) then ! land points
+ xkzm_hx (i) = xkzm_hl
+ xkzm_mx (i) = xkzm_ml
+ elseif (islimsk (i) == 2) then! sea ice points
+ xkzm_hx (i) = xkzm_hi
+ xkzm_mx (i) = xkzm_mi
+ else ! ocean points
+ xkzm_hx (i) = xkzm_ho
+ xkzm_mx (i) = xkzm_mo
+ endif
+ else ! resolution finer than xkgdx
+ tem = 1. / (xkgdx - 5.)
+ if (islimsk (i) == 1) then ! land points
+ tem1 = (xkzm_hl - xkzm_lim) * tem
+ tem2 = (xkzm_ml - xkzm_lim) * tem
+ elseif (islimsk (i) == 2) then! sea ice points
+ tem1 = (xkzm_hi - xkzm_lim) * tem
+ tem2 = (xkzm_mi - xkzm_lim) * tem
+ else ! ocean points
+ tem1 = (xkzm_ho - xkzm_lim) * tem
+ tem2 = (xkzm_mo - xkzm_lim) * tem
+ endif
+ ptem = gdx (i) - 5.
+ xkzm_hx (i) = xkzm_lim + tem1 * ptem
+ xkzm_mx (i) = xkzm_lim + tem2 * ptem
+ endif
+
+ else ! use values in the namelist; no res dependency
+
+ if (islimsk (i) == 1) then ! land points
+ xkzm_hx (i) = xkzm_hl
+ xkzm_mx (i) = xkzm_ml
+ elseif (islimsk (i) == 2) then ! sea ice points
+ xkzm_hx (i) = xkzm_hi
+ xkzm_mx (i) = xkzm_mi
+ else ! ocean points
+ xkzm_hx (i) = xkzm_ho
+ xkzm_mx (i) = xkzm_mo
+ endif
+
+ endif
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ xkzo (i, k) = 0.0
+ xkzmo (i, k) = 0.0
+ if (k < kinver (i)) then
+ ! -----------------------------------------------------------------------
+ ! vertical background diffusivity
+ ! -----------------------------------------------------------------------
+ ptem = prsi (i, k + 1) * tx1 (i)
+ tem1 = 1.0 - ptem
+ tem2 = tem1 * tem1 * 10.0
+ tem2 = min (1.0, exp (- tem2))
+ xkzo (i, k) = xkzm_hx (i) * tem2
+
+ ptem = prsl (i, k) * tx1 (i)
+ tem1 = 1.0 - ptem
+ tem2 = tem1 * tem1 * 2.5
+ tem2 = min (1.0, exp (- tem2))
+ rlmnz (i, k) = rlmn * tem2
+ rlmnz (i, k) = max (rlmnz (i, k), rlmn1)
+ ! -----------------------------------------------------------------------
+ ! vertical background diffusivity for momentum
+ ! -----------------------------------------------------------------------
+ if (ptem >= xkzm_s) then
+ xkzmo (i, k) = xkzm_mx (i)
+ kx1 (i) = k + 1
+ else
+ if (k == kx1 (i) .and. k > 1) tx2 (i) = 1.0 / prsi (i, k)
+ tem1 = 1.0 - prsi (i, k + 1) * tx2 (i)
+ tem1 = tem1 * tem1 * 5.0
+ xkzmo (i, k) = xkzm_mx (i) * min (1.0, exp (- tem1))
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ z0 (i) = 0.01 * zorl (i)
+ if (present (dusfc)) dusfc (i) = 0.
+ if (present (dvsfc)) dvsfc (i) = 0.
+ if (present (dtsfc)) dtsfc (i) = 0.
+ if (present (dqsfc)) dqsfc (i) = 0.
+ kpbl (i) = 1
+ hpbl (i) = 0.
+ kpblx (i) = 1
+ hpblx (i) = 0.
+ pblflg (i) = .true.
+ sfcflg (i) = .true.
+ if (rbsoil (i) > 0.) sfcflg (i) = .false.
+ pcnvflg (i) = .false.
+ scuflg (i) = .true.
+ if (scuflg (i)) then
+ radmin (i) = 0.
+ mrad (i) = km1
+ krad (i) = 1
+ lcld (i) = km1
+ kcld (i) = km1
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute a function for green vegetation fraction and surface roughness
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ !tem = (sigmaf (i) - vegflo) / (vegfup - vegflo)
+ !tem = min (max (tem, 0.), 1.)
+ !tem1 = sqrt (tem)
+ !ptem = (z0 (i) - z0lo) / (z0up - z0lo)
+ !ptem = min (max (ptem, 0.), 1.)
+ vez0fun (i) = 1. ! (1. + vc0 * tem1) * (1. + zc0 * ptem)
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ pix (i, k) = psk (i) / prslk (i, k)
+ theta (i, k) = t1 (i, k) * pix (i, k)
+ if (ntiw > 0) then
+ tem = max (q1 (i, k, ntcw), qlmin)
+ tem1 = max (q1 (i, k, ntiw), qlmin)
+ qlx (i, k) = tem + tem1
+ ptem = hlv * tem + (hlv + hlf) * tem1
+ slx (i, k) = cp_air * t1 (i, k) + phil (i, k) - ptem
+ else
+ qlx (i, k) = max (q1 (i, k, ntcw), qlmin)
+ slx (i, k) = cp_air * t1 (i, k) + phil (i, k) - hlv * qlx (i, k)
+ endif
+ tem2 = 1. + zvir * max (q1g (i, k, 1), qmin) - qlx (i, k)
+ thvx (i, k) = theta (i, k) * tem2
+ tvx (i, k) = t1 (i, k) * tem2
+ qtx (i, k) = max (q1g (i, k, 1), qmin) + qlx (i, k)
+ thlx (i, k) = theta (i, k) - pix (i, k) * elocp * qlx (i, k)
+ thlvx (i, k) = thlx (i, k) * (1. + zvir * qtx (i, k))
+ svx (i, k) = cp_air * tvx (i, k)
+ ptem1 = elocp * pix (i, k) * max (q1g (i, k, 1), qmin)
+ thetae (i, k) = theta (i, k) + ptem1
+ gotvx (i, k) = g / tvx (i, k)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute an empirical cloud fraction based on
+ ! xu & randall's (1996, jas) study
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ plyr (i, k) = 0.01 * prsl (i, k) ! pa to mb (hpa)
+ ! compute relative humidity
+ es = 0.01 * mqs (t1 (i, k)) ! mqs in pa
+ ! revise it to a stable format -- Linjiong Zhou, 7/19/2022
+ ! qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ qs = max (qmin, es / plyr (i, k) * eps * (1 + zvir * q1g (i, k, 1)))
+ rhly (i, k) = max (0.0, min (1.0, max (qmin, q1g (i, k, 1)) / qs))
+ qstl (i, k) = qs
+ enddo
+ enddo
+
+ do k = 1, km
+ do i = 1, im
+ cfly (i, k) = 0.
+ clwt = 1.0e-6 * (plyr (i, k) * 0.001)
+ if (qlx (i, k) > clwt) then
+ onemrh = max (1.e-10, 1.0 - rhly (i, k))
+ tem1 = min (max ((onemrh * qstl (i, k)) ** 0.49, 0.0001), 1.0)
+ tem1 = cql / tem1
+ value = max (min (tem1 * qlx (i, k), 50.0), 0.0)
+ tem2 = sqrt (sqrt (rhly (i, k)))
+ cfly (i, k) = min (max (tem2 * (1.0 - exp (- value)), 0.0), 1.0)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy modified by clouds
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ tem = 0.5 * (svx (i, k) + svx (i, k + 1))
+ tem1 = 0.5 * (t1 (i, k) + t1 (i, k + 1))
+ tem2 = 0.5 * (qstl (i, k) + qstl (i, k + 1))
+ cfh = min (cfly (i, k + 1), 0.5 * (cfly (i, k) + cfly (i, k + 1)))
+ alp = g / tem
+ gamma = el2orc * tem2 / (tem1 ** 2)
+ epsi = tem1 / elocp
+ beta = (1. + gamma * epsi * (1. + zvir)) / (1. + gamma)
+ chx = cfh * alp * beta + (1. - cfh) * alp
+ cqx = cfh * alp * hlv * (beta - epsi)
+ cqx = cqx + (1. - cfh) * zvir * g
+ ptem1 = (slx (i, k + 1) - slx (i, k)) * rdzt (i, k)
+ ptem2 = (qtx (i, k + 1) - qtx (i, k)) * rdzt (i, k)
+ bf (i, k) = chx * ptem1 + cqx * ptem2
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ dku (i, k) = 0.
+ dkt (i, k) = 0.
+ dkq (i, k) = 0.
+ cku (i, k) = 0.
+ ckt (i, k) = 0.
+ tem = zi (i, k + 1) - zi (i, k)
+ radx (i, k) = tem * radh (i, k)
+ enddo
+ enddo
+
+ do i = 1, im
+ sflux (i) = heat (i) + evap (i) * zvir * theta (i, 1)
+ if (.not.sfcflg (i) .or. sflux (i) <= 0.) pblflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute critical bulk richardson number
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (pblflg (i)) then
+ ! thermal (i) = thvx (i, 1)
+ thermal (i) = thlvx (i, 1)
+ crb (i) = rbcr
+ else
+ thermal (i) = tsea (i) * (1. + zvir * max (q1g (i, 1, 1), qmin))
+ tem = sqrt (u10m (i) ** 2 + v10m (i) ** 2)
+ tem = max (tem, 1.)
+ robn = tem / (f0 * z0 (i))
+ tem1 = 1.e-7 * robn
+ crb (i) = 0.16 * (tem1 ** (- 0.18))
+ crb (i) = max (min (crb (i), crbmax), crbmin)
+ endif
+ enddo
+
+ do i = 1, im
+ dtdz1 (i) = dt2 / (zi (i, 2) - zi (i, 1))
+ enddo
+
+ do i = 1, im
+ ustar (i) = sqrt (stress (i))
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy (bf) and winshear square
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ rdz = rdzt (i, k)
+ ! bf (i, k) = gotvx (i, k) * (thvx (i, k + 1) - thvx (i, k)) * rdz
+ dw2 = (u1 (i, k) - u1 (i, k + 1)) ** 2 + &
+ (v1 (i, k) - v1 (i, k + 1)) ** 2
+ shr2 (i, k) = max (dw2, dw2min) * rdz * rdz
+ ri (i, k) = max (bf (i, k) / shr2 (i, k), rimin)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! find pbl height based on bulk richardson number (mrf pbl scheme)
+ ! and also for diagnostic purpose
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .false.
+ rbup (i) = rbsoil (i)
+ enddo
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (.not.flg (i)) then
+ rbdn (i) = rbup (i)
+ spdk2 = max ((u1 (i, k) ** 2 + v1 (i, k) ** 2), 1.)
+ ! rbup (i) = (thvx (i, k) - thermal (i)) * &
+ ! (g * zl (i, k) / thvx (i, 1)) / spdk2
+ rbup (i) = (thlvx (i, k) - thermal (i)) * &
+ (g * zl (i, k) / thlvx (i, 1)) / spdk2
+ kpblx (i) = k
+ flg (i) = rbup (i) > crb (i)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (kpblx (i) > 1) then
+ k = kpblx (i)
+ if (rbdn (i) >= crb (i)) then
+ rbint = 0.
+ elseif (rbup (i) <= crb (i)) then
+ rbint = 1.
+ else
+ rbint = (crb (i) - rbdn (i)) / (rbup (i) - rbdn (i))
+ endif
+ hpblx (i) = zl (i, k - 1) + rbint * (zl (i, k) - zl (i, k - 1))
+ if (hpblx (i) < zi (i, kpblx (i))) kpblx (i) = kpblx (i) - 1
+ else
+ hpblx (i) = zl (i, 1)
+ kpblx (i) = 1
+ endif
+ hpbl (i) = hpblx (i)
+ kpbl (i) = kpblx (i)
+ if (kpbl (i) <= 1) pblflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute mean tke within pbl
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ sumx (i) = 0.
+ tkemean (i) = 0.
+ enddo
+ do k = 1, kmpbl
+ do i = 1, im
+ if (k < kpbl (i)) then
+ dz = zi (i, k + 1) - zi (i, k)
+ tkemean (i) = tkemean (i) + tke (i, k) * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (tkemean (i) > 0. .and. sumx (i) > 0.) then
+ tkemean (i) = tkemean (i) / sumx (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute wind shear term as a sink term for updraft and downdraft
+ ! velocity
+ ! -----------------------------------------------------------------------
+
+ kps = max (kmpbl, kmscu)
+ do k = 2, kps
+ do i = 1, im
+ dz = zi (i, k + 1) - zi (i, k)
+ tem = (0.5 * (u1 (i, k - 1) - u1 (i, k + 1)) / dz) ** 2
+ tem1 = tem + (0.5 * (v1 (i, k - 1) - v1 (i, k + 1)) / dz) ** 2
+ wush (i, k) = csmf * sqrt (tem1)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute similarity parameters
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ zol (i) = max (rbsoil (i) * fm (i) * fm (i) / fh (i), rimin)
+ if (sfcflg (i)) then
+ zol (i) = min (zol (i), - zfmin)
+ else
+ zol (i) = max (zol (i), zfmin)
+ endif
+
+ zol1 = zol (i) * sfcfrac * hpbl (i) / zl (i, 1)
+ if (sfcflg (i)) then
+ tem = 1.0 / (1. - aphi16 * zol1)
+ phih (i) = sqrt (tem)
+ phim (i) = sqrt (phih (i))
+ tem1 = 1.0 / (1. - aphi16 * zol (i))
+ phims (i) = sqrt (sqrt (tem1))
+ else
+ phim (i) = 1. + aphi5 * zol1
+ phih (i) = phim (i)
+ phims (i) = 1. + aphi5 * zol (i)
+ endif
+ enddo
+
+ do i = 1, im
+ if (pblflg (i)) then
+ if (zol (i) < zolcru) then
+ pcnvflg (i) = .true.
+ endif
+ wst3 (i) = gotvx (i, 1) * sflux (i) * hpbl (i)
+ wstar (i) = wst3 (i) ** h1
+ ust3 (i) = ustar (i) ** 3.
+ wscale (i) = (ust3 (i) + wfac * vk * wst3 (i) * sfcfrac) ** h1
+ ptem = ustar (i) / aphi5
+ wscale (i) = max (wscale (i), ptem)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute a thermal excess
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (pcnvflg (i)) then
+ hgamt (i) = heat (i) / wscale (i)
+ hgamq (i) = evap (i) / wscale (i)
+ vpert (i) = hgamt (i) + hgamq (i) * zvir * theta (i, 1)
+ vpert (i) = max (vpert (i), 0.)
+ tem = min (cfac * vpert (i), gamcrt)
+ thermal (i) = thermal (i) + tem !jih jul2020
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! enhance the pbl height by considering the thermal excess
+ ! (overshoot pbl top) -- jih jul2020
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .true.
+ if (pcnvflg (i)) then
+ flg (i) = .false.
+ rbup (i) = rbsoil (i)
+ endif
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (.not.flg (i)) then
+ rbdn (i) = rbup (i)
+ spdk2 = max ((u1 (i, k) ** 2 + v1 (i, k) ** 2), 1.)
+ rbup (i) = (thlvx (i, k) - thermal (i)) * &
+ (g * zl (i, k) / thlvx (i, 1)) / spdk2
+ kpbl (i) = k
+ flg (i) = rbup (i) > crb (i)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (pcnvflg (i)) then
+ k = kpbl (i)
+ if (rbdn (i) >= crb (i)) then
+ rbint = 0.
+ elseif (rbup (i) <= crb (i)) then
+ rbint = 1.
+ else
+ rbint = (crb (i) - rbdn (i)) / (rbup (i) - rbdn (i))
+ endif
+ hpbl (i) = zl (i, k - 1) + rbint * (zl (i, k) - zl (i, k - 1))
+ if (hpbl (i) < zi (i, kpbl (i))) then
+ kpbl (i) = kpbl (i) - 1
+ endif
+ if (kpbl (i) <= 1) then
+ pcnvflg (i) = .false.
+ pblflg (i) = .false.
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! look for stratocumulus
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = scuflg (i)
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ if (flg (i) .and.zl (i, k) >= zstblmax) then
+ lcld (i) = k
+ flg (i) = .false.
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ flg (i) = scuflg (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k <= lcld (i)) then
+ if (qlx (i, k) >= qlcr) then
+ kcld (i) = k
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (scuflg (i) .and. kcld (i) == km1) scuflg (i) = .false.
+ enddo
+
+ do i = 1, im
+ flg (i) = scuflg (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k <= kcld (i)) then
+ if (qlx (i, k) >= qlcr) then
+ if (radx (i, k) < radmin (i)) then
+ radmin (i) = radx (i, k)
+ krad (i) = k
+ endif
+ else
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (scuflg (i) .and. krad (i) <= 1) scuflg (i) = .false.
+ if (scuflg (i) .and. radmin (i) >= 0.) scuflg (i) = .false.
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute components for mass flux mixing by large thermals
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (pcnvflg (i)) then
+ tcko (i, k) = t1 (i, k)
+ ucko (i, k) = u1 (i, k)
+ vcko (i, k) = v1 (i, k)
+ endif
+ if (scuflg (i)) then
+ tcdo (i, k) = t1 (i, k)
+ ucdo (i, k) = u1 (i, k)
+ vcdo (i, k) = v1 (i, k)
+ endif
+ enddo
+ enddo
+ do kk = 1, ntrac1
+ do k = 1, km
+ do i = 1, im
+ if (pcnvflg (i)) then
+ qcko (i, k, kk) = q1g (i, k, kk)
+ endif
+ if (scuflg (i)) then
+ qcdo (i, k, kk) = q1g (i, k, kk)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! kgao note - change ntcw if q1g is rearranged
+ ! -----------------------------------------------------------------------
+
+ if (ntke > ntcw) then
+ ntcw_new = ntcw
+ else
+ ntcw_new = ntcw - 1
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! edmf parameterization siebesma et al. (2007)
+ ! -----------------------------------------------------------------------
+
+ call mfpbltq (im, km, kmpbl, ntcw_new, ntrac1, dt2, &
+ pcnvflg, zl, zm, q1g, t1, u1, v1, plyr, pix, thlx, thvx, &
+ gdx, hpbl, kpbl, vpert, buou, &
+ use_shear_pbl, wush, &
+ use_tke_pbl, tkemean, vez0fun, xmf, &
+ tcko, qcko, ucko, vcko, xlamue, bl_upfr)
+
+ ! -----------------------------------------------------------------------
+ ! mass - flux parameterization for stratocumulus - top - induced turbulence mixing
+ ! -----------------------------------------------------------------------
+
+ call mfscuq (im, km, kmscu, ntcw_new, ntrac1, dt2, &
+ scuflg, zl, zm, q1g, t1, u1, v1, plyr, pix, &
+ thlx, thvx, thlvx, gdx, thetae, &
+ krad, mrad, radmin, buod, &
+ use_shear_pbl, wush, &
+ use_tke_pbl, tkemean, vez0fun, xmfd, &
+ tcdo, qcdo, ucdo, vcdo, xlamde, bl_dnfr)
+
+ ! -----------------------------------------------------------------------
+ ! compute prandtl number and exchange coefficient varying with height
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (k < kpbl (i)) then
+ tem = phih (i) / phim (i)
+ ptem = sfcfrac * hpbl (i)
+ tem1 = max (zi (i, k + 1) - ptem, 0.)
+ tem2 = tem1 / (hpbl (i) - ptem)
+ if (pcnvflg (i)) then
+ tem = min (tem, pr0)
+ prn (i, k) = tem + (pr0 - tem) * tem2
+ else
+ tem = max (tem, pr0)
+ prn (i, k) = tem
+ endif
+ prn (i, k) = min (prn (i, k), prmax)
+ prn (i, k) = max (prn (i, k), prmin)
+
+ ckz (i, k) = ck0 + (ck1 - ck0) * tem2
+ ckz (i, k) = max (min (ckz (i, k), ck0), ck1)
+ chz (i, k) = ch0 + (ch1 - ch0) * tem2
+ chz (i, k) = max (min (chz (i, k), ch0), ch1)
+
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! above a threshold height (hcrinv), the background vertical diffusivities and mixing length
+ ! in the inversion layers are set to much smaller values (xkzinv and rlmn2)
+ ! below the threshold height (hcrinv), the background vertical diffusivities and mixing length
+ ! in the inversion layers are increased with increasing roughness length and vegetation fraction
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (islimsk (i) == 1) then
+ z0fun = min (max ( (zorl (i) * 0.01 - 0.1) / 0.9, 0.0), 1.0) ! jih jul2020: (z0fun = 0. ~ 1.0)
+ zvfun (i) = sqrt (max (sigmaf (i), 0.1) * z0fun) !jih jul2020: over land, zvfun = 0 over ocean
+ else
+ zvfun (i) = 0.
+ endif
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ if (zi (i, k + 1) > hcrinv) then
+ tem1 = tvx (i, k + 1) - tvx (i, k)
+ if (tem1 >= 0. .and. islimsk (i) == 0) then ! kgao note: only apply limiter over ocean points
+ xkzo (i, k) = min (xkzo (i, k), xkzinv)
+ xkzmo (i, k) = min (xkzmo (i, k), xkzinv)
+ rlmnz (i, k) = min (rlmnz (i, k), rlmn2)
+ endif
+ else
+ tem1 = tvx (i, k + 1) - tvx (i, k)
+ if (tem1 > 0.) then
+ ptem = xkzo (i, k) * zvfun (i)
+ xkzo (i, k) = min (max (ptem, xkzinv), xkzo (i, k))
+ ptem = xkzmo (i, k) * zvfun (i)
+ xkzmo (i, k) = min (max (ptem, xkzinv), xkzmo (i, k))
+ ptem = rlmnz (i, k) * zvfun (i)
+ rlmnz (i, k) = min (max (ptem, rlmn2), rlmnz (i, k))
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute an asymtotic mixing length
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+
+ if (l2_diag_opt == 0) then
+ ! kgao 12 / 08 / 2023: original method as in han and bretherton 2019
+ ! but additionally considers shear effect
+ zlup = 0.0
+ bsum = 0.0
+ mlenflg = .true.
+ do n = k, km1
+ if (mlenflg) then
+ dz = zl (i, n + 1) - zl (i, n)
+ tem3 = ((u1 (i, n + 1) - u1 (i, n)) / dz) ** 2
+ tem3 = tem3 + ((v1 (i, n + 1) - v1 (i, n)) / dz) ** 2
+ tem3 = cs0 * sqrt (tem3) * sqrt (tke (i, k))
+ ptem = (gotvx (i, n) * (thvx (i, n + 1) - thvx (i, k)) + tem3) * dz
+ bsum = bsum + ptem
+ zlup = zlup + dz
+ if (bsum >= tke (i, k)) then
+ if (ptem >= 0.) then
+ tem2 = max (ptem, zfmin)
+ else
+ tem2 = min (ptem, - zfmin)
+ endif
+ ptem1 = (bsum - tke (i, k)) / tem2
+ zlup = zlup - ptem1 * dz
+ zlup = max (zlup, 0.)
+ mlenflg = .false.
+ endif
+ endif
+ enddo
+ zldn = 0.0
+ bsum = 0.0
+ mlenflg = .true.
+ do n = k, 1, - 1
+ if (mlenflg) then
+ if (n == 1) then
+ dz = zl (i, 1)
+ tem1 = tsea (i) * (1. + zvir * max (q1g (i, 1, 1), qmin))
+ !jih jul2020
+ tem3 = (u1 (i, 1) / dz) ** 2
+ tem3 = tem3 + (v1 (i, 1) / dz) ** 2
+ tem3 = cs0 * sqrt (tem3) * sqrt (tke (i, 1))
+ else
+ dz = zl (i, n) - zl (i, n - 1)
+ tem1 = thvx (i, n - 1)
+ ! tem1 = thlvx (i, n - 1)
+ tem3 = ((u1 (i, n) - u1 (i, n - 1)) / dz) ** 2
+ tem3 = tem3 + ((v1 (i, n) - v1 (i, n - 1)) / dz) ** 2
+ tem3 = cs0 * sqrt (tem3) * sqrt (tke (i, k))
+ endif
+ ptem = (gotvx (i, n) * (thvx (i, k) - tem1) + tem3) * dz
+ bsum = bsum + ptem
+ zldn = zldn + dz
+ if (bsum >= tke (i, k)) then
+ if (ptem >= 0.) then
+ tem2 = max (ptem, zfmin)
+ else
+ tem2 = min (ptem, - zfmin)
+ endif
+ ptem1 = (bsum - tke (i, k)) / tem2
+ zldn = zldn - ptem1 * dz
+ zldn = max (zldn, 0.)
+ mlenflg = .false.
+ endif
+ endif
+ enddo
+
+ else if (l2_diag_opt == 1) then
+ ! kgao 12 / 08 / 2023: a new method for diagnosing l2
+ zlup = 0.0
+ mlenflg = .true.
+ e2 (i, k) = max (2. * tke (i, k), 0.001)
+ do n = k, km1
+ if (mlenflg) then
+ dz = zl (i, n + 1) - zl (i, n)
+ tem1 = 2. * gotvx (i, n + 1) * (thvx (i, k) - thvx (i, n + 1))
+ tem2 = cs0 * sqrt (e2 (i, n)) * sqrt (shr2 (i, n))
+ e2 (i, n + 1) = e2 (i, n) + (tem1 - tem2) * dz
+ zlup = zlup + dz
+ if (e2 (i, n + 1) < 0.) then
+ ptem = e2 (i, n + 1) / (e2 (i, n + 1) - e2 (i, n))
+ zlup = zlup - ptem * dz
+ zlup = max (zlup, 0.)
+ mlenflg = .false.
+ endif
+ endif
+ enddo
+ zldn = 0.0
+ mlenflg = .true.
+ do n = k, 1, - 1
+ if (mlenflg) then
+ if (n == 1) then
+ dz = zl (i, 1)
+ tem = tsea (i) * (1. + zvir * max (q1g (i, 1, 1), qmin))
+ tem1 = 2. * gotvx (i, n) * (tem - thvx (i, k))
+ tem2 = ustar (i) * phims (i) / (vk * dz)
+ tem2 = cs0 * sqrt (e2 (i, n)) * tem2
+ e2 (i, n - 1) = e2 (i, n) + (tem1 - tem2) * dz
+ else
+ dz = zl (i, n) - zl (i, n - 1)
+ tem1 = 2. * gotvx (i, n - 1) * (thvx (i, n - 1) - thvx (i, k))
+ tem2 = cs0 * sqrt (e2 (i, n)) * sqrt (shr2 (i, n - 1))
+ e2 (i, n - 1) = e2 (i, n) + (tem1 - tem2) * dz
+ endif
+ zldn = zldn + dz
+ if (e2 (i, n - 1) < 0.) then
+ ptem = e2 (i, n - 1) / (e2 (i, n - 1) - e2 (i, n))
+ zldn = zldn - ptem * dz
+ zldn = max (zldn, 0.)
+ mlenflg = .false.
+ endif
+ endif
+ enddo
+ endif ! end - if of l2_diag_opt
+
+ tem = 0.5 * (zi (i, k + 1) - zi (i, k))
+ tem1 = min (tem, rlmnz (i, k))
+
+
+ ! -----------------------------------------------------------------------
+ ! kgao 08 / 29 / 23: add option to use l_up as l2
+ ! zldn is strongly limited by the layer height for the near - surface levels
+ ! it is not physical to use limiter below because zk already considers this factor
+ ! -----------------------------------------------------------------------
+
+ if (use_lup_only) then
+ ptem2 = zlup
+ else
+ ptem2 = min (zlup, zldn)
+ endif
+
+ rlam (i, k) = elmfac * ptem2
+ rlam (i, k) = max (rlam (i, k), tem1)
+ rlam (i, k) = min (rlam (i, k), rlmx)
+
+ ptem2 = sqrt (zlup * zldn)
+ ele (i, k) = elefac * ptem2
+ ele (i, k) = max (ele (i, k), tem1)
+ ele (i, k) = min (ele (i, k), elmx)
+
+ enddo
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ tem = vk * zl (i, k)
+ if (zol (i) < 0.) then
+ ptem = 1. - 100. * zol (i)
+ ptem1 = ptem ** 0.2
+ zk = tem * ptem1
+ elseif (zol (i) >= 1.) then
+ zk = tem / 3.7
+ else
+ ptem = 1. + 2.7 * zol (i)
+ zk = tem / ptem
+ endif
+
+ ! kgao 12 / 08 / 2023: introduce multiple l1 and l2 blending options
+ if (l1l2_blend_opt == 0) then
+ ! original as in hk19
+ elm (i, k) = zk * rlam (i, k) / (rlam (i, k) + zk)
+
+ else if (l1l2_blend_opt == 1) then
+ ! hafa method as in wang et al 2023 waf; use zk as elm within surface layer
+ tem = 1.
+ if (sfcflg (i) .and. hpbl (i) > 200.) then
+ tem1 = min (100., hpbl (i) * 0.05) ! sfc layer height
+ if (zl (i, k) < tem1) then ! for layers below sfc layer
+ tem = 0.
+ elseif (zl (i, k) >= tem1 .and. zl (i, k) < 2 * tem1) then ! transition layers
+ tem = (zl (i, k) - tem1) / tem1
+ endif
+ endif
+ elm (i, k) = 1. / (1. / zk + tem * 1. / rlam (i, k))
+
+ else if (l1l2_blend_opt == 2) then
+ ! hafb blending method
+ elm (i, k) = sqrt (1.0 / (1.0 / (zk ** 2) + 1.0 / (rlam (i, k) ** 2)))
+ endif
+
+ ! kgao 12 / 08 / 2023: use l1 as l at the lowest layer
+ if (use_l1_sfc) then
+ if (k == 1) elm (i, k) = zk
+ endif
+
+ dz = zi (i, k + 1) - zi (i, k)
+ tem = max (gdx (i), dz)
+ elm (i, k) = min (elm (i, k), tem)
+ ele (i, k) = min (ele (i, k), tem)
+
+ enddo
+ enddo
+ do i = 1, im
+ elm (i, km) = elm (i, km1)
+ ele (i, km) = ele (i, km1)
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute eddy diffusivities
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ xkzo (i, k) = 0.5 * (xkzo (i, k) + xkzo (i, k + 1))
+ xkzmo (i, k) = 0.5 * (xkzmo (i, k) + xkzmo (i, k + 1))
+ enddo
+ enddo
+ do k = 1, km1
+ do i = 1, im
+ tem = 0.5 * (elm (i, k) + elm (i, k + 1))
+ tem = tem * sqrt (tkeh (i, k))
+ if (k < kpbl (i)) then
+ if (pcnvflg (i)) then
+ dku (i, k) = ckz (i, k) * tem
+ dkt (i, k) = dku (i, k) / prn (i, k)
+ else
+ if (ri (i, k) < 0.) then ! unstable regime
+ dku (i, k) = ckz (i, k) * tem
+ dkt (i, k) = dku (i, k) / prn (i, k)
+ else ! stable regime
+ dkt (i, k) = chz (i, k) * tem
+ dku (i, k) = dkt (i, k) * prn (i, k)
+ endif
+ endif
+ else
+ if (ri (i, k) < 0.) then ! unstable regime
+ dku (i, k) = ck1 * tem
+ dkt (i, k) = rchck * dku (i, k)
+ else ! stable regime
+ dkt (i, k) = ch1 * tem
+ prnum = 1.0 + 2.1 * ri (i, k)
+ prnum = min (prnum, prmax)
+ dku (i, k) = dkt (i, k) * prnum
+ endif
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ tem1 = ckz (i, k) * tem
+ ptem1 = tem1 / prscu
+ dku (i, k) = max (dku (i, k), tem1)
+ dkt (i, k) = max (dkt (i, k), ptem1)
+ endif
+ endif
+
+ dkq (i, k) = prtke * dkt (i, k)
+
+ dkt (i, k) = min (dkt (i, k), dkmax)
+ dkt (i, k) = max (dkt (i, k), xkzo (i, k))
+ dkq (i, k) = min (dkq (i, k), dkmax)
+ dkq (i, k) = max (dkq (i, k), xkzo (i, k))
+ dku (i, k) = min (dku (i, k), dkmax)
+ dku (i, k) = max (dku (i, k), xkzmo (i, k))
+
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute a minimum tke deduced from background diffusivity for momentum.
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k == 1) then
+ tem = ckz (i, 1)
+ tem1 = 0.5 * xkzmo (i, 1)
+ else
+ tem = 0.5 * (ckz (i, k - 1) + ckz (i, k))
+ tem1 = 0.5 * (xkzmo (i, k - 1) + xkzmo (i, k))
+ endif
+ ptem = tem1 / (tem * elm (i, k))
+ tkmnz (i, k) = ptem * ptem
+ tkmnz (i, k) = min (tkmnz (i, k), tkminx)
+ tkmnz (i, k) = max (tkmnz (i, k), tkmin)
+ enddo
+ enddo
+
+ if (present (dkt_out)) then
+ do k = 1, km1
+ do i = 1, im
+ dkt_out (i, k) = dkt (i, k)
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy and shear productions of tke
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km1
+ do i = 1, im
+ if (k == 1) then
+ tem = - dkt (i, 1) * bf (i, 1)
+ ! if (pcnvflg (i)) then
+ ! ptem1 = xmf (i, 1) * buou (i, 1)
+ ! else
+ ptem1 = 0.
+ ! endif
+ if (scuflg (i) .and. mrad (i) == 1) then
+ ptem2 = xmfd (i, 1) * buod (i, 1)
+ else
+ ptem2 = 0.
+ endif
+ tem = tem + ptem1 + ptem2
+ buop = 0.5 * (gotvx (i, 1) * sflux (i) + tem)
+
+ tem1 = dku (i, 1) * shr2 (i, 1)
+
+ tem = (u1 (i, 2) - u1 (i, 1)) * rdzt (i, 1)
+ ! if (pcnvflg (i)) then
+ ! ptem = xmf (i, 1) * tem
+ ! ptem1 = 0.5 * ptem * (u1 (i, 2) - ucko (i, 2))
+ ! else
+ ptem1 = 0.
+ ! endif
+ if (scuflg (i) .and. mrad (i) == 1) then
+ ptem = ucdo (i, 1) + ucdo (i, 2) - u1 (i, 1) - u1 (i, 2)
+ ptem = 0.5 * tem * xmfd (i, 1) * ptem
+ else
+ ptem = 0.
+ endif
+ ptem1 = ptem1 + ptem
+
+ tem = (v1 (i, 2) - v1 (i, 1)) * rdzt (i, 1)
+ ! if (pcnvflg (i)) then
+ ! ptem = xmf (i, 1) * tem
+ ! ptem2 = 0.5 * ptem * (v1 (i, 2) - vcko (i, 2))
+ ! else
+ ptem2 = 0.
+ ! endif
+ if (scuflg (i) .and. mrad (i) == 1) then
+ ptem = vcdo (i, 1) + vcdo (i, 2) - v1 (i, 1) - v1 (i, 2)
+ ptem = 0.5 * tem * xmfd (i, 1) * ptem
+ else
+ ptem = 0.
+ endif
+ ptem2 = ptem2 + ptem
+
+ ! tem2 = stress (i) * spd1 (i) / zl (i, 1)
+ tem2 = stress (i) * ustar (i) * phim (i) / (vk * zl (i, 1))
+ shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2)
+ else
+ tem1 = - dkt (i, k - 1) * bf (i, k - 1)
+ tem2 = - dkt (i, k) * bf (i, k)
+ tem = 0.5 * (tem1 + tem2)
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ ptem = 0.5 * (xmf (i, k - 1) + xmf (i, k))
+ ptem1 = ptem * buou (i, k)
+ else
+ ptem1 = 0.
+ endif
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem0 = 0.5 * (xmfd (i, k - 1) + xmfd (i, k))
+ ptem2 = ptem0 * buod (i, k)
+ else
+ ptem2 = 0.
+ endif
+ else
+ ptem2 = 0.
+ endif
+ buop = tem + ptem1 + ptem2
+
+ tem1 = dku (i, k - 1) * shr2 (i, k - 1)
+ tem2 = dku (i, k) * shr2 (i, k)
+ tem = 0.5 * (tem1 + tem2)
+ tem1 = (u1 (i, k + 1) - u1 (i, k)) * rdzt (i, k)
+ tem2 = (u1 (i, k) - u1 (i, k - 1)) * rdzt (i, k - 1)
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ ptem = xmf (i, k) * tem1 + xmf (i, k - 1) * tem2
+ ptem1 = 0.5 * ptem * (u1 (i, k) - ucko (i, k))
+ else
+ ptem1 = 0.
+ endif
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem0 = xmfd (i, k) * tem1 + xmfd (i, k - 1) * tem2
+ ptem2 = 0.5 * ptem0 * (ucdo (i, k) - u1 (i, k))
+ else
+ ptem2 = 0.
+ endif
+ else
+ ptem2 = 0.
+ endif
+ shrp = tem + ptem1 + ptem2
+ tem1 = (v1 (i, k + 1) - v1 (i, k)) * rdzt (i, k)
+ tem2 = (v1 (i, k) - v1 (i, k - 1)) * rdzt (i, k - 1)
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ ptem = xmf (i, k) * tem1 + xmf (i, k - 1) * tem2
+ ptem1 = 0.5 * ptem * (v1 (i, k) - vcko (i, k))
+ else
+ ptem1 = 0.
+ endif
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem0 = xmfd (i, k) * tem1 + xmfd (i, k - 1) * tem2
+ ptem2 = 0.5 * ptem0 * (vcdo (i, k) - v1 (i, k))
+ else
+ ptem2 = 0.
+ endif
+ else
+ ptem2 = 0.
+ endif
+ shrp = shrp + ptem1 + ptem2
+ endif
+ prod (i, k) = buop + shrp
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! first predict tke due to tke production & dissipation (diss)
+ ! -----------------------------------------------------------------------
+
+ dtn = dt2 / float (ndt)
+ do n = 1, ndt
+ do k = 1, km1
+ do i = 1, im
+ tem = sqrt (tke (i, k))
+ ptem = ce0 / ele (i, k)
+ diss (i, k) = ptem * tke (i, k) * tem
+ tem1 = prod (i, k) + tke (i, k) / dtn
+ diss (i, k) = max (min (diss (i, k), tem1), 0.)
+ tke (i, k) = tke (i, k) + dtn * (prod (i, k) - diss (i, k)) ! no diffusion yet
+ ! tke (i, k) = max (tke (i, k), tkmin)
+ tke (i, k) = max (tke (i, k), tkmnz (i, k))
+ enddo
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft & downdraft properties for tke
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ if (pcnvflg (i)) then
+ ! kgao change
+ ! qcko (i, k, ntke) = tke (i, k)
+ qcko (i, k, ntrac) = tke (i, k)
+ endif
+ if (scuflg (i)) then
+ ! kgao change
+ ! qcdo (i, k, ntke) = tke (i, k)
+ qcdo (i, k, ntrac) = tke (i, k)
+ endif
+ enddo
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (pcnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+ ! kgao change
+ ! qcko (i, k, ntke) = ((1. - tem) * qcko (i, k - 1, ntke) + tem * &
+ ! (tke (i, k) + tke (i, k - 1))) / factor
+ qcko (i, k, ntrac) = ((1. - tem) * qcko (i, k - 1, ntrac) + tem * &
+ (tke (i, k) + tke (i, k - 1))) / factor
+ endif
+ enddo
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (scuflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+ ! kgao change
+ ! qcdo (i, k, ntke) = ((1. - tem) * qcdo (i, k + 1, ntke) + tem * &
+ ! (tke (i, k) + tke (i, k + 1))) / factor
+ qcdo (i, k, ntrac) = ((1. - tem) * qcdo (i, k + 1, ntrac) + tem * &
+ (tke (i, k) + tke (i, k + 1))) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute tridiagonal matrix elements for turbulent kinetic energy
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ad (i, 1) = 1.0
+ f1 (i, 1) = tke (i, 1)
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ rdz = rdzt (i, k)
+ tem1 = dsig * dkq (i, k) * rdz
+ dsdz2 = tem1 * rdz
+ au (i, k) = - dtodsd * dsdz2
+ al (i, k) = - dtodsu * dsdz2
+ ad (i, k) = ad (i, k) - au (i, k)
+ ad (i, k + 1) = 1. - al (i, k)
+ tem2 = dsig * rdz
+
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ ptem = 0.5 * tem2 * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = tke (i, k) + tke (i, k + 1)
+ ! kgao change
+ ! ptem = qcko (i, k, ntke) + qcko (i, k + 1, ntke)
+ ptem = qcko (i, k, ntrac) + qcko (i, k + 1, ntrac)
+ f1 (i, k) = f1 (i, k) - (ptem - tem) * ptem1
+ f1 (i, k + 1) = tke (i, k + 1) + (ptem - tem) * ptem2
+ else
+ f1 (i, k + 1) = tke (i, k + 1)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem = 0.5 * tem2 * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = tke (i, k) + tke (i, k + 1)
+ ! kgao change
+ ! ptem = qcdo (i, k, ntke) + qcdo (i, k + 1, ntke)
+ ptem = qcdo (i, k, ntrac) + qcdo (i, k + 1, ntrac)
+ f1 (i, k) = f1 (i, k) + (ptem - tem) * ptem1
+ f1 (i, k + 1) = f1 (i, k + 1) - (ptem - tem) * ptem2
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! solve tridiagonal problem for tke
+ ! -----------------------------------------------------------------------
+
+ call tridit (im, km, 1, al, ad, au, f1, au, f1)
+
+ ! -----------------------------------------------------------------------
+ ! recover tendency of tke
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ ! fix negative tke
+ f1 (i, k) = max (f1 (i, k), tkmin)
+ q1g (i, k, ntrac) = f1 (i, k)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute tridiagonal matrix elements for heat and moisture (and other tracers, except tke)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ad (i, 1) = 1.
+ f1 (i, 1) = t1 (i, 1) + dtdz1 (i) * heat (i)
+ f2 (i, 1) = q1g (i, 1, 1) + dtdz1 (i) * evap (i)
+ enddo
+ if (ntrac1 >= 2) then
+ do kk = 2, ntrac1
+ is = (kk - 1) * km
+ do i = 1, im
+ f2 (i, 1 + is) = q1g (i, 1, kk)
+ enddo
+ enddo
+ endif
+
+ do k = 1, km1
+ do i = 1, im
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ rdz = rdzt (i, k)
+ tem1 = dsig * dkt (i, k) * rdz
+ dsdzt = tem1 * gocp
+ dsdz2 = tem1 * rdz
+ au (i, k) = - dtodsd * dsdz2
+ al (i, k) = - dtodsu * dsdz2
+ ad (i, k) = ad (i, k) - au (i, k)
+ ad (i, k + 1) = 1. - al (i, k)
+ tem2 = dsig * rdz
+
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ ptem = 0.5 * tem2 * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = t1 (i, k) + t1 (i, k + 1)
+ ptem = tcko (i, k) + tcko (i, k + 1)
+ f1 (i, k) = f1 (i, k) + dtodsd * dsdzt - (ptem - tem) * ptem1
+ f1 (i, k + 1) = t1 (i, k + 1) - dtodsu * dsdzt + (ptem - tem) * ptem2
+ ! kgao - updraft mass flux
+ if (present (flux_up)) flux_up (i, k) = xmf (i, k) !0.5 * (ptem - tem) * xmf (i, k)
+ tem = q1g (i, k, 1) + q1g (i, k + 1, 1)
+ ptem = qcko (i, k, 1) + qcko (i, k + 1, 1)
+ f2 (i, k) = f2 (i, k) - (ptem - tem) * ptem1
+ f2 (i, k + 1) = q1g (i, k + 1, 1) + (ptem - tem) * ptem2
+ else
+ f1 (i, k) = f1 (i, k) + dtodsd * dsdzt
+ f1 (i, k + 1) = t1 (i, k + 1) - dtodsu * dsdzt
+ f2 (i, k + 1) = q1g (i, k + 1, 1)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem = 0.5 * tem2 * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ ptem = tcdo (i, k) + tcdo (i, k + 1)
+ tem = t1 (i, k) + t1 (i, k + 1)
+ f1 (i, k) = f1 (i, k) + (ptem - tem) * ptem1
+ f1 (i, k + 1) = f1 (i, k + 1) - (ptem - tem) * ptem2
+ ! kgao - downdraft mass flux
+ if (present (flux_dn)) flux_dn (i, k) = xmfd (i, k) ! - 0.5 * (ptem - tem) * xmfd (i, k)
+ tem = q1g (i, k, 1) + q1g (i, k + 1, 1)
+ ptem = qcdo (i, k, 1) + qcdo (i, k + 1, 1)
+ f2 (i, k) = f2 (i, k) + (ptem - tem) * ptem1
+ f2 (i, k + 1) = f2 (i, k + 1) - (ptem - tem) * ptem2
+ endif
+ endif
+ enddo
+ enddo
+
+ if (ntrac1 >= 2) then
+ do kk = 2, ntrac1
+ is = (kk - 1) * km
+ do k = 1, km1
+ do i = 1, im
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ tem = dsig * rdzt (i, k)
+ ptem = 0.5 * tem * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem1 = qcko (i, k, kk) + qcko (i, k + 1, kk)
+ tem2 = q1g (i, k, kk) + q1g (i, k + 1, kk)
+ ! kgao note - turn off non - local mixing
+ f2 (i, k + is) = f2 (i, k + is) ! - (tem1 - tem2) * ptem1
+ f2 (i, k + 1 + is) = q1g (i, k + 1, kk) ! + (tem1 - tem2) * ptem2
+ else
+ f2 (i, k + 1 + is) = q1g (i, k + 1, kk)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ tem = dsig * rdzt (i, k)
+ ptem = 0.5 * tem * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem1 = qcdo (i, k, kk) + qcdo (i, k + 1, kk)
+ tem2 = q1g (i, k, kk) + q1g (i, k + 1, kk)
+ ! kgao note - turn off non - local mixing
+ f2 (i, k + is) = f2 (i, k + is) ! + (tem1 - tem2) * ptem1
+ f2 (i, k + 1 + is) = f2 (i, k + 1 + is) ! - (tem1 - tem2) * ptem2
+ endif
+ endif
+
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! solve tridiagonal problem for heat and moisture
+ ! -----------------------------------------------------------------------
+
+ call tridin (im, km, ntrac1, al, ad, au, f1, f2, au, f1, f2)
+
+ ! -----------------------------------------------------------------------
+ ! recover tendencies of heat and moisture
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ tdt (i, k) = (f1 (i, k) - t1 (i, k)) * rdt
+ qdt (i, k) = (f2 (i, k) - q1g (i, k, 1)) * rdt
+ if (present (dtsfc)) dtsfc (i) = dtsfc (i) + cont * del (i, k) * tdt (i, k)
+ if (present (dqsfc)) dqsfc (i) = dqsfc (i) + conq * del (i, k) * qdt (i, k)
+ t1 (i, k) = f1 (i, k)
+ q1g (i, k, 1) = f2 (i, k)
+ enddo
+ enddo
+
+ if (ntrac1 >= 2) then
+ do kk = 2, ntrac1
+ is = (kk - 1) * km
+ do k = 1, km
+ do i = 1, im
+ q1g (i, k, kk) = f2 (i, k + is)
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! kgao note - rearrange tracer tendencies
+ ! -----------------------------------------------------------------------
+
+ !if (ntrac >= 3) then
+ if (ntke == ntrac) then ! tke is the last tracer
+ q1 (:, :, :) = q1g (:, :, :)
+ else ! tke is not
+ do kk = 1, ntke - 1
+ q1 (:, :, kk) = q1g (:, :, kk)
+ enddo
+ q1 (:, :, ntke) = q1g (:, :, ntrac)
+ do kk = ntke + 1, ntrac
+ q1 (:, :, kk) = q1g (:, :, kk - 1)
+ enddo
+ endif
+ !endif
+
+ ! -----------------------------------------------------------------------
+ ! add tke dissipative heating to temperature tendency
+ ! -----------------------------------------------------------------------
+
+ if (dspheat) then
+ do k = 1, km1
+ do i = 1, im
+ ! tem = min (diss (i, k), dspmax)
+ ! ttend = tem / cp_air
+ ttend = diss (i, k) / cp_air
+ t1 (i, k) = t1 (i, k) + dspfac * ttend * dt2
+ enddo
+ enddo
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! compute tridiagonal matrix elements for momentum
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ ad (i, 1) = 1.0 + dtdz1 (i) * stress (i) / spd1 (i)
+ f1 (i, 1) = u1 (i, 1)
+ f2 (i, 1) = v1 (i, 1)
+ enddo
+
+ do k = 1, km1
+ do i = 1, im
+ dtodsd = dt2 / del (i, k)
+ dtodsu = dt2 / del (i, k + 1)
+ dsig = prsl (i, k) - prsl (i, k + 1)
+ rdz = rdzt (i, k)
+ tem1 = dsig * dku (i, k) * rdz
+ dsdz2 = tem1 * rdz
+ au (i, k) = - dtodsd * dsdz2
+ al (i, k) = - dtodsu * dsdz2
+ ad (i, k) = ad (i, k) - au (i, k)
+ ad (i, k + 1) = 1. - al (i, k)
+ tem2 = dsig * rdz
+
+ if (pcnvflg (i) .and. k < kpbl (i)) then
+ ptem = 0.5 * tem2 * xmf (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = u1 (i, k) + u1 (i, k + 1)
+ ptem = ucko (i, k) + ucko (i, k + 1)
+ f1 (i, k) = f1 (i, k) - (ptem - tem) * ptem1
+ f1 (i, k + 1) = u1 (i, k + 1) + (ptem - tem) * ptem2
+ tem = v1 (i, k) + v1 (i, k + 1)
+ ptem = vcko (i, k) + vcko (i, k + 1)
+ f2 (i, k) = f2 (i, k) - (ptem - tem) * ptem1
+ f2 (i, k + 1) = v1 (i, k + 1) + (ptem - tem) * ptem2
+ else
+ f1 (i, k + 1) = u1 (i, k + 1)
+ f2 (i, k + 1) = v1 (i, k + 1)
+ endif
+
+ if (scuflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ ptem = 0.5 * tem2 * xmfd (i, k)
+ ptem1 = dtodsd * ptem
+ ptem2 = dtodsu * ptem
+ tem = u1 (i, k) + u1 (i, k + 1)
+ ptem = ucdo (i, k) + ucdo (i, k + 1)
+ f1 (i, k) = f1 (i, k) + (ptem - tem) * ptem1
+ f1 (i, k + 1) = f1 (i, k + 1) - (ptem - tem) * ptem2
+ tem = v1 (i, k) + v1 (i, k + 1)
+ ptem = vcdo (i, k) + vcdo (i, k + 1)
+ f2 (i, k) = f2 (i, k) + (ptem - tem) * ptem1
+ f2 (i, k + 1) = f2 (i, k + 1) - (ptem - tem) * ptem2
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! solve tridiagonal problem for momentum
+ ! -----------------------------------------------------------------------
+
+ call tridi2 (im, km, al, ad, au, f1, f2, au, f1, f2)
+
+ ! -----------------------------------------------------------------------
+ ! recover tendencies of momentum
+ ! -----------------------------------------------------------------------
+
+ do k = 1, km
+ do i = 1, im
+ udt (i, k) = (f1 (i, k) - u1 (i, k)) * rdt
+ vdt (i, k) = (f2 (i, k) - v1 (i, k)) * rdt
+ if (present (dusfc)) dusfc (i) = dusfc (i) + conw * del (i, k) * udt (i, k)
+ if (present (dvsfc)) dvsfc (i) = dvsfc (i) + conw * del (i, k) * vdt (i, k)
+ u1 (i, k) = f1 (i, k)
+ v1 (i, k) = f2 (i, k)
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! pbl height for diagnostic purpose
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ hpbl (i) = hpblx (i)
+ kpbl (i) = kpblx (i)
+ enddo
+
+ return
+
+end subroutine sa_tke_edmf_new_pbl
+
+! =======================================================================
+! subroutine to calcualte surface variables for PBL
+! =======================================================================
+
+subroutine sa_tke_edmf_new_sfc (im, lsoil, ps, u1, v1, t1, q1, &
+ delt, tsurf, prsl1, prslki, evap, hflx, fm, fh, &
+ z1, snwdph, zorl, ztrl, islimsk, ustar, sigmaf, &
+ vegtype, shdmax, sfcemis, dlwflx, sfcnsw, &
+ sfcdsw, srflag, hice, fice, tice, weasd, &
+ tprcp, stc, qsurf, cmm, chh, gflux, ep, &
+ u10m_out, v10m_out, t2m_out, q2m_out, &
+ cm_out, ch_out, rb_out, stress_out, wind_out)
+
+ implicit none
+
+ ! -----------------------------------------------------------------------
+ ! input / output arguments
+ ! -----------------------------------------------------------------------
+
+ integer, intent (in) :: im, lsoil
+
+ integer, intent (in) :: islimsk (im), vegtype (im)
+
+ real, intent (in) :: delt
+
+ real, intent (in) :: ps (im), u1 (im), v1 (im), t1 (im), q1 (im), &
+ prslki (im), z1 (im), prsl1 (im), sigmaf (im), shdmax (im), &
+ sfcemis (im), dlwflx (im), sfcnsw (im), sfcdsw (im), srflag (im)
+
+ real, intent (inout) :: fm (im), fh (im), zorl (im), ztrl (im), ustar (im), snwdph (im), &
+ hice (im), fice (im), tice (im), weasd (im), tprcp (im), stc (im, lsoil), &
+ evap (im), hflx (im), tsurf (im), qsurf (im), cmm (im), chh (im), &
+ gflux (im), ep (im)
+
+ real, intent (out), optional :: u10m_out (im), v10m_out (im), &
+ t2m_out (im), q2m_out (im), cm_out (im), ch_out (im), rb_out (im), &
+ stress_out (im), wind_out (im)
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ logical :: mom4ice = .false.
+
+ integer :: lsm = 1
+
+ real :: fm10 (im), fh2 (im), u10m (im), v10m (im), t2m (im), q2m (im), &
+ cm (im), ch (im), rb (im), stress (im), wind (im), snowmt (im)
+
+ ! -----------------------------------------------------------------------
+ ! calculate surface exchange coefficients and near-surface wind
+ ! -----------------------------------------------------------------------
+
+ if ( sfc_gfdl ) then
+
+ call sfc_exch_gfdl (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, ztrl, cm, ch, rb, &
+ prsl1, prslki, islimsk, stress, fm, fh, &
+ ustar, wind, fm10, fh2, sigmaf, vegtype, shdmax)
+
+ else
+
+ call sfc_exch (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, cm, ch, rb, &
+ prsl1, prslki, islimsk, stress, fm, fh, &
+ ustar, wind, fm10, fh2, sigmaf, vegtype, shdmax)
+
+ endif
+
+ ! -----------------------------------------------------------------------
+ ! surface energy balance over ocean
+ ! -----------------------------------------------------------------------
+
+ call sfc_ocea (im, ps, u1, v1, t1, q1, tsurf, cm, ch, &
+ prsl1, prslki, islimsk, qsurf, cmm, chh, gflux, evap, hflx, ep)
+
+ ! -----------------------------------------------------------------------
+ ! surface energy balance over land
+ ! -----------------------------------------------------------------------
+
+ ! TBD
+
+ ! -----------------------------------------------------------------------
+ ! surface energy balance over seaice
+ ! -----------------------------------------------------------------------
+
+ call sfc_seai (im, lsoil, ps, u1, v1, t1, q1, delt, &
+ sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, &
+ cm, ch, prsl1, prslki, islimsk, mom4ice, lsm, &
+ hice, fice, tice, weasd, tsurf, tprcp, stc, ep, &
+ snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx)
+
+ ! -----------------------------------------------------------------------
+ ! update near surface fields
+ ! -----------------------------------------------------------------------
+
+ call sfc_updt (im, ps, u1, v1, t1, q1, &
+ tsurf, qsurf, u10m, v10m, t2m, q2m, &
+ prslki, evap, fm, fh, fm10, fh2)
+
+ ! -----------------------------------------------------------------------
+ ! optional output
+ ! -----------------------------------------------------------------------
+
+ if (present (u10m_out)) u10m_out = u10m
+ if (present (v10m_out)) v10m_out = v10m
+ if (present (t2m_out)) t2m_out = t2m
+ if (present (q2m_out)) q2m_out = q2m
+ if (present (cm_out)) cm_out = cm
+ if (present (ch_out)) ch_out = ch
+ if (present (rb_out)) rb_out = rb
+ if (present (stress_out)) stress_out = stress
+ if (present (wind_out)) wind_out = wind
+
+end subroutine sa_tke_edmf_new_sfc
+
+! =======================================================================
+! subroutine to calculate surface exchange coefficients and near-surface wind
+! =======================================================================
+
+subroutine sfc_exch (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, cm, ch, rb, &
+ prsl1, prslki, islimsk, stress, fm, fh, &
+ ustar, wind, fm10, fh2, sigmaf, vegtype, shdmax)
+
+ implicit none
+
+ integer im
+ real, dimension (im) :: ps, u1, v1, t1, q1, z1, &
+ tsurf, zorl, cm, ch, rb, &
+ prsl1, prslki, stress, &
+ fm, fh, ustar, wind, ddvel, &
+ fm10, fh2, sigmaf, shdmax, &
+ snwdph
+ integer, dimension (im) :: vegtype, islimsk
+
+ logical flag_iter (im) ! added by s.lu
+
+ ! locals
+
+ integer i
+
+ real :: aa, aa0, bb, bb0, dtv, adtv, qs1, &
+ hl1, hl12, pm, ph, pm10, ph2, rat, &
+ thv1, tvs, z1i, z0, z0max, ztmax, &
+ fms, fhs, hl0, hl0inf, hlinf, &
+ hl110, hlt, hltinf, olinf, &
+ restar, tem1, tem2, ztmax1, &
+ z0_adj, wind_th_moon, ustar_th, a, b, c, & !kgao
+ u10m, v10m, ws10m !kgao
+
+ real, parameter :: &
+ charnock = .014, ca = .4, & ! ca - von karman constant
+ alpha = 5., a0 = - 3.975, a1 = 12.32, alpha4 = 4.0 * alpha, &
+ b1 = - 7.755, b2 = 6.041, alpha2 = alpha + alpha, beta = 1.0, &
+ a0p = - 7.941, a1p = 24.75, b1p = - 8.705, b2p = 7.899, &
+ vis = 1.4e-5, rnu = 1.51e-5, visi = 1.0 / vis, &
+ log01 = log (0.01), log05 = log (0.05), log07 = log (0.07), &
+ ztmin1 = - 999.0, &
+ ! following is added by kgao
+ bs0 = - 8.367276172397277e-12, &
+ bs1 = 1.7398510865876079e-09, &
+ bs2 = - 1.331896578363359e-07, &
+ bs3 = 4.507055294438727e-06, &
+ bs4 = - 6.508676881906914e-05, &
+ bs5 = 0.00044745137674732834, &
+ bs6 = - 0.0010745704660847233, &
+ cf0 = 2.1151080765239772e-13, &
+ cf1 = - 3.2260663894433345e-11, &
+ cf2 = - 3.329705958751961e-10, &
+ cf3 = 1.7648562021709124e-07, &
+ cf4 = 7.107636825694182e-06, &
+ cf5 = - 0.0013914681964973246, &
+ cf6 = 0.0406766967657759, &
+ p13 = - 1.296521881682694e-02, &
+ p12 = 2.855780863283819e-01, &
+ p11 = - 1.597898515251717e+00, &
+ p10 = - 8.396975715683501e+00, &
+ p25 = 3.790846746036765e-10, &
+ p24 = 3.281964357650687e-09, &
+ p23 = 1.962282433562894e-07, &
+ p22 = - 1.240239171056262e-06, &
+ p21 = 1.739759082358234e-07, &
+ p20 = 2.147264020369413e-05, &
+ p35 = 1.840430200185075e-07, &
+ p34 = - 2.793849676757154e-05, &
+ p33 = 1.735308193700643e-03, &
+ p32 = - 6.139315534216305e-02, &
+ p31 = 1.255457892775006e+00, &
+ p30 = - 1.663993561652530e+01, &
+ p40 = 4.579369142033410e-04
+
+ ! parameter (charnock = .014, ca = .4) !c ca is the von karman constant
+ ! parameter (alpha = 5., a0 = - 3.975, a1 = 12.32, b1 = - 7.755, b2 = 6.041)
+ ! parameter (a0p = - 7.941, a1p = 24.75, b1p = - 8.705, b2p = 7.899, vis = 1.4e-5)
+
+ ! real aa1, bb1, bb2, cc, cc1, cc2, arnu
+ ! parameter (aa1 = - 1.076, bb1 = .7045, cc1 = - .05808)
+ ! parameter (bb2 = - .1954, cc2 = .009999)
+ ! parameter (arnu = .135 * rnu)
+
+ ! z0s_max = .196e-2 for u10_crit = 25 m / s
+ ! z0s_max = .317e-2 for u10_crit = 30 m / s
+ ! z0s_max = .479e-2 for u10_crit = 35 m / s
+
+ ! mbek -- toga - coare flux algorithm
+ ! parameter (rnu = 1.51e-5, arnu = 0.11 * rnu)
+
+ ! initialize variables. all units are supposedly m.k.s. unless specified
+ ! ps is in pascals, wind is wind speed,
+ ! surface roughness length is converted to m from cm
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+ if (flag_iter (i)) then
+ wind (i) = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+ tem1 = 1.0 + zvir * max (q1 (i), 1.e-8)
+ thv1 = t1 (i) * prslki (i) * tem1
+ tvs = 0.5 * (tsurf (i) + tsurf (i)) * tem1
+ qs1 = mqs (t1 (i))
+ qs1 = max (1.0e-8, eps * qs1 / (prsl1 (i) + epsm1 * qs1))
+
+ z0 = 0.01 * zorl (i)
+ z0max = max (1.0e-6, min (z0, z1 (i)))
+ z1i = 1.0 / z1 (i)
+
+ ! compute stability dependent exchange coefficients
+ ! this portion of the code is presently suppressed
+
+
+ if (islimsk (i) == 0) then ! over ocean
+ ustar (i) = sqrt (grav * z0 / charnock)
+
+ ! ** test xubin's new z0
+
+ ! ztmax = z0max
+
+ restar = max (ustar (i) * z0max * visi, 0.000001)
+
+ ! restar = log (restar)
+ ! restar = min (restar, 5.)
+ ! restar = max (restar, - 5.)
+ ! rat = aa1 + (bb1 + cc1 * restar) * restar
+ ! rat = rat / (1. + (bb2 + cc2 * restar) * restar))
+ ! rat taken from zeng, zhao and dickinson 1997
+
+ rat = min (7.0, 2.67 * sqrt (sqrt (restar)) - 2.57)
+ ztmax = z0max * exp (- rat)
+
+ else ! over land and sea ice
+ ! ** xubin's new z0 over land and sea ice
+ tem1 = 1.0 - shdmax (i)
+ tem2 = tem1 * tem1
+ tem1 = 1.0 - tem2
+
+ if (ivegsrc == 1) then
+
+ if (vegtype (i) == 10) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 6) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 7) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 16) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ elseif (ivegsrc == 2) then
+
+ if (vegtype (i) == 7) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 8) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 9) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 11) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ endif
+ z0max = max (z0max, 1.0e-6)
+
+ ! czilc = 10.0 ** (- (0.40 / 0.07) * z0) ! fei's canopy height dependance of czil
+ ! czilc = 0.8
+
+ tem1 = 1.0 - sigmaf (i)
+ ztmax = z0max * exp (- tem1 * tem1 &
+ * czilc * ca * sqrt (ustar (i) * (0.01 / 1.5e-05)))
+
+ endif ! end of if (islimsk (i) == 0) then
+
+ ztmax = max (ztmax, 1.0e-6)
+ tem1 = z0max / z1 (i)
+ if (abs (1.0 - tem1) > 1.0e-6) then
+ ztmax1 = - beta * log (tem1) / (alpha2 * (1. - tem1))
+ else
+ ztmax1 = 99.0
+ endif
+ if (z0max < 0.05 .and. snwdph (i) < 10.0) ztmax1 = 99.0
+
+
+ ! compute stability indices (rb and hlinf)
+
+ dtv = thv1 - tvs
+ adtv = max (abs (dtv), 0.001)
+ dtv = sign (1., dtv) * adtv
+ rb (i) = max (- 5000.0, (grav + grav) * dtv * z1 (i) &
+ / ((thv1 + tvs) * wind (i) * wind (i)))
+ tem1 = 1.0 / z0max
+ tem2 = 1.0 / ztmax
+ fm (i) = log ((z0max + z1 (i)) * tem1)
+ fh (i) = log ((ztmax + z1 (i)) * tem2)
+ fm10 (i) = log ((z0max + 10.) * tem1)
+ fh2 (i) = log ((ztmax + 2.) * tem2)
+ hlinf = rb (i) * fm (i) * fm (i) / fh (i)
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+
+ ! stable case
+
+ if (dtv >= 0.0) then
+ hl1 = hlinf
+ if (hlinf > .25) then
+ tem1 = hlinf * z1i
+ hl0inf = z0max * tem1
+ hltinf = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hlinf)
+ aa0 = sqrt (1. + alpha4 * hl0inf)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hltinf)
+ pm = aa0 - aa + log ((aa + 1.) / (aa0 + 1.))
+ ph = bb0 - bb + log ((bb + 1.) / (bb0 + 1.))
+ fms = fm (i) - pm
+ fhs = fh (i) - ph
+ hl1 = fms * fms * rb (i) / fhs
+ hl1 = min (max (hl1, ztmin1), ztmax1)
+ endif
+
+ ! second iteration
+
+ tem1 = hl1 * z1i
+ hl0 = z0max * tem1
+ hlt = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hl1)
+ aa0 = sqrt (1. + alpha4 * hl0)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hlt)
+ pm = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ ph = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ aa = sqrt (1. + alpha4 * hl110)
+ pm10 = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ! aa = sqrt (1. + alpha4 * hl12)
+ bb = sqrt (1. + alpha4 * hl12)
+ ph2 = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+
+ ! unstable case - check for unphysical obukhov length
+
+ else ! dtv < 0 case
+ olinf = z1 (i) / hlinf
+ tem1 = 50.0 * z0max
+ if (abs (olinf) <= tem1) then
+ hlinf = - z1 (i) / tem1
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+ endif
+
+ ! get pm and ph
+
+ if (hlinf >= - 0.5) then
+ hl1 = hlinf
+ pm = (a0 + a1 * hl1) * hl1 / (1. + (b1 + b2 * hl1) * hl1)
+ ph = (a0p + a1p * hl1) * hl1 / (1. + (b1p + b2p * hl1) * hl1)
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = (a0 + a1 * hl110) * hl110 / (1. + (b1 + b2 * hl110) * hl110)
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = (a0p + a1p * hl12) * hl12 / (1. + (b1p + b2p * hl12) * hl12)
+ else ! hlinf < 0.05
+ hl1 = - hlinf
+ tem1 = 1.0 / sqrt (hl1)
+ pm = log (hl1) + 2. * sqrt (tem1) - .8776
+ ph = log (hl1) + .5 * tem1 + 1.386
+ ! pm = log (hl1) + 2.0 * hl1 ** (- .25) - .8776
+ ! ph = log (hl1) + 0.5 * hl1 ** (- .5) + 1.386
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = log (hl110) + 2.0 / sqrt (sqrt (hl110)) - .8776
+ ! pm10 = log (hl110) + 2. * hl110 ** (- .25) - .8776
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = log (hl12) + 0.5 / sqrt (hl12) + 1.386
+ ! ph2 = log (hl12) + .5 * hl12 ** (- .5) + 1.386
+ endif
+
+ endif ! end of if (dtv >= 0) then loop
+
+ ! finish the exchange coefficient computation to provide fm and fh
+
+ fm (i) = fm (i) - pm
+ fh (i) = fh (i) - ph
+ fm10 (i) = fm10 (i) - pm10
+ fh2 (i) = fh2 (i) - ph2
+ cm (i) = ca * ca / (fm (i) * fm (i))
+ ch (i) = ca * ca / (fm (i) * fh (i))
+ tem1 = 0.00001 / z1 (i)
+ cm (i) = max (cm (i), tem1)
+ ch (i) = max (ch (i), tem1)
+ stress (i) = cm (i) * wind (i) * wind (i)
+ ustar (i) = sqrt (stress (i))
+
+ ! update z0 over ocean
+
+ if (islimsk (i) == 0) then
+
+ z0 = (charnock / grav) * ustar (i) * ustar (i)
+
+ ! mbek -- toga - coare flux algorithm
+ ! z0 = (charnock / grav) * ustar (i) * ustar (i) + arnu / ustar (i)
+ ! new implementation of z0
+ ! cc = ustar (i) * z0 / rnu
+ ! pp = cc / (1. + cc)
+ ! ff = grav * arnu / (charnock * ustar (i) ** 3)
+ ! z0 = arnu / (ustar (i) * ff ** pp)
+
+ ! -------------------------- modify z0 by kgao
+
+ ! diagnose 10m wind (same as sfc_diag.f)
+
+ u10m = u1 (i) * fm10 (i) / fm (i)
+ v10m = v1 (i) * fm10 (i) / fm (i)
+ ws10m = sqrt (u10m * u10m + v10m * v10m)
+
+ ! option - uri / gfdl (hwrf 2015)
+ ! note there is discontinuity at 10m / s in original formulation
+ ! needs to be fixed
+
+ if (do_z0_hwrf15) then
+ if (ws10m <= 5.0) then
+ z0 = 0.0185 / 9.8 * (7.59e-4 * ws10m ** 2 + 2.46e-2 * ws10m) ** 2
+ elseif (ws10m > 5.0 .and. ws10m <= 10.) then
+ z0 = 0.00000235 * (ws10m ** 2 - 25.) + 3.805129199617346e-05
+ elseif (ws10m > 10.0 .and. ws10m <= 60.) then
+ z0 = bs6 + bs5 * ws10m + bs4 * ws10m ** 2 + bs3 * ws10m ** 3 &
+ + bs2 * ws10m ** 4 + bs1 * ws10m ** 5 + bs0 * ws10m ** 6
+ else
+ z0 = cf6 + cf5 * ws10m + cf4 * ws10m ** 2 + cf3 * ws10m ** 3 &
+ + cf2 * ws10m ** 4 + cf1 * ws10m ** 5 + cf0 * ws10m ** 6
+ endif
+ endif
+
+ ! option - hwrf 2017
+
+ if (do_z0_hwrf17) then
+ if (ws10m <= 6.5) then
+ z0 = exp (p10 + p11 * ws10m + p12 * ws10m ** 2 + p13 * ws10m ** 3)
+ elseif (ws10m > 6.5 .and. ws10m <= 15.7) then
+ z0 = p25 * ws10m ** 5 + p24 * ws10m ** 4 + p23 * ws10m ** 3 &
+ + p22 * ws10m ** 2 + p21 * ws10m + p20
+ elseif (ws10m > 15.7 .and. ws10m <= 53.) then
+ z0 = exp (p35 * ws10m ** 5 + p34 * ws10m ** 4 + p33 * ws10m ** 3 &
+ + p32 * ws10m ** 2 + p31 * ws10m + p30)
+ else
+ z0 = p40
+ endif
+ endif
+
+ ! option - gfs (low wind) + hwrf 2017 (high wind)
+
+ if (do_z0_hwrf17_hwonly) then
+
+ if (ws10m > wind_th_hwrf .and. ws10m <= 53.) then
+ z0 = exp (p35 * ws10m ** 5 + p34 * ws10m ** 4 + p33 * ws10m ** 3 &
+ + p32 * ws10m ** 2 + p31 * ws10m + p30)
+ elseif (ws10m > 53.) then
+ z0 = p40
+ endif
+
+ endif
+
+ ! option - gfs (low wind) + moon et al (high wind)
+
+ if (do_z0_moon) then
+ wind_th_moon = 20.
+ a = 0.56
+ b = - 20.255
+ c = wind_th_moon - 2.458
+ ustar_th = (- b - sqrt (b * b - 4 * a * c)) / (2 * a)
+
+ z0_adj = 0.001 * (0.085 * wind_th_moon - 0.58) - &
+ (charnock / grav) * ustar_th * ustar_th
+
+ ws10m = 2.458 + ustar (i) * (20.255 - 0.56 * ustar (i)) ! eq (7) moon et al. 2007
+ if (ws10m > wind_th_moon) then ! no modification in low wind conditions
+ z0 = 0.001 * (0.085 * ws10m - 0.58) - z0_adj ! eq (8b) moon et al. 2007 modified by kgao
+ endif
+ endif
+
+ ! ---------------------------- modify z0 end
+
+ if (redrag) then
+ zorl (i) = 100.0 * max (min (z0, z0s_max), 1.e-7)
+ else
+ zorl (i) = 100.0 * max (min (z0, .1), 1.e-7)
+ endif
+ endif
+ endif ! end of if (flagiter) loop
+ enddo
+
+end subroutine sfc_exch
+
+! =======================================================================
+! subroutine to calculate surface exchange coefficients and near-surface wind
+! Oct 2019 - a clean and updated version by Kun Gao at GFDL (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine sfc_exch_gfdl (im, ps, u1, v1, t1, q1, z1, &
+ snwdph, tsurf, zorl, ztrl, cm, ch, rb, &
+ prsl1, prslki, islimsk, &
+ stress, fm, fh, &
+ ustar, wind, fm10, fh2, &
+ sigmaf, vegtype, shdmax)
+
+ implicit none
+
+ ! --- input / output
+
+ integer im
+
+ real, dimension (im) :: ps, u1, v1, t1, q1, z1, &
+ zorl, ztrl, cm, ch, rb, &
+ prsl1, prslki, stress, &
+ fm, fh, ustar, wind, ddvel, &
+ fm10, fh2, sigmaf, shdmax, &
+ tsurf, snwdph
+
+ integer, dimension (im) :: vegtype, islimsk
+
+ logical flag_iter (im)
+
+ ! --- local
+
+ integer i
+
+ real :: aa, aa0, bb, bb0, dtv, adtv, qs1, &
+ hl1, hl12, pm, ph, pm10, ph2, rat, &
+ thv1, tvs, z1i, z0, zt, z0max, ztmax, &
+ fms, fhs, hl0, hl0inf, hlinf, &
+ hl110, hlt, hltinf, olinf, &
+ restar, czilc, tem1, tem2, &
+ u10m, v10m, ws10m, ws10m_moon, &
+ z0_1, zt_1, fm1, fh1, ustar_1, ztmax_1
+
+ real, parameter :: &
+ charnock = .014, ca = .4, &
+ vis = 1.4e-5, rnu = 1.51e-5, visi = 1.0 / vis, &
+ log01 = log (0.01), log05 = log (0.05), log07 = log (0.07), &
+ ztmin1 = - 999.0
+
+ ! ================================================
+ ! main program starts here
+ ! ================================================
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+
+ if (flag_iter (i)) then
+
+ ! --- get variables at model lowest layer and surface (water / ice / land)
+
+ wind (i) = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+ tem1 = 1.0 + zvir * max (q1 (i), 1.e-8)
+ thv1 = t1 (i) * prslki (i) * tem1
+ tvs = 0.5 * (tsurf (i) + tsurf (i)) * tem1
+ qs1 = mqs (t1 (i))
+ qs1 = max (1.0e-8, eps * qs1 / (prsl1 (i) + epsm1 * qs1))
+
+ ! (sea / land / ice mask = 0 / 1 / 2)
+ if (islimsk (i) == 1 .or. islimsk (i) == 2) then ! over land or sea ice
+
+ ! ================================================
+ ! if over land or sea ice:
+ ! step 1 - get z0 / zt
+ ! step 2 - call similarity
+ ! ================================================
+
+ ! --- get surface roughness for momentum (z0)
+
+ z0 = 0.01 * zorl (i)
+ z0max = max (1.0e-6, min (z0, z1 (i)))
+
+ !xubin's new z0 over land and sea ice
+ tem1 = 1.0 - shdmax (i) ! shdmax is max vegetation area fraction
+ tem2 = tem1 * tem1
+ tem1 = 1.0 - tem2
+
+ if (ivegsrc == 1) then
+
+ if (vegtype (i) == 10) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 6) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 7) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 16) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ elseif (ivegsrc == 2) then
+
+ if (vegtype (i) == 7) then
+ z0max = exp (tem2 * log01 + tem1 * log07)
+ elseif (vegtype (i) == 8) then
+ z0max = exp (tem2 * log01 + tem1 * log05)
+ elseif (vegtype (i) == 9) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ elseif (vegtype (i) == 11) then
+ ! z0max = exp (tem2 * log01 + tem1 * log01)
+ z0max = 0.01
+ else
+ z0max = exp (tem2 * log01 + tem1 * log (z0max))
+ endif
+
+ z0max = max (z0max, 1.0e-6)
+
+ endif
+
+ ! --- get surface roughness for heat (zt)
+
+ ! czilc = 10.0 ** (- (0.40 / 0.07) * z0) ! let czilc depend on canopy height
+ czilc = 0.8
+
+ tem1 = 1.0 - sigmaf (i)
+ ztmax = z0max * exp (- tem1 * tem1 * &
+ czilc * ca * sqrt (ustar (i) * (0.01 / 1.5e-05)))
+
+ ztmax = max (ztmax, 1.0e-6)
+
+ ! --- call similarity
+
+ call monin_obukhov_similarity &
+ (z1 (i), snwdph (i), thv1, wind (i), z0max, ztmax, tvs, &
+ rb (i), fm (i), fh (i), fm10 (i), fh2 (i), &
+ cm (i), ch (i), stress (i), ustar (i))
+
+ elseif (islimsk (i) == 0) then ! over water
+
+ ! ================================================
+ ! if over water (redesigned by kun gao)
+ ! iteration 1
+ ! step 1 get z0 / zt from previous step
+ ! step 2 call similarity
+ ! iteration 2
+ ! step 1 update z0 / zt
+ ! step 2 call similarity
+ ! ================================================
+
+ ! === iteration 1
+
+ ! --- get z0 / zt
+ z0 = 0.01 * zorl (i)
+ zt = 0.01 * ztrl (i)
+
+ z0max = max (1.0e-6, min (z0, z1 (i)))
+ ztmax = max (zt, 1.0e-6)
+
+ ! --- call similarity
+ call monin_obukhov_similarity &
+ (z1 (i), snwdph (i), thv1, wind (i), z0max, ztmax, tvs, &
+ rb (i), fm (i), fh (i), fm10 (i), fh2 (i), &
+ cm (i), ch (i), stress (i), ustar (i))
+
+ ! === iteration 2
+
+ ! --- get z0 / zt following the old sfc_diff.f
+ z0 = (charnock / grav) * ustar (i) * ustar (i)
+ if (redrag) then
+ z0 = max (min (z0, z0s_max), 1.e-7)
+ else
+ z0 = max (min (z0, .1), 1.e-7)
+ endif
+
+ ! zt calculations copied from old sfc_diff.f
+ !ustar (i) = sqrt (grav * z0 / charnock)
+ !restar = max (ustar (i) * z0max * visi, 0.000001)
+ !rat = min (7.0, 2.67 * sqrt (sqrt (restar)) - 2.57)
+ !ztmax = z0max * exp (- rat)
+
+ ustar_1 = sqrt (grav * z0 / charnock)
+ restar = max (ustar_1 * z0max * visi, 0.000001)
+ rat = min (7.0, 2.67 * sqrt (sqrt (restar)) - 2.57)
+ zt = z0max * exp (- rat) ! zeng, zhao and dickinson 1997 (eq 25)
+
+ ! --- update z0 / zt with new options
+ ! only z0 options in the following
+ ! will add zt options in the future
+
+ u10m = u1 (i) * fm10 (i) / fm (i)
+ v10m = v1 (i) * fm10 (i) / fm (i)
+ ws10m = sqrt (u10m * u10m + v10m * v10m)
+
+ if (do_z0_hwrf15) then
+ ! option 1: hwrf15, originally developed by uri / gfdl
+ call cal_z0_hwrf15 (ws10m, z0)
+ call cal_zt_hwrf15 (ws10m, zt)
+
+ elseif (do_z0_hwrf17) then
+ ! option 2: hwrf17
+ call cal_z0_hwrf17 (ws10m, z0)
+ call cal_zt_hwrf17 (ws10m, zt)
+
+ elseif (do_z0_hwrf17_hwonly) then
+ ! option 3: hwrf17 under high wind only
+ if (ws10m > wind_th_hwrf) then
+ call cal_z0_hwrf17 (ws10m, z0)
+ z0 = max (min (z0, z0s_max), 1.e-7) ! must apply limiter here
+ endif
+
+ elseif (do_z0_moon) then
+ ! option 4: moon et al 2007 under high winds (same as in hiram)
+ ws10m_moon = 2.458 + ustar (i) * (20.255 - 0.56 * ustar (i)) ! eq (7) moon et al. 2007
+ if (ws10m_moon > 20.) then
+ call cal_z0_moon (ws10m_moon, z0)
+ z0 = max (min (z0, z0s_max), 1.e-7) ! must apply limiter here
+ endif
+ endif
+
+ z0max = max (z0, 1.0e-6)
+ ztmax = max (zt, 1.0e-6)
+
+ ! --- call similarity
+ call monin_obukhov_similarity &
+ (z1 (i), snwdph (i), thv1, wind (i), z0max, ztmax, tvs, &
+ rb (i), fm (i), fh (i), fm10 (i), fh2 (i), &
+ cm (i), ch (i), stress (i), ustar (i))
+
+ zorl (i) = 100.0 * z0max
+ ztrl (i) = 100.0 * ztmax
+
+ endif ! end of if (islimsk) loop
+ endif ! end of if (flagiter) loop
+ enddo ! end of do i = 1, im loop
+
+ return
+
+end subroutine sfc_exch_gfdl
+
+! =======================================================================
+! Originally developed by URI/GFDL
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_z0_hwrf15 (ws10m, z0)
+
+ real :: ws10m, z0
+
+ real, parameter :: &
+ a0 = - 8.367276172397277e-12, &
+ a1 = 1.7398510865876079e-09, &
+ a2 = - 1.331896578363359e-07, &
+ a3 = 4.507055294438727e-06, &
+ a4 = - 6.508676881906914e-05, &
+ a5 = 0.00044745137674732834, &
+ a6 = - 0.0010745704660847233, &
+ b0 = 2.1151080765239772e-13, &
+ b1 = - 3.2260663894433345e-11, &
+ b2 = - 3.329705958751961e-10, &
+ b3 = 1.7648562021709124e-07, &
+ b4 = 7.107636825694182e-06, &
+ b5 = - 0.0013914681964973246, &
+ b6 = 0.0406766967657759
+
+ if (ws10m <= 5.0) then
+ z0 = 0.0185 / 9.8 * (7.59e-4 * ws10m ** 2 + 2.46e-2 * ws10m) ** 2
+ elseif (ws10m > 5.0 .and. ws10m <= 10.) then
+ z0 = 0.00000235 * (ws10m ** 2 - 25.) + 3.805129199617346e-05
+ elseif (ws10m > 10.0 .and. ws10m <= 60.) then
+ z0 = a6 + a5 * ws10m + a4 * ws10m ** 2 + a3 * ws10m ** 3 + &
+ a2 * ws10m ** 4 + a1 * ws10m ** 5 + a0 * ws10m ** 6
+ else
+ z0 = b6 + b5 * ws10m + b4 * ws10m ** 2 + b3 * ws10m ** 3 + &
+ b2 * ws10m ** 4 + b1 * ws10m ** 5 + b0 * ws10m ** 6
+ endif
+
+end subroutine cal_z0_hwrf15
+
+! =======================================================================
+! Originally developed by URI/GFDL
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_zt_hwrf15 (ws10m, zt)
+
+ real :: ws10m, zt
+
+ real, parameter :: &
+ a0 = 2.51715926619e-09, &
+ a1 = - 1.66917514012e-07, &
+ a2 = 4.57345863551e-06, &
+ a3 = - 6.64883696932e-05, &
+ a4 = 0.00054390175125, &
+ a5 = - 0.00239645231325, &
+ a6 = 0.00453024927761, &
+ b0 = - 1.72935914649e-14, &
+ b1 = 2.50587455802e-12, &
+ b2 = - 7.90109676541e-11, &
+ b3 = - 4.40976353607e-09, &
+ b4 = 3.68968179733e-07, &
+ b5 = - 9.43728336756e-06, &
+ b6 = 8.90731312383e-05, &
+ c0 = 4.68042680888e-14, &
+ c1 = - 1.98125754931e-11, &
+ c2 = 3.41357133496e-09, &
+ c3 = - 3.05130605309e-07, &
+ c4 = 1.48243563819e-05, &
+ c5 = - 0.000367207751936, &
+ c6 = 0.00357204479347
+
+ if (ws10m <= 7.0) then
+ zt = 0.0185 / 9.8 * (7.59e-4 * ws10m ** 2 + 2.46e-2 * ws10m) ** 2
+ elseif (ws10m > 7.0 .and. ws10m <= 15.) then
+ zt = a6 + a5 * ws10m + a4 * ws10m ** 2 + a3 * ws10m ** 3 + &
+ a2 * ws10m ** 4 + a1 * ws10m ** 5 + a0 * ws10m ** 6
+ elseif (ws10m > 15.0 .and. ws10m <= 60.) then
+ zt = b6 + b5 * ws10m + b4 * ws10m ** 2 + b3 * ws10m ** 3 + &
+ b2 * ws10m ** 4 + b1 * ws10m ** 5 + b0 * ws10m ** 6
+ else
+ zt = c6 + c5 * ws10m + c4 * ws10m ** 2 + c3 * ws10m ** 3 + &
+ c2 * ws10m ** 4 + c1 * ws10m ** 5 + c0 * ws10m ** 6
+ endif
+
+end subroutine cal_zt_hwrf15
+
+! =======================================================================
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_z0_hwrf17 (ws10m, z0)
+
+ real :: ws10m, z0
+
+ real, parameter :: &
+ p13 = - 1.296521881682694e-02, &
+ p12 = 2.855780863283819e-01, &
+ p11 = - 1.597898515251717e+00, &
+ p10 = - 8.396975715683501e+00, &
+ p25 = 3.790846746036765e-10, &
+ p24 = 3.281964357650687e-09, &
+ p23 = 1.962282433562894e-07, &
+ p22 = - 1.240239171056262e-06, &
+ p21 = 1.739759082358234e-07, &
+ p20 = 2.147264020369413e-05, &
+ p35 = 1.840430200185075e-07, &
+ p34 = - 2.793849676757154e-05, &
+ p33 = 1.735308193700643e-03, &
+ p32 = - 6.139315534216305e-02, &
+ p31 = 1.255457892775006e+00, &
+ p30 = - 1.663993561652530e+01, &
+ p40 = 4.579369142033410e-04
+
+ if (ws10m <= 6.5) then
+ z0 = exp (p10 + p11 * ws10m + p12 * ws10m ** 2 + p13 * ws10m ** 3)
+ elseif (ws10m > 6.5 .and. ws10m <= 15.7) then
+ z0 = p25 * ws10m ** 5 + p24 * ws10m ** 4 + p23 * ws10m ** 3 + &
+ p22 * ws10m ** 2 + p21 * ws10m + p20
+ elseif (ws10m > 15.7 .and. ws10m <= 53.) then
+ z0 = exp (p35 * ws10m ** 5 + p34 * ws10m ** 4 + p33 * ws10m ** 3 + &
+ p32 * ws10m ** 2 + p31 * ws10m + p30)
+ else
+ z0 = p40
+ endif
+
+end subroutine cal_z0_hwrf17
+
+! =======================================================================
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_zt_hwrf17 (ws10m, zt)
+
+ real :: ws10m, zt
+
+ real, parameter :: p00 = 1.100000000000000e-04, &
+ p15 = - 9.144581627678278e-10, p14 = 7.020346616456421e-08, &
+ p13 = - 2.155602086883837e-06, p12 = 3.333848806567684e-05, &
+ p11 = - 2.628501274963990e-04, p10 = 8.634221567969181e-04, &
+ p25 = - 8.654513012535990e-12, p24 = 1.232380050058077e-09, &
+ p23 = - 6.837922749505057e-08, p22 = 1.871407733439947e-06, &
+ p21 = - 2.552246987137160e-05, p20 = 1.428968311457630e-04, &
+ p35 = 3.207515102100162e-12, p34 = - 2.945761895342535e-10, &
+ p33 = 8.788972147364181e-09, p32 = - 3.814457439412957e-08, &
+ p31 = - 2.448983648874671e-06, p30 = 3.436721779020359e-05, &
+ p45 = - 3.530687797132211e-11, p44 = 3.939867958963747e-09, &
+ p43 = - 1.227668406985956e-08, p42 = - 1.367469811838390e-05, &
+ p41 = 5.988240863928883e-04, p40 = - 7.746288511324971e-03, &
+ p56 = - 1.187982453329086e-13, p55 = 4.801984186231693e-11, &
+ p54 = - 8.049200462388188e-09, p53 = 7.169872601310186e-07, &
+ p52 = - 3.581694433758150e-05, p51 = 9.503919224192534e-04, &
+ p50 = - 1.036679430885215e-02, &
+ p60 = 4.751256171799112e-05
+
+ if (ws10m >= 0.0 .and. ws10m < 5.9) then
+ zt = p00
+ elseif (ws10m >= 5.9 .and. ws10m <= 15.4) then
+ zt = p10 + ws10m * (p11 + ws10m * (p12 + ws10m * (p13 + &
+ ws10m * (p14 + ws10m * p15))))
+ elseif (ws10m > 15.4 .and. ws10m <= 21.6) then
+ zt = p20 + ws10m * (p21 + ws10m * (p22 + ws10m * (p23 + &
+ ws10m * (p24 + ws10m * p25))))
+ elseif (ws10m > 21.6 .and. ws10m <= 42.2) then
+ zt = p30 + ws10m * (p31 + ws10m * (p32 + ws10m * (p33 + &
+ ws10m * (p34 + ws10m * p35))))
+ elseif (ws10m > 42.2 .and. ws10m <= 53.3) then
+ zt = p40 + ws10m * (p41 + ws10m * (p42 + ws10m * (p43 + &
+ ws10m * (p44 + ws10m * p45))))
+ elseif (ws10m > 53.3 .and. ws10m <= 80.0) then
+ zt = p50 + ws10m * (p51 + ws10m * (p52 + ws10m * (p53 + &
+ ws10m * (p54 + ws10m * (p55 + ws10m * p56)))))
+ elseif (ws10m > 80.0) then
+ zt = p60
+ endif
+
+end subroutine cal_zt_hwrf17
+
+! =======================================================================
+! Coded by Kun Gao (kun.gao@noaa.gov)
+! =======================================================================
+
+subroutine cal_z0_moon (ws10m, z0)
+
+ real :: ws10m, z0
+
+ real :: ustar_th, z0_adj
+
+ real, parameter :: &
+ charnock = .014, &
+ wind_th_moon = 20., &
+ a = 0.56, &
+ b = - 20.255, &
+ c = wind_th_moon - 2.458
+
+ ustar_th = (- b - sqrt (b * b - 4 * a * c)) / (2 * a)
+
+ z0_adj = 0.001 * (0.085 * wind_th_moon - 0.58) - &
+ (charnock / grav) * ustar_th * ustar_th
+
+ z0 = 0.001 * (0.085 * ws10m - 0.58) - z0_adj ! eq (8b) moon et al. 2007 modified by kgao
+
+end subroutine cal_z0_moon
+
+! =======================================================================
+! Monin Obukhov Similarity
+! =======================================================================
+
+subroutine monin_obukhov_similarity ( &
+ z1, snwdph, thv1, wind, z0max, ztmax, tvs, &
+ rb, fm, fh, fm10, fh2, cm, ch, stress, ustar)
+
+ ! --- input
+ ! z1 - lowest model level height
+ ! snwdph - surface snow thickness
+ ! wind - wind speed at lowest model layer
+ ! thv1 - virtual potential temp at lowest model layer
+ ! tvs - surface temp
+ ! z0max - surface roughness length for momentum
+ ! ztmax - surface roughness length for heat
+ !
+ ! --- output
+ ! rb - a bulk richardson number
+ ! fm, fh - similarity function defined at lowest model layer
+ ! fm10, fh2 - similarity function defined at 10m (for momentum) and 2m (for heat)
+ ! cm, ch - surface exchange coefficients for momentum and heat
+ ! stress - surface wind stress
+ ! ustar - surface frictional velocity
+
+ ! --- inputs:
+ real, intent (in) :: z1, snwdph, thv1, wind, z0max, ztmax, tvs
+
+ ! --- outputs:
+ real, intent (out) :: rb, fm, fh, fm10, fh2, cm, ch, stress, ustar
+
+ ! --- locals:
+
+ real, parameter :: alpha = 5., a0 = - 3.975, &
+ a1 = 12.32, alpha4 = 4.0 * alpha, &
+ b1 = - 7.755, b2 = 6.041, alpha2 = alpha + alpha, beta = 1.0, &
+ a0p = - 7.941, a1p = 24.75, b1p = - 8.705, b2p = 7.899, &
+ ztmin1 = - 999.0, ca = .4
+
+ real :: aa, aa0, bb, bb0, dtv, adtv, &
+ hl1, hl12, pm, ph, pm10, ph2, &
+ z1i, &
+ fms, fhs, hl0, hl0inf, hlinf, &
+ hl110, hlt, hltinf, olinf, &
+ tem1, tem2, ztmax1
+
+ z1i = 1.0 / z1
+
+ tem1 = z0max / z1
+ if (abs (1.0 - tem1) > 1.0e-6) then
+ ztmax1 = - beta * log (tem1) / (alpha2 * (1. - tem1))
+ else
+ ztmax1 = 99.0
+ endif
+ if (z0max < 0.05 .and. snwdph < 10.0) ztmax1 = 99.0
+
+ !
+ ! compute stability indices (rb and hlinf)
+ !
+ dtv = thv1 - tvs
+ adtv = max (abs (dtv), 0.001)
+ dtv = sign (1., dtv) * adtv
+ rb = max (- 5000.0, (grav + grav) * dtv * z1 / &
+ ((thv1 + tvs) * wind * wind))
+ tem1 = 1.0 / z0max
+ tem2 = 1.0 / ztmax
+ fm = log ((z0max + z1) * tem1)
+ fh = log ((ztmax + z1) * tem2)
+ fm10 = log ((z0max + 10.) * tem1)
+ fh2 = log ((ztmax + 2.) * tem2)
+ hlinf = rb * fm * fm / fh
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+ !
+ ! stable case
+ !
+ if (dtv >= 0.0) then
+ hl1 = hlinf
+ if (hlinf > .25) then
+ tem1 = hlinf * z1i
+ hl0inf = z0max * tem1
+ hltinf = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hlinf)
+ aa0 = sqrt (1. + alpha4 * hl0inf)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hltinf)
+ pm = aa0 - aa + log ((aa + 1.) / (aa0 + 1.))
+ ph = bb0 - bb + log ((bb + 1.) / (bb0 + 1.))
+ fms = fm - pm
+ fhs = fh - ph
+ hl1 = fms * fms * rb / fhs
+ hl1 = min (max (hl1, ztmin1), ztmax1)
+ endif
+ !
+ ! second iteration
+ !
+ tem1 = hl1 * z1i
+ hl0 = z0max * tem1
+ hlt = ztmax * tem1
+ aa = sqrt (1. + alpha4 * hl1)
+ aa0 = sqrt (1. + alpha4 * hl0)
+ bb = aa
+ bb0 = sqrt (1. + alpha4 * hlt)
+ pm = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ ph = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ aa = sqrt (1. + alpha4 * hl110)
+ pm10 = aa0 - aa + log ((1.0 + aa) / (1.0 + aa0))
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ! aa = sqrt (1. + alpha4 * hl12)
+ bb = sqrt (1. + alpha4 * hl12)
+ ph2 = bb0 - bb + log ((1.0 + bb) / (1.0 + bb0))
+ !
+ ! unstable case - check for unphysical obukhov length
+ !
+ else ! dtv < 0 case
+ olinf = z1 / hlinf
+ tem1 = 50.0 * z0max
+ if (abs (olinf) <= tem1) then
+ hlinf = - z1 / tem1
+ hlinf = min (max (hlinf, ztmin1), ztmax1)
+ endif
+ !
+ ! get pm and ph
+ !
+ if (hlinf >= - 0.5) then
+ hl1 = hlinf
+ pm = (a0 + a1 * hl1) * hl1 / (1. + (b1 + b2 * hl1) * hl1)
+ ph = (a0p + a1p * hl1) * hl1 / (1. + (b1p + b2p * hl1) * hl1)
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = (a0 + a1 * hl110) * hl110 / (1. + (b1 + b2 * hl110) * hl110)
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = (a0p + a1p * hl12) * hl12 / (1. + (b1p + b2p * hl12) * hl12)
+ else ! hlinf < 0.05
+ hl1 = - hlinf
+ tem1 = 1.0 / sqrt (hl1)
+ pm = log (hl1) + 2. * sqrt (tem1) - .8776
+ ph = log (hl1) + .5 * tem1 + 1.386
+ ! pm = log (hl1) + 2.0 * hl1 ** (- .25) - .8776
+ ! ph = log (hl1) + 0.5 * hl1 ** (- .5) + 1.386
+ hl110 = hl1 * 10. * z1i
+ hl110 = min (max (hl110, ztmin1), ztmax1)
+ pm10 = log (hl110) + 2.0 / sqrt (sqrt (hl110)) - .8776
+ ! pm10 = log (hl110) + 2. * hl110 ** (- .25) - .8776
+ hl12 = (hl1 + hl1) * z1i
+ hl12 = min (max (hl12, ztmin1), ztmax1)
+ ph2 = log (hl12) + 0.5 / sqrt (hl12) + 1.386
+ ! ph2 = log (hl12) + .5 * hl12 ** (- .5) + 1.386
+ endif
+
+ endif ! end of if (dtv >= 0) then loop
+ !
+ ! finish the exchange coefficient computation to provide fm and fh
+ !
+ fm = fm - pm
+ fh = fh - ph
+ fm10 = fm10 - pm10
+ fh2 = fh2 - ph2
+ cm = ca * ca / (fm * fm)
+ ch = ca * ca / (fm * fh)
+ tem1 = 0.00001 / z1
+ cm = max (cm, tem1)
+ ch = max (ch, tem1)
+ stress = cm * wind * wind
+ ustar = sqrt (stress)
+
+ return
+
+end subroutine monin_obukhov_similarity
+
+! =======================================================================
+! subroutine to surface energy balance over ocean
+!
+! program history log:
+! 2005 -- created from the original progtm to account for ocean only
+! oct 2006 -- h. wei added cmm and chh to the output
+! apr 2009 -- y. - t. hou modified to match the modified gbphys.f
+! reformatted the code and added program documentation
+! sep 2009 -- s. moorthi removed rcl and made pa as pressure unit
+! and furthur reformatted the code
+!
+! inputs: size
+! im - integer, horizontal dimension 1
+! ps - real, surface pressure im
+! u1, v1 - real, u / v component of surface layer wind im
+! t1 - real, surface layer mean temperature (k) im
+! q1 - real, surface layer mean specific humidity im
+! tsurf - real, ground surface skin temperature (k) im
+! cm - real, surface exchange coeff for momentum (m / s) im
+! ch - real, surface exchange coeff heat & moisture (m / s) im
+! prsl1 - real, surface layer mean pressure im
+! prslki - real, im
+! islimsk - integer, sea / land / ice mask (= 0 / 1 / 2) im
+! ddvel - real, wind enhancement due to convection (m / s) im
+! flag_iter - logical, im
+!
+! outputs: size
+! qsurf - real, specific humidity at sfc im
+! cmm - real, im
+! chh - real, im
+! gflux - real, ground heat flux (zero for ocean) im
+! evap - real, evaporation from latent heat flux im
+! hflx - real, sensible heat flux im
+! ep - real, potential evaporation im
+! =======================================================================
+
+subroutine sfc_ocea (im, ps, u1, v1, t1, q1, tsurf, cm, ch, &
+ prsl1, prslki, islimsk, qsurf, cmm, chh, gflux, evap, hflx, ep)
+
+ implicit none
+
+ ! --- constant parameters:
+ real, parameter :: cpinv = 1.0 / cp_air, &
+ hvapi = 1.0 / hlv, &
+ elocp = hlv / cp_air
+
+ ! --- inputs:
+ integer, intent (in) :: im
+
+ real, dimension (im), intent (in) :: ps, u1, v1, &
+ t1, q1, tsurf, cm, ch, prsl1, prslki
+ integer, dimension (im), intent (in) :: islimsk
+
+ ! --- outputs:
+ real, dimension (im), intent (inout) :: qsurf, &
+ cmm, chh, gflux, evap, hflx, ep
+
+ ! --- locals:
+
+ real :: q0, qss, rch, rho, wind, tem, ddvel (im)
+
+ integer :: i
+
+ logical :: flag (im), flag_iter (im)
+ !
+ ! ===> ... begin here
+ !
+ ! --- ... flag for open water
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+ flag (i) = (islimsk (i) == 0 .and. flag_iter (i))
+
+ ! --- ... initialize variables. all units are supposedly m.k.s. unless specified
+ ! ps is in pascals, wind is wind speed,
+ ! rho is density, qss is sat. hum. at surface
+
+ if (flag (i)) then
+
+ wind = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+
+ q0 = max (q1 (i), 1.0e-8)
+ rho = prsl1 (i) / (rdgas * t1 (i) * (1.0 + zvir * q0))
+
+ qss = mqs (tsurf (i))
+ qss = eps * qss / (ps (i) + epsm1 * qss)
+
+ evap (i) = 0.0
+ hflx (i) = 0.0
+ ep (i) = 0.0
+ gflux (i) = 0.0
+
+ ! --- ... rcp = rho cp_air ch v
+
+ rch = rho * cp_air * ch (i) * wind
+ cmm (i) = cm (i) * wind
+ chh (i) = rho * ch (i) * wind
+
+ ! --- ... sensible and latent heat flux over open water
+
+ hflx (i) = rch * (tsurf (i) - t1 (i) * prslki (i))
+
+ evap (i) = elocp * rch * (qss - q0)
+ qsurf (i) = qss
+
+ tem = 1.0 / rho
+ hflx (i) = hflx (i) * tem * cpinv
+ evap (i) = evap (i) * tem * hvapi
+ endif
+ enddo
+
+end subroutine sfc_ocea
+
+! =======================================================================
+! subroutine to surface energy balance over land
+! =======================================================================
+
+! =======================================================================
+! subroutine to surface energy balance over seaice
+!
+! program history log:
+! 2005 -- xingren wu created from original progtm and added
+! two - layer ice model
+! 200x -- sarah lu added flag_iter
+! oct 2006 -- h. wei added cmm and chh to output
+! 2007 -- x. wu modified for mom4 coupling (i.e. mom4ice)
+! 2007 -- s. moorthi micellaneous changes
+! may 2009 -- y. - t. hou modified to include surface emissivity
+! effect on lw radiation. replaced the confusing
+! slrad with sfc net sw sfcnsw (dn - up) . reformatted
+! the code and add program documentation block.
+! sep 2009 -- s. moorthi removed rcl, changed pressure units and
+! further optimized
+! jan 2015 -- x. wu change "cimin = 0.15" for both
+! uncoupled and coupled case
+!
+! inputs: size
+! im, km - integer, horiz dimension and num of soil layers 1
+! ps - real, surface pressure im
+! u1, v1 - real, u / v component of surface layer wind im
+! t1 - real, surface layer mean temperature (k) im
+! q1 - real, surface layer mean specific humidity im
+! delt - real, time interval (second) 1
+! sfcemis - real, sfc lw emissivity (fraction) im
+! dlwflx - real, total sky sfc downward lw flux (w / m ** 2) im
+! sfcnsw - real, total sky sfc netsw flx into ground (w / m ** 2) im
+! sfcdsw - real, total sky sfc downward sw flux (w / m ** 2) im
+! srflag - real, snow / rain flag for precipitation im
+! cm - real, surface exchange coeff for momentum (m / s) im
+! ch - real, surface exchange coeff heat & moisture (m / s) im
+! prsl1 - real, surface layer mean pressure im
+! prslki - real, im
+! islimsk - integer, sea / land / ice mask (= 0 / 1 / 2) im
+! ddvel - real, im
+! flag_iter - logical, im
+! mom4ice - logical, im
+! islimsk - integer, flag for land surface model scheme 1
+! = 0: use osu scheme; = 1: use noah scheme
+!
+! input / outputs:
+! hice - real, sea - ice thickness im
+! fice - real, sea - ice concentration im
+! tice - real, sea - ice surface temperature im
+! weasd - real, water equivalent accumulated snow depth (mm) im
+! tsurf - real, ground surface skin temperature (k) im
+! tprcp - real, total precipitation im
+! stc - real, soil temp (k) im, km
+! ep - real, potential evaporation im
+!
+! outputs:
+! snwdph - real, water equivalent snow depth (mm) im
+! qsurf - real, specific humidity at sfc im
+! snowmt - real, snow melt (m) im
+! gflux - real, soil heat flux (w / m ** 2) im
+! cmm - real, im
+! chh - real, im
+! evap - real, evaperation from latent heat flux im
+! hflx - real, sensible heat flux im
+! =======================================================================
+
+subroutine sfc_seai (im, km, ps, u1, v1, t1, q1, delt, &
+ sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, &
+ cm, ch, prsl1, prslki, islimsk, mom4ice, lsm, &
+ hice, fice, tice, weasd, tsurf, tprcp, stc, ep, &
+ snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx)
+
+ implicit none
+
+ ! --- constant parameters:
+ integer, parameter :: kmi = 2 ! 2 - layer of ice
+ real, parameter :: cpinv = 1.0 / cp_air
+ real, parameter :: hvapi = 1.0 / hlv
+ real, parameter :: elocp = hlv / cp_air
+ real, parameter :: himax = 8.0 ! maximum ice thickness allowed
+ real, parameter :: himin = 0.1 ! minimum ice thickness required
+ real, parameter :: hsmax = 2.0 ! maximum snow depth allowed
+ real, parameter :: timin = 173.0 ! minimum temperature allowed for snow / ice
+ real, parameter :: albfw = 0.06 ! albedo for lead
+ real, parameter :: dsi = 1.0 / 0.33
+
+ ! --- inputs:
+ integer, intent (in) :: im, km, lsm
+
+ real, dimension (im), intent (in) :: ps, u1, v1, &
+ t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, &
+ prsl1, prslki
+
+ integer, dimension (im), intent (in) :: islimsk
+ real, intent (in) :: delt
+
+ logical, intent (in) :: mom4ice
+
+ ! --- input / outputs:
+ real, dimension (im), intent (inout) :: hice, &
+ fice, tice, weasd, tsurf, tprcp, ep
+
+ real, dimension (im, km), intent (inout) :: stc
+
+ ! --- outputs:
+ real, dimension (im), intent (inout) :: snwdph, &
+ qsurf, snowmt, gflux, cmm, chh, evap, hflx
+
+ ! --- locals:
+ real, dimension (im) :: ffw, evapi, evapw, &
+ sneti, snetw, hfd, hfi, &
+ ! hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, &
+ focn, snof, hi_save, hs_save, rch, rho, &
+ snowd, theta1, ddvel
+
+ real :: t12, t14, tem, stsice (im, kmi), &
+ hflxi, hflxw, q0, qs1, wind, qssi, qssw
+ real, parameter :: cimin = 0.15 ! --- minimum ice concentration
+
+ integer :: i, k
+
+ logical :: flag (im), flag_iter (im)
+ !
+ ! ===> ... begin here
+ !
+ ! --- ... set flag for sea - ice
+
+ ddvel = 0.0
+ flag_iter = .true.
+
+ do i = 1, im
+ flag (i) = (islimsk (i) >= 2) .and. flag_iter (i)
+ if (flag_iter (i) .and. islimsk (i) < 2) then
+ hice (i) = 0.0
+ fice (i) = 0.0
+ endif
+ enddo
+
+ ! --- ... update sea ice temperature
+
+ do k = 1, kmi
+ do i = 1, im
+ if (flag (i)) then
+ stsice (i, k) = stc (i, k)
+ endif
+ enddo
+ enddo
+ !
+ if (mom4ice) then
+ do i = 1, im
+ if (flag (i)) then
+ hi_save (i) = hice (i)
+ hs_save (i) = weasd (i) * 0.001
+ endif
+ enddo
+ elseif (lsm > 0) then ! --- ... snow - rain detection
+ do i = 1, im
+ if (flag (i)) then
+ if (srflag (i) == 1.0) then
+ ep (i) = 0.0
+ weasd (i) = weasd (i) + 1.e3 * tprcp (i)
+ tprcp (i) = 0.0
+ endif
+ endif
+ enddo
+ endif
+
+ ! --- ... initialize variables. all units are supposedly m.k.s. unless specifie
+ ! psurf is in pascals, wind is wind speed, theta1 is adiabatic surface
+ ! temp from level 1, rho is density, qs1 is sat. hum. at level1 and qss
+ ! is sat. hum. at surface
+ ! convert slrad to the civilized unit from langley minute - 1 k - 4
+
+ do i = 1, im
+ if (flag (i)) then
+ ! psurf (i) = 1000.0 * ps (i)
+ ! ps1 (i) = 1000.0 * prsl1 (i)
+
+ ! dlwflx has been given a negative sign for downward longwave
+ ! sfcnsw is the net shortwave flux (direction: dn - up)
+
+ wind = max (sqrt (u1 (i) * u1 (i) + v1 (i) * v1 (i)) &
+ + max (0.0, min (ddvel (i), 30.0)), 1.0)
+
+ q0 = max (q1 (i), 1.0e-8)
+ theta1 (i) = t1 (i) * prslki (i)
+ rho (i) = prsl1 (i) / (rdgas * t1 (i) * (1.0 + zvir * q0))
+ qs1 = mqs (t1 (i))
+ qs1 = max (eps * qs1 / (prsl1 (i) + epsm1 * qs1), 1.e-8)
+ q0 = min (qs1, q0)
+
+ ffw (i) = 1.0 - fice (i)
+ if (fice (i) < cimin) then
+ print *, 'warning: ice fraction is low:', fice (i)
+ fice (i) = cimin
+ ffw (i) = 1.0 - fice (i)
+ tice (i) = tgice
+ tsurf (i) = tgice
+ print *, 'fix ice fraction: reset it to:', fice (i)
+ endif
+
+ qssi = mqs (tice (i))
+ qssi = eps * qssi / (ps (i) + epsm1 * qssi)
+ qssw = mqs (tgice)
+ qssw = eps * qssw / (ps (i) + epsm1 * qssw)
+
+ ! --- ... snow depth in water equivalent is converted from mm to m unit
+
+ if (mom4ice) then
+ snowd (i) = weasd (i) * 0.001 / fice (i)
+ else
+ snowd (i) = weasd (i) * 0.001
+ endif
+ ! flagsnw (i) = .false.
+
+ ! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and
+ ! soil is allowed to interact with the atmosphere.
+ ! we should eventually move to a linear combination of soil and
+ ! snow under the condition of patchy snow.
+
+ ! --- ... rcp = rho cp_air ch v
+
+ cmm (i) = cm (i) * wind
+ chh (i) = rho (i) * ch (i) * wind
+ rch (i) = chh (i) * cp_air
+
+ ! --- ... sensible and latent heat flux over open water & sea ice
+
+ evapi (i) = elocp * rch (i) * (qssi - q0)
+ evapw (i) = elocp * rch (i) * (qssw - q0)
+ ! evap (i) = fice (i) * evapi (i) + ffw (i) * evapw (i)
+
+ ! if (lprnt) write (0, *) ' tice = ', tice (ipr)
+
+ snetw (i) = sfcdsw (i) * (1.0 - albfw)
+ snetw (i) = min (3.0 * sfcnsw (i) / (1.0 + 2.0 * ffw (i)), snetw (i))
+ sneti (i) = (sfcnsw (i) - ffw (i) * snetw (i)) / fice (i)
+
+ t12 = tice (i) * tice (i)
+ t14 = t12 * t12
+
+ ! --- ... hfi = net non - solar and upir heat flux @ ice surface
+
+ hfi (i) = - dlwflx (i) + sfcemis (i) * sbc * t14 + evapi (i) &
+ + rch (i) * (tice (i) - theta1 (i))
+ hfd (i) = 4.0 * sfcemis (i) * sbc * tice (i) * t12 &
+ + (1.0 + elocp * eps * hlv * qs1 / (rdgas * t12)) * rch (i)
+
+ t12 = tgice * tgice
+ t14 = t12 * t12
+
+ ! --- ... hfw = net heat flux @ water surface (within ice)
+
+ ! hfw (i) = - dlwflx (i) + sfcemis (i) * sbc * t14 + evapw (i) &
+ ! + rch (i) * (tgice - theta1 (i)) - snetw (i)
+
+ focn (i) = 2.0 ! heat flux from ocean - should be from ocn model
+ snof (i) = 0.0 ! snowfall rate - snow accumulates in gbphys
+
+ hice (i) = max (min (hice (i), himax), himin)
+ snowd (i) = min (snowd (i), hsmax)
+
+ if (snowd (i) > (2.0 * hice (i))) then
+ print *, 'warning: too much snow :', snowd (i)
+ snowd (i) = hice (i) + hice (i)
+ print *, 'fix: decrease snow depth to:', snowd (i)
+ endif
+ endif
+ enddo
+
+ ! if (lprnt) write (0, *) ' tice2 = ', tice (ipr)
+ call ice3lay &
+ ! --- inputs: !
+ (im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, &
+ ! --- outputs: !
+ snowd, hice, stsice, tice, snof, snowmt, gflux) !
+
+ ! if (lprnt) write (0, *) ' tice3 = ', tice (ipr)
+ if (mom4ice) then
+ do i = 1, im
+ if (flag (i)) then
+ hice (i) = hi_save (i)
+ snowd (i) = hs_save (i)
+ endif
+ enddo
+ endif
+
+ do i = 1, im
+ if (flag (i)) then
+ if (tice (i) < timin) then
+ print *, 'warning: snow / ice temperature is too low:', tice (i), ' i = ', i
+ tice (i) = timin
+ print *, 'fix snow / ice temperature: reset it to:', tice (i)
+ endif
+
+ if (stsice (i, 1) < timin) then
+ print *, 'warning: layer 1 ice temp is too low:', stsice (i, 1), ' i = ', i
+ stsice (i, 1) = timin
+ print *, 'fix layer 1 ice temp: reset it to:', stsice (i, 1)
+ endif
+
+ if (stsice (i, 2) < timin) then
+ print *, 'warning: layer 2 ice temp is too low:', stsice (i, 2)
+ stsice (i, 2) = timin
+ print *, 'fix layer 2 ice temp: reset it to:', stsice (i, 2)
+ endif
+
+ tsurf (i) = tice (i) * fice (i) + tgice * ffw (i)
+ endif
+ enddo
+
+ do k = 1, kmi
+ do i = 1, im
+ if (flag (i)) then
+ stc (i, k) = min (stsice (i, k), t0ice)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (flag (i)) then
+ ! --- ... calculate sensible heat flux (& evap over sea ice)
+
+ hflxi = rch (i) * (tice (i) - theta1 (i))
+ hflxw = rch (i) * (tgice - theta1 (i))
+ hflx (i) = fice (i) * hflxi + ffw (i) * hflxw
+ evap (i) = fice (i) * evapi (i) + ffw (i) * evapw (i)
+ !
+ ! --- ... the rest of the output
+
+ qsurf (i) = q1 (i) + evap (i) / (elocp * rch (i))
+
+ ! --- ... convert snow depth back to mm of water equivalent
+
+ weasd (i) = snowd (i) * 1000.0
+ snwdph (i) = weasd (i) * dsi ! snow depth in mm
+
+ tem = 1.0 / rho (i)
+ hflx (i) = hflx (i) * tem * cpinv
+ evap (i) = evap (i) * tem * hvapi
+ endif
+ enddo
+
+end subroutine sfc_seai
+
+! =======================================================================
+! Three-Layer Sea Ice Vertical Thermodynamics
+!
+! based on: m. winton, "a reformulated three-layer sea ice model",
+! journal of atmospheric and oceanic technology, 2000
+!
+!
+! -> +---------+ <- tice - diagnostic surface temperature ( <= 0c )
+! / | |
+! snowd | snow | <- 0-heat capacity snow layer
+! \ | |
+! => +---------+
+! / | |
+! / | | <- t1 - upper 1/2 ice temperature; this layer has
+! / | | a variable (t/s dependent) heat capacity
+! hice |...ice...|
+! \ | |
+! \ | | <- t2 - lower 1/2 ice temp. (fixed heat capacity)
+! \ | |
+! -> +---------+ <- base of ice fixed at seawater freezing temp.
+!
+! inputs: size
+! im, kmi - integer, horiz dimension and num of ice layers 1
+! fice - real, sea - ice concentration im
+! flag - logical, ice mask flag 1
+! hfi - real, net non - solar and heat flux @ surface (w / m^2) im
+! hfd - real, heat flux derivatice @ sfc (w / m^2 / deg - c) im
+! sneti - real, net solar incoming at top (w / m^2) im
+! focn - real, heat flux from ocean (w / m^2) im
+! delt - real, timestep (sec) 1
+!
+! input / outputs:
+! snowd - real, surface pressure im
+! hice - real, sea - ice thickness im
+! stsice - real, temp @ midpt of ice levels (deg c) im, km
+! tice - real, surface temperature (deg c) im
+! snof - real, snowfall rate (m / sec) im
+!
+! outputs:
+! snowmt - real, snow melt during delt (m) im
+! gflux - real, conductive heat flux (w / m^2) im
+!
+! locals:
+! hdi - real, ice - water interface (m)
+! hsni - real, snow - ice (m)
+!
+! =======================================================================
+
+subroutine ice3lay &
+ !...................................
+ ! --- inputs:
+ (im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, &
+ ! --- input / outputs:
+ snowd, hice, stsice, tice, snof, &
+ ! --- outputs:
+ snowmt, gflux)
+
+ implicit none
+
+ ! --- constant parameters: (properties of ice, snow, and seawater)
+ real, parameter :: ds = 330.0 ! snow (ov sea ice) density (kg / m^3)
+ real, parameter :: dw = 1000.0 ! fresh water density (kg / m^3)
+ real, parameter :: dsdw = ds / dw
+ real, parameter :: dwds = dw / ds
+ real, parameter :: ks = 0.31 ! conductivity of snow (w / mk)
+ real, parameter :: i0 = 0.3 ! ice surface penetrating solar fraction
+ real, parameter :: ki = 2.03 ! conductivity of ice (w / mk)
+ real, parameter :: di = 917.0 ! density of ice (kg / m^3)
+ real, parameter :: didw = di / dw
+ real, parameter :: dsdi = ds / di
+ real, parameter :: ci = 2054.0 ! heat capacity of fresh ice (j / kg / k)
+ real, parameter :: li = 3.34e5 ! latent heat of fusion (j / kg - ice)
+ real, parameter :: si = 1.0 ! salinity of sea ice
+ real, parameter :: mu = 0.054 ! relates freezing temp to salinity
+ real, parameter :: tfi = - mu * si ! sea ice freezing temp = - mu * salinity
+ real, parameter :: tfw = - 1.8 ! tfw - seawater freezing temp (c)
+ real, parameter :: tfi0 = tfi - 0.0001
+ real, parameter :: dici = di * ci
+ real, parameter :: dili = di * li
+ real, parameter :: dsli = ds * li
+ real, parameter :: ki4 = ki * 4.0
+
+ ! --- inputs:
+ integer, intent (in) :: im, kmi
+
+ real, dimension (im), intent (in) :: fice, hfi, hfd, sneti, focn
+
+ real, intent (in) :: delt
+
+ logical, dimension (im), intent (in) :: flag
+
+ ! --- input / outputs:
+ real, dimension (im), intent (inout) :: snowd, hice, tice, snof
+
+ real, dimension (im, kmi), intent (inout) :: stsice
+
+ ! --- outputs:
+ real, dimension (im), intent (out) :: snowmt, gflux
+
+ ! --- locals:
+
+ real :: dt2, dt4, dt6, h1, h2, dh, wrk, wrk1, &
+ dt2i, hdi, hsni, ai, bi, a1, b1, a10, b10, &
+ c1, ip, k12, k32, tsf, f1, tmelt, bmelt
+
+ integer :: i
+ !
+ ! ===> ... begin here
+ !
+ dt2 = 2.0 * delt
+ dt4 = 4.0 * delt
+ dt6 = 6.0 * delt
+ dt2i = 1.0 / dt2
+
+ do i = 1, im
+ if (flag (i)) then
+ snowd (i) = snowd (i) * dwds
+ hdi = (dsdw * snowd (i) + didw * hice (i))
+
+ if (hice (i) < hdi) then
+ snowd (i) = snowd (i) + hice (i) - hdi
+ hsni = (hdi - hice (i)) * dsdi
+ hice (i) = hice (i) + hsni
+ endif
+
+ snof (i) = snof (i) * dwds
+ tice (i) = tice (i) - t0ice
+ stsice (i, 1) = min (stsice (i, 1) - t0ice, tfi0) ! degc
+ stsice (i, 2) = min (stsice (i, 2) - t0ice, tfi0) ! degc
+
+ ip = i0 * sneti (i) ! ip + v (in winton ip = - i0 * sneti as sol - v)
+ if (snowd (i) > 0.0) then
+ tsf = 0.0
+ ip = 0.0
+ else
+ tsf = tfi
+ ip = i0 * sneti (i) ! ip + v here (in winton ip = - i0 * sneti)
+ endif
+ tice (i) = min (tice (i), tsf)
+
+ ! --- ... compute ice temperature
+
+ bi = hfd (i)
+ ai = hfi (i) - sneti (i) + ip - tice (i) * bi ! + v sol input here
+ k12 = ki4 * ks / (ks * hice (i) + ki4 * snowd (i))
+ k32 = (ki + ki) / hice (i)
+
+ wrk = 1.0 / (dt6 * k32 + dici * hice (i))
+ a10 = dici * hice (i) * dt2i + k32 * (dt4 * k32 + dici * hice (i)) * wrk
+ b10 = - di * hice (i) * (ci * stsice (i, 1) + li * tfi / stsice (i, 1)) &
+ * dt2i - ip &
+ - k32 * (dt4 * k32 * tfw + dici * hice (i) * stsice (i, 2)) * wrk
+
+ wrk1 = k12 / (k12 + bi)
+ a1 = a10 + bi * wrk1
+ b1 = b10 + ai * wrk1
+ c1 = dili * tfi * dt2i * hice (i)
+
+ stsice (i, 1) = - (sqrt (b1 * b1 - 4.0 * a1 * c1) + b1) / (a1 + a1)
+ tice (i) = (k12 * stsice (i, 1) - ai) / (k12 + bi)
+
+ if (tice (i) > tsf) then
+ a1 = a10 + k12
+ b1 = b10 - k12 * tsf
+ stsice (i, 1) = - (sqrt (b1 * b1 - 4.0 * a1 * c1) + b1) / (a1 + a1)
+ tice (i) = tsf
+ tmelt = (k12 * (stsice (i, 1) - tsf) - (ai + bi * tsf)) * delt
+ else
+ tmelt = 0.0
+ snowd (i) = snowd (i) + snof (i) * delt
+ endif
+
+ stsice (i, 2) = (dt2 * k32 * (stsice (i, 1) + tfw + tfw) &
+ + dici * hice (i) * stsice (i, 2)) * wrk
+
+ bmelt = (focn (i) + ki4 * (stsice (i, 2) - tfw) / hice (i)) * delt
+
+ ! --- ... resize the ice ...
+
+ h1 = 0.5 * hice (i)
+ h2 = 0.5 * hice (i)
+
+ ! --- ... top ...
+
+ if (tmelt <= snowd (i) * dsli) then
+ snowmt (i) = tmelt / dsli
+ snowd (i) = snowd (i) - snowmt (i)
+ else
+ snowmt (i) = snowd (i)
+ h1 = h1 - (tmelt - snowd (i) * dsli) &
+ / (di * (ci - li / stsice (i, 1)) * (tfi - stsice (i, 1)))
+ snowd (i) = 0.0
+ endif
+
+ ! --- ... and bottom
+
+ if (bmelt < 0.0) then
+ dh = - bmelt / (dili + dici * (tfi - tfw))
+ stsice (i, 2) = (h2 * stsice (i, 2) + dh * tfw) / (h2 + dh)
+ h2 = h2 + dh
+ else
+ h2 = h2 - bmelt / (dili + dici * (tfi - stsice (i, 2)))
+ endif
+
+ ! --- ... if ice remains, even up 2 layers, else, pass negative energy back in snow
+
+ hice (i) = h1 + h2
+
+ if (hice (i) > 0.0) then
+ if (h1 > 0.5 * hice (i)) then
+ f1 = 1.0 - (h2 + h2) / hice (i)
+ stsice (i, 2) = f1 * (stsice (i, 1) + li * tfi / (ci * stsice (i, 1))) &
+ + (1.0 - f1) * stsice (i, 2)
+
+ if (stsice (i, 2) > tfi) then
+ hice (i) = hice (i) - h2 * ci * (stsice (i, 2) - tfi) / (li * delt)
+ stsice (i, 2) = tfi
+ endif
+ else
+ f1 = (h1 + h1) / hice (i)
+ stsice (i, 1) = f1 * (stsice (i, 1) + li * tfi / (ci * stsice (i, 1))) &
+ + (1.0 - f1) * stsice (i, 2)
+ stsice (i, 1) = (stsice (i, 1) - sqrt (stsice (i, 1) * stsice (i, 1) &
+ - 4.0 * tfi * li / ci)) * 0.5
+ endif
+
+ k12 = ki4 * ks / (ks * hice (i) + ki4 * snowd (i))
+ gflux (i) = k12 * (stsice (i, 1) - tice (i))
+ else
+ snowd (i) = snowd (i) + (h1 * (ci * (stsice (i, 1) - tfi) &
+ - li * (1.0 - tfi / stsice (i, 1))) &
+ + h2 * (ci * (stsice (i, 2) - tfi) - li)) / li
+
+ hice (i) = max (0.0, snowd (i) * dsdi)
+ snowd (i) = 0.0
+ stsice (i, 1) = tfw
+ stsice (i, 2) = tfw
+ gflux (i) = 0.0
+ endif ! endif_hice_block
+
+ gflux (i) = fice (i) * gflux (i)
+ snowmt (i) = snowmt (i) * dsdw
+ snowd (i) = snowd (i) * dsdw
+ tice (i) = tice (i) + t0ice
+ stsice (i, 1) = stsice (i, 1) + t0ice
+ stsice (i, 2) = stsice (i, 2) + t0ice
+ endif ! endif_flag_block
+ enddo ! enddo_i_loop
+
+end subroutine ice3lay
+
+! =======================================================================
+! subroutine to update near surface fields
+! =======================================================================
+
+subroutine sfc_updt (im, ps, u1, v1, t1, q1, &
+ tsurf, qsurf, u10m, v10m, t2m, q2m, &
+ prslki, evap, fm, fh, fm10, fh2)
+
+ implicit none
+
+ integer im
+ real, dimension (im) :: ps, u1, v1, t1, q1, tsurf, qsurf, &
+ u10m, v10m, t2m, q2m, prslki, evap, &
+ fm, fh, fm10, fh2
+
+ ! locals
+
+ real, parameter :: qmin = 1.0e-8
+ integer k, i
+
+ real :: fhi, qss, wrk, f10m (im)
+ ! real :: sig2k, fhi, qss
+
+ ! real, parameter :: g = grav
+
+ ! estimate sigma ** k at 2 m
+
+ ! sig2k = 1. - 4. * g * 2. / (cp_air * 280.)
+
+ ! initialize variables. all units are supposedly m.k.s. unless specified
+ ! ps is in pascals
+
+ do i = 1, im
+ f10m (i) = fm10 (i) / fm (i)
+ ! f10m (i) = min (f10m (i), 1.)
+ u10m (i) = f10m (i) * u1 (i)
+ v10m (i) = f10m (i) * v1 (i)
+ fhi = fh2 (i) / fh (i)
+ ! t2m (i) = tsurf (i) * (1. - fhi) + t1 (i) * prslki (i) * fhi
+ ! sig2k = 1. - (grav + grav) / (cp_air * t2m (i))
+ ! t2m (i) = t2m (i) * sig2k
+ wrk = 1.0 - fhi
+
+ t2m (i) = tsurf (i) * wrk + t1 (i) * prslki (i) * fhi - (grav + grav) / cp_air
+
+ if (evap (i) >= 0.) then ! for evaporation > 0, use inferred qsurf to deduce q2m
+ q2m (i) = qsurf (i) * wrk + max (qmin, q1 (i)) * fhi
+ else ! for dew formation, use saturated q at tsurf
+ qss = mqs (tsurf (i))
+ qss = eps * qss / (ps (i) + epsm1 * qss)
+ q2m (i) = qss * wrk + max (qmin, q1 (i)) * fhi
+ endif
+ qss = mqs (t2m (i))
+ qss = eps * qss / (ps (i) + epsm1 * qss)
+ q2m (i) = min (q2m (i), qss)
+ enddo
+
+end subroutine sfc_updt
+
+! =======================================================================
+! solve tridiagonal problem for tke
+! =======================================================================
+
+subroutine tridit (l, n, nt, cl, cm, cu, rt, au, at)
+
+ implicit none
+
+ integer :: is, k, kk, n, nt, l, i
+
+ real :: fk (l)
+
+ real :: cl (l, 2:n), cm (l, n), cu (l, n - 1), &
+ rt (l, n * nt), &
+ au (l, n - 1), at (l, n * nt), &
+ fkk (l, 2:n - 1)
+
+ do i = 1, l
+ fk (i) = 1. / cm (i, 1)
+ au (i, 1) = fk (i) * cu (i, 1)
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ at (i, 1 + is) = fk (i) * rt (i, 1 + is)
+ enddo
+ enddo
+ do k = 2, n - 1
+ do i = 1, l
+ fkk (i, k) = 1. / (cm (i, k) - cl (i, k) * au (i, k - 1))
+ au (i, k) = fkk (i, k) * cu (i, k)
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = 2, n - 1
+ do i = 1, l
+ at (i, k + is) = fkk (i, k) * (rt (i, k + is) - cl (i, k) * at (i, k + is - 1))
+ enddo
+ enddo
+ enddo
+ do i = 1, l
+ fk (i) = 1. / (cm (i, n) - cl (i, n) * au (i, n - 1))
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ at (i, n + is) = fk (i) * (rt (i, n + is) - cl (i, n) * at (i, n + is - 1))
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ at (i, k + is) = at (i, k + is) - au (i, k) * at (i, k + is + 1)
+ enddo
+ enddo
+ enddo
+
+end subroutine tridit
+
+! =======================================================================
+! edmf parameterization siebesma et al. (2007)
+! =======================================================================
+
+subroutine mfpbltq (im, km, kmpbl, ntcw, ntrac1, delt, &
+ cnvflg, zl, zm, q1, t1, u1, v1, plyr, pix, thlx, thvx, &
+ gdx, hpbl, kpbl, vpert, buo, use_shear_pbl, wush, &
+ use_tke_pbl, tkemean, vez0fun, xmf, &
+ tcko, qcko, ucko, vcko, xlamue, a1)
+
+ implicit none
+
+ integer, intent (in) :: im, km, kmpbl, ntcw, ntrac1
+ integer :: kpbl (im)
+
+ logical :: cnvflg (im)
+
+ real :: delt
+ real :: q1 (im, km, ntrac1), &
+ t1 (im, km), u1 (im, km), v1 (im, km), &
+ plyr (im, km), pix (im, km), thlx (im, km), &
+ thvx (im, km), zl (im, km), zm (im, km), &
+ wush (im, km), &
+ gdx (im), hpbl (im), vpert (im), &
+ tkemean (im), vez0fun (im), &
+ buo (im, km), xmf (im, km), &
+ tcko (im, km), qcko (im, km, ntrac1), &
+ ucko (im, km), vcko (im, km), &
+ xlamue (im, km - 1)
+ logical use_tke_pbl, use_shear_pbl
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer i, j, k, n, ndc
+ integer kpblx (im), kpbly (im)
+
+ real :: dt2, dz, ce0, cm, &
+ factor, gocp, &
+ g, b1, f1, &
+ bb1, bb2, &
+ alp, vprtmax, a1, pgcon, &
+ qmin, qlmin, xmmx, rbint, &
+ tem, tem1, tem2, &
+ ptem, ptem1, ptem2, &
+ tkcrt, cmxfac
+
+ real :: elocp, el2orc, qs, es, &
+ tlu, gamma, qlu, &
+ thup, thvu, dq
+
+ real :: rbdn (im), rbup (im), hpblx (im), &
+ xlamuem (im, km - 1)
+ real :: delz (im), xlamax (im), ce0t (im)
+
+ real :: wu2 (im, km), thlu (im, km), &
+ qtx (im, km), qtu (im, km)
+
+ real :: xlamavg (im), sigma (im), &
+ scaldfunc (im), sumx (im)
+
+ logical totflg, flg (im)
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (gocp = g / cp_air)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (ce0 = 0.4, cm = 1.0)
+ parameter (tkcrt = 2., cmxfac = 5.)
+ parameter (qmin = 1.e-8, qlmin = 1.e-12)
+ parameter (alp = 1.5, vprtmax = 3.0, pgcon = 0.55)
+ parameter (b1 = 0.5, f1 = 0.15)
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ dt2 = delt
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ buo (i, k) = 0.
+ wu2 (i, k) = 0.
+ qtx (i, k) = q1 (i, k, 1) + q1 (i, k, ntcw)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute thermal excess
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ptem = alp * vpert (i)
+ ptem = min (ptem, vprtmax)
+ thlu (i, 1) = thlx (i, 1) + ptem
+ qtu (i, 1) = qtx (i, 1)
+ buo (i, 1) = g * ptem / thvx (i, 1)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! kgao 12 / 08 / 2023: adjust entrainment / detrainment rate based on pbl - mean tke
+ ! if tkemean > tkcrt, ce0t = sqrt (tkemean / tkcrt) * ce0
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (use_tke_pbl .and. cnvflg (i)) then
+ ce0t (i) = ce0 * vez0fun (i)
+ if (tkemean (i) > tkcrt) then
+ tem = sqrt (tkemean (i) / tkcrt)
+ tem1 = min (tem, cmxfac)
+ tem2 = tem1 * ce0
+ ce0t (i) = max (ce0t (i), tem2)
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kpbl (i) / 2
+ k = max (k, 1)
+ delz (i) = zl (i, k + 1) - zl (i, k)
+ ! kgao 12 / 08 / 2023
+ if (use_tke_pbl) then
+ xlamax (i) = ce0t (i) / delz (i)
+ else
+ xlamax (i) = ce0 / delz (i)
+ endif
+ endif
+ enddo
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k < kpbl (i)) then
+ ptem = 1. / (zm (i, k) + delz (i))
+ tem = max ((hpbl (i) - zm (i, k) + delz (i)), delz (i))
+ ptem1 = 1. / tem
+ ! kgao 12 / 08 / 2023
+ if (use_tke_pbl) then
+ xlamue (i, k) = ce0t (i) * (ptem + ptem1)
+ else
+ xlamue (i, k) = ce0 * (ptem + ptem1)
+ endif
+ else
+ xlamue (i, k) = xlamax (i)
+ endif
+ xlamuem (i, k) = cm * xlamue (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy for updraft air parcel
+ ! -----------------------------------------------------------------------
+
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ thlu (i, k) = ((1. - tem) * thlu (i, k - 1) + tem * &
+ (thlx (i, k - 1) + thlx (i, k))) / factor
+ qtu (i, k) = ((1. - tem) * qtu (i, k - 1) + tem * &
+ (qtx (i, k - 1) + qtx (i, k))) / factor
+
+ tlu = thlu (i, k) / pix (i, k)
+ es = 0.01 * mqs (tlu) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtu (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tlu ** 2)
+ qlu = dq / (1. + gamma)
+ qtu (i, k) = qs + qlu
+ tem1 = 1. + zvir * qs - qlu
+ thup = thlu (i, k) + pix (i, k) * elocp * qlu
+ thvu = thup * tem1
+ else
+ tem1 = 1. + zvir * qtu (i, k)
+ thvu = thlu (i, k) * tem1
+ endif
+ buo (i, k) = g * (thvu / thvx (i, k) - 1.)
+
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft velocity square (wu2)
+ ! -----------------------------------------------------------------------
+
+ ! tem = 1. - 2. * f1
+ ! bb1 = 2. * b1 / tem
+ ! bb2 = 2. / tem
+ ! from soares et al. (2004, qjrms)
+ ! bb1 = 2.
+ ! bb2 = 4.
+
+ ! from bretherton et al. (2004, mwr)
+ ! bb1 = 4.
+ ! bb2 = 2.
+
+ ! from our tuning
+ bb1 = 2.0
+ bb2 = 4.0
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zm (i, 1)
+ tem = 0.5 * bb1 * xlamue (i, 1) * dz
+ tem1 = bb2 * buo (i, 1) * dz
+ ptem1 = 1. + tem
+ wu2 (i, 1) = tem1 / ptem1
+ endif
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i)) then
+ dz = zm (i, k) - zm (i, k - 1)
+ tem = 0.25 * bb1 * (xlamue (i, k - 1) + xlamue (i, k)) * dz
+ ! kgao 12 / 15 / 2023 - consider shear effect on wu diagnosis
+ if (use_shear_pbl) then
+ tem1 = max (wu2 (i, k - 1), 0.)
+ tem1 = bb2 * buo (i, k) - wush (i, k) * sqrt (tem1)
+ tem2 = tem1 * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ else
+ tem1 = bb2 * buo (i, k) * dz
+ ptem = (1. - tem) * wu2 (i, k - 1)
+ ptem1 = 1. + tem
+ wu2 (i, k) = (ptem + tem1) / ptem1
+ endif
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! update pbl height as the height where updraft velocity vanishes
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = .true.
+ kpblx (i) = 1
+ kpbly (i) = kpbl (i)
+ if (cnvflg (i)) then
+ flg (i) = .false.
+ rbup (i) = wu2 (i, 1)
+ endif
+ enddo
+ do k = 2, kmpbl
+ do i = 1, im
+ if (.not.flg (i)) then
+ rbdn (i) = rbup (i)
+ rbup (i) = wu2 (i, k)
+ kpblx (i) = k
+ flg (i) = rbup (i) .le.0.
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = kpblx (i)
+ if (rbdn (i) <= 0.) then
+ rbint = 0.
+ elseif (rbup (i) >= 0.) then
+ rbint = 1.
+ else
+ rbint = rbdn (i) / (rbdn (i) - rbup (i))
+ endif
+ hpblx (i) = zm (i, k - 1) + rbint * (zm (i, k) - zm (i, k - 1))
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (kpblx (i) < kpbl (i)) then
+ kpbl (i) = kpblx (i)
+ hpbl (i) = hpblx (i)
+ endif
+ if (kpbl (i) <= 1) cnvflg (i) = .false.
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! update entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. kpblx (i) < kpbly (i)) then
+ ! if (cnvflg (i)) then
+ if (k < kpbl (i)) then
+ ptem = 1. / (zm (i, k) + delz (i))
+ tem = max ((hpbl (i) - zm (i, k) + delz (i)), delz (i))
+ ptem1 = 1. / tem
+ ! kgao 12 / 08 / 2023
+ if (use_tke_pbl) then
+ xlamue (i, k) = ce0t (i) * (ptem + ptem1)
+ else
+ xlamue (i, k) = ce0 * (ptem + ptem1)
+ endif
+ else
+ xlamue (i, k) = xlamax (i)
+ endif
+
+ xlamuem (i, k) = cm * xlamue (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate averaged over the whole pbl
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ xlamavg (i) = 0.
+ sumx (i) = 0.
+ enddo
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k < kpbl (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ xlamavg (i) = xlamavg (i) + xlamue (i, k) * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamavg (i) = xlamavg (i) / sumx (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! updraft mass flux as a function of updraft velocity profile
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k < kpbl (i)) then
+ xmf (i, k) = a1 * sqrt (wu2 (i, k))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft fraction as a function of mean entrainment rate
+ ! (grell & freitas, 2014)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = 0.2 / xlamavg (i)
+ tem1 = 3.14 * tem * tem
+ sigma (i) = tem1 / (gdx (i) * gdx (i))
+ sigma (i) = max (sigma (i), 0.001)
+ sigma (i) = min (sigma (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute scale - aware function based on arakawa & wu (2013)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sigma (i) > a1) then
+ scaldfunc (i) = (1. - sigma (i)) * (1. - sigma (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final scale - aware updraft mass flux
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k < kpbl (i)) then
+ xmf (i, k) = scaldfunc (i) * xmf (i, k)
+ dz = zl (i, k + 1) - zl (i, k)
+ xmmx = dz / dt2
+ xmf (i, k) = min (xmf (i, k), xmmx)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute updraft property using updated entranment rate
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ thlu (i, 1) = thlx (i, 1)
+ endif
+ enddo
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! ptem1 = max (qcko (i, 1, ntcw), 0.)
+ ! tlu = thlu (i, 1) / pix (i, 1)
+ ! tcko (i, 1) = tlu + elocp * ptem1
+ ! endif
+ ! enddo
+
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ thlu (i, k) = ((1. - tem) * thlu (i, k - 1) + tem * &
+ (thlx (i, k - 1) + thlx (i, k))) / factor
+ qtu (i, k) = ((1. - tem) * qtu (i, k - 1) + tem * &
+ (qtx (i, k - 1) + qtx (i, k))) / factor
+
+ tlu = thlu (i, k) / pix (i, k)
+ es = 0.01 * mqs (tlu) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtu (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tlu ** 2)
+ qlu = dq / (1. + gamma)
+ qtu (i, k) = qs + qlu
+ qcko (i, k, 1) = qs
+ qcko (i, k, ntcw) = qlu
+ tcko (i, k) = tlu + elocp * qlu
+ else
+ qcko (i, k, 1) = qtu (i, k)
+ qcko (i, k, ntcw) = 0.
+ tcko (i, k) = tlu
+ endif
+
+ endif
+ enddo
+ enddo
+
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamuem (i, k - 1) * dz
+ factor = 1. + tem
+ ptem = tem + pgcon
+ ptem1 = tem - pgcon
+ ucko (i, k) = ((1. - tem) * ucko (i, k - 1) + ptem * u1 (i, k) + &
+ ptem1 * u1 (i, k - 1)) / factor
+ vcko (i, k) = ((1. - tem) * vcko (i, k - 1) + ptem * v1 (i, k) + &
+ ptem1 * v1 (i, k - 1)) / factor
+ endif
+ enddo
+ enddo
+
+ if (ntcw > 2) then
+
+ do n = 2, ntcw - 1
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ qcko (i, k, n) = ((1. - tem) * qcko (i, k - 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k - 1, n))) / factor
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ndc = ntrac1 - ntcw
+
+ if (ndc > 0) then
+
+ do n = ntcw + 1, ntrac1
+ do k = 2, kmpbl
+ do i = 1, im
+ if (cnvflg (i) .and. k <= kpbl (i)) then
+ dz = zl (i, k) - zl (i, k - 1)
+ tem = 0.5 * xlamue (i, k - 1) * dz
+ factor = 1. + tem
+
+ qcko (i, k, n) = ((1. - tem) * qcko (i, k - 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k - 1, n))) / factor
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ return
+
+end subroutine mfpbltq
+
+! =======================================================================
+! mass - flux parameterization for stratocumulus - top - induced turbulence mixing
+! =======================================================================
+
+subroutine mfscuq (im, km, kmscu, ntcw, ntrac1, delt, &
+ cnvflg, zl, zm, q1, t1, u1, v1, plyr, pix, &
+ thlx, thvx, thlvx, gdx, thetae, &
+ krad, mrad, radmin, buo, &
+ use_shear_pbl, wush, &
+ use_tke_pbl, tkemean, vez0fun, xmfd, &
+ tcdo, qcdo, ucdo, vcdo, xlamde, a1)
+
+ implicit none
+
+ integer, intent (in) :: im, km, kmscu, ntcw, ntrac1
+ integer :: krad (im), mrad (im)
+
+ logical :: cnvflg (im)
+
+ real :: delt
+ real :: q1 (im, km, ntrac1), t1 (im, km), &
+ u1 (im, km), v1 (im, km), &
+ plyr (im, km), pix (im, km), &
+ thlx (im, km), wush (im, km), &
+ thvx (im, km), thlvx (im, km), &
+ gdx (im), &
+ zl (im, km), zm (im, km), &
+ thetae (im, km), radmin (im), &
+ tkemean (im), vez0fun (im), &
+ buo (im, km), xmfd (im, km), &
+ tcdo (im, km), qcdo (im, km, ntrac1), &
+ ucdo (im, km), vcdo (im, km), &
+ xlamde (im, km - 1)
+ logical use_tke_pbl, use_shear_pbl
+
+ ! -----------------------------------------------------------------------
+ ! local variables
+ ! -----------------------------------------------------------------------
+
+ integer :: i, j, indx, k, n, kk, ndc
+
+ integer :: krad1 (im)
+
+ real :: dt2, dz, ce0, cm, &
+ gocp, factor, g, tau, &
+ b1, f1, bb1, bb2, &
+ a1, a2, &
+ cteit, pgcon, &
+ qmin, qlmin, &
+ xmmx, tem, tem1, tem2, &
+ ptem, ptem1, ptem2, &
+ tkcrt, cmxfac
+
+ real :: elocp, el2orc, qs, es, &
+ tld, gamma, qld, thdn, &
+ thvd, dq
+
+ real :: wd2 (im, km), thld (im, km), &
+ qtx (im, km), qtd (im, km), &
+ thlvd (im), hrad (im), &
+ xlamdem (im, km - 1), ra1 (im)
+ real :: delz (im), xlamax (im), ce0t (im)
+
+ real :: xlamavg (im), sigma (im), &
+ scaldfunc (im), sumx (im)
+
+ logical totflg, flg (im)
+
+ real :: actei, cldtime
+
+ ! physical parameters
+ parameter (g = grav)
+ parameter (gocp = g / cp_air)
+ parameter (elocp = hlv / cp_air, el2orc = hlv * hlv / (rvgas * cp_air))
+ parameter (ce0 = 0.4, cm = 1.0, pgcon = 0.55)
+ parameter (tkcrt = 2., cmxfac = 5.)
+ parameter (qmin = 1.e-8, qlmin = 1.e-12)
+ parameter (b1 = 0.45, f1 = 0.15)
+ parameter (a2 = 0.5)
+ parameter (cldtime = 500.)
+ parameter (actei = 0.7)
+ ! parameter (actei = 0.23)
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ dt2 = delt
+
+ do k = 1, km
+ do i = 1, im
+ if (cnvflg (i)) then
+ buo (i, k) = 0.
+ wd2 (i, k) = 0.
+ qtx (i, k) = q1 (i, k, 1) + q1 (i, k, ntcw)
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ hrad (i) = zm (i, krad (i))
+ krad1 (i) = krad (i) - 1
+ endif
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad (i)
+ tem = zm (i, k + 1) - zm (i, k)
+ tem1 = cldtime * radmin (i) / tem
+ tem1 = max (tem1, - 3.0)
+ thld (i, k) = thlx (i, k) + tem1
+ qtd (i, k) = qtx (i, k)
+ thlvd (i) = thlvx (i, k) + tem1
+ buo (i, k) = - g * tem1 / thvx (i, k)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! specify downdraft fraction
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ ra1 (i) = a1
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! if the condition for cloud - top instability is met,
+ ! increase downdraft fraction
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad (i)
+ tem = thetae (i, k) - thetae (i, k + 1)
+ tem1 = qtx (i, k) - qtx (i, k + 1)
+ if (tem > 0. .and. tem1 > 0.) then
+ cteit = cp_air * tem / (hlv * tem1)
+ if (cteit > actei) then
+ ra1 (i) = a2
+ endif
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! first - quess level of downdraft extension (mrad)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ mrad (i) = krad (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k < krad (i)) then
+ if (thlvd (i) <= thlvx (i, k)) then
+ mrad (i) = k
+ else
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = krad (i) - mrad (i)
+ if (kk < 1) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+
+ ! -----------------------------------------------------------------------
+ ! kgao 12 / 08 / 2023: compute entrainment / detrainment rate based on pbl - mean tke
+ ! if tkemean > tkcrt, ce0t = sqrt (tkemean / tkcrt) * ce0
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (use_tke_pbl .and. cnvflg (i)) then
+ ce0t (i) = ce0 * vez0fun (i)
+ if (tkemean (i) > tkcrt) then
+ tem = sqrt (tkemean (i) / tkcrt)
+ tem1 = min (tem, cmxfac)
+ tem2 = tem1 * ce0
+ ce0t (i) = max (ce0t (i), tem2)
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = mrad (i) + (krad (i) - mrad (i)) / 2
+ k = max (k, mrad (i))
+ delz (i) = zl (i, k + 1) - zl (i, k)
+ ! kgao 12 / 08 / 2023
+ if (use_tke_pbl) then
+ xlamax (i) = ce0t (i) / delz (i)
+ else
+ xlamax (i) = ce0 / delz (i)
+ endif
+ endif
+ enddo
+
+ do k = 1, kmscu
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ if (mrad (i) == 1) then
+ ptem = 1. / (zm (i, k) + delz (i))
+ else
+ ptem = 1. / (zm (i, k) - zm (i, mrad (i) - 1) + delz (i))
+ endif
+ tem = max ((hrad (i) - zm (i, k) + delz (i)), delz (i))
+ ptem1 = 1. / tem
+ ! kgao 12 / 08 / 2023
+ if (use_tke_pbl) then
+ xlamde (i, k) = ce0t (i) * (ptem + ptem1)
+ else
+ xlamde (i, k) = ce0 * (ptem + ptem1)
+ endif
+ else
+ xlamde (i, k) = xlamax (i)
+ endif
+ xlamdem (i, k) = cm * xlamde (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute buoyancy for downdraft air parcel
+ ! -----------------------------------------------------------------------
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ thld (i, k) = ((1. - tem) * thld (i, k + 1) + tem * &
+ (thlx (i, k) + thlx (i, k + 1))) / factor
+ qtd (i, k) = ((1. - tem) * qtd (i, k + 1) + tem * &
+ (qtx (i, k) + qtx (i, k + 1))) / factor
+
+ tld = thld (i, k) / pix (i, k)
+ es = 0.01 * mqs (tld) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtd (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tld ** 2)
+ qld = dq / (1. + gamma)
+ qtd (i, k) = qs + qld
+ tem1 = 1. + zvir * qs - qld
+ thdn = thld (i, k) + pix (i, k) * elocp * qld
+ thvd = thdn * tem1
+ else
+ tem1 = 1. + zvir * qtd (i, k)
+ thvd = thld (i, k) * tem1
+ endif
+ buo (i, k) = g * (1. - thvd / thvx (i, k))
+
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft velocity square (wd2)
+ ! -----------------------------------------------------------------------
+
+ ! tem = 1. - 2. * f1
+ ! bb1 = 2. * b1 / tem
+ ! bb2 = 2. / tem
+ ! from soares et al. (2004, qjrms)
+ ! bb1 = 2.
+ ! bb2 = 4.
+
+ ! from bretherton et al. (2004, mwr)
+ ! bb1 = 4.
+ ! bb2 = 2.
+
+ ! from our tuning
+ bb1 = 2.0
+ bb2 = 4.0
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad1 (i)
+ dz = zm (i, k + 1) - zm (i, k)
+ ! tem = 0.25 * bb1 * (xlamde (i, k) + xlamde (i, k + 1)) * dz
+ tem = 0.5 * bb1 * xlamde (i, k) * dz
+ tem1 = bb2 * buo (i, k + 1) * dz
+ ptem1 = 1. + tem
+ wd2 (i, k) = tem1 / ptem1
+ endif
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad1 (i)) then
+ dz = zm (i, k + 1) - zm (i, k)
+ tem = 0.25 * bb1 * (xlamde (i, k) + xlamde (i, k + 1)) * dz
+ ! kgao 12 / 15 / 2023 - consider shear effect on wd diagnosis
+ if (use_shear_pbl) then
+ tem1 = max (wd2 (i, k + 1), 0.)
+ tem1 = bb2 * buo (i, k + 1) - wush (i, k + 1) * sqrt (tem1)
+ tem2 = tem1 * dz
+ ptem = (1. - tem) * wd2 (i, k + 1)
+ ptem1 = 1. + tem
+ wd2 (i, k) = (ptem + tem2) / ptem1
+ else
+ tem1 = bb2 * buo (i, k + 1) * dz
+ ptem = (1. - tem) * wd2 (i, k + 1)
+ ptem1 = 1. + tem
+ wd2 (i, k) = (ptem + tem1) / ptem1
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ flg (i) = cnvflg (i)
+ if (flg (i)) mrad (i) = krad (i)
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (flg (i) .and. k < krad (i)) then
+ if (wd2 (i, k) > 0.) then
+ mrad (i) = k
+ else
+ flg (i) = .false.
+ endif
+ endif
+ enddo
+ enddo
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ kk = krad (i) - mrad (i)
+ if (kk < 1) cnvflg (i) = .false.
+ endif
+ enddo
+
+ totflg = .true.
+ do i = 1, im
+ totflg = totflg .and. (.not. cnvflg (i))
+ enddo
+ if (totflg) return
+
+ ! -----------------------------------------------------------------------
+ ! update entrainment rate
+ ! -----------------------------------------------------------------------
+
+ do k = 1, kmscu
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (k >= mrad (i) .and. k < krad (i)) then
+ if (mrad (i) == 1) then
+ ptem = 1. / (zm (i, k) + delz (i))
+ else
+ ptem = 1. / (zm (i, k) - zm (i, mrad (i) - 1) + delz (i))
+ endif
+ tem = max ((hrad (i) - zm (i, k) + delz (i)), delz (i))
+ ptem1 = 1. / tem
+ ! kgao 12 / 08 / 2023
+ if (use_tke_pbl) then
+ xlamde (i, k) = ce0t (i) * (ptem + ptem1)
+ else
+ xlamde (i, k) = ce0 * (ptem + ptem1)
+ endif
+ else
+ xlamde (i, k) = xlamax (i)
+ endif
+ xlamdem (i, k) = cm * xlamde (i, k)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute entrainment rate averaged over the whole downdraft layers
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ xlamavg (i) = 0.
+ sumx (i) = 0.
+ enddo
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. (k >= mrad (i) .and. k < krad (i))) then
+ dz = zl (i, k + 1) - zl (i, k)
+ xlamavg (i) = xlamavg (i) + xlamde (i, k) * dz
+ sumx (i) = sumx (i) + dz
+ endif
+ enddo
+ enddo
+ do i = 1, im
+ if (cnvflg (i)) then
+ xlamavg (i) = xlamavg (i) / sumx (i)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft mass flux
+ ! -----------------------------------------------------------------------
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. &
+ (k >= mrad (i) .and. k < krad (i))) then
+ xmfd (i, k) = ra1 (i) * sqrt (wd2 (i, k))
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft fraction as a function of mean entrainment rate
+ ! (grell & freitas, 2014)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ tem = 0.2 / xlamavg (i)
+ tem1 = 3.14 * tem * tem
+ sigma (i) = tem1 / (gdx (i) * gdx (i))
+ sigma (i) = max (sigma (i), 0.001)
+ sigma (i) = min (sigma (i), 0.999)
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute scale - aware function based on arakawa & wu (2013)
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ if (sigma (i) > ra1 (i)) then
+ scaldfunc (i) = (1. - sigma (i)) * (1. - sigma (i))
+ scaldfunc (i) = max (min (scaldfunc (i), 1.0), 0.)
+ else
+ scaldfunc (i) = 1.0
+ endif
+ endif
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! final scale - aware downdraft mass flux
+ ! -----------------------------------------------------------------------
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. &
+ (k >= mrad (i) .and. k < krad (i))) then
+ xmfd (i, k) = scaldfunc (i) * xmfd (i, k)
+ dz = zl (i, k + 1) - zl (i, k)
+ xmmx = dz / dt2
+ xmfd (i, k) = min (xmfd (i, k), xmmx)
+ endif
+ enddo
+ enddo
+
+ ! -----------------------------------------------------------------------
+ ! compute downdraft property using updated entranment rate
+ ! -----------------------------------------------------------------------
+
+ do i = 1, im
+ if (cnvflg (i)) then
+ k = krad (i)
+ thld (i, k) = thlx (i, k)
+ endif
+ enddo
+
+ ! do i = 1, im
+ ! if (cnvflg (i)) then
+ ! k = krad (i)
+ ! ptem1 = max (qcdo (i, k, ntcw), 0.)
+ ! tld = thld (i, k) / pix (i, k)
+ ! tcdo (i, k) = tld + elocp * ptem1
+ ! qcdo (i, k, 1) = qcdo (i, k, 1) + 0.2 * qcdo (i, k, 1)
+ ! qcdo (i, k, ntcw) = qcdo (i, k, ntcw) + 0.2 * qcdo (i, k, ntcw)
+ ! endif
+ ! enddo
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. &
+ (k >= mrad (i) .and. k < krad (i))) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ thld (i, k) = ((1. - tem) * thld (i, k + 1) + tem * &
+ (thlx (i, k) + thlx (i, k + 1))) / factor
+ qtd (i, k) = ((1. - tem) * qtd (i, k + 1) + tem * &
+ (qtx (i, k) + qtx (i, k + 1))) / factor
+
+ tld = thld (i, k) / pix (i, k)
+ es = 0.01 * mqs (tld) ! mqs in pa
+ qs = max (qmin, eps * es / (plyr (i, k) + epsm1 * es))
+ dq = qtd (i, k) - qs
+
+ if (dq > 0.) then
+ gamma = el2orc * qs / (tld ** 2)
+ qld = dq / (1. + gamma)
+ qtd (i, k) = qs + qld
+ qcdo (i, k, 1) = qs
+ qcdo (i, k, ntcw) = qld
+ tcdo (i, k) = tld + elocp * qld
+ else
+ qcdo (i, k, 1) = qtd (i, k)
+ qcdo (i, k, ntcw) = 0.
+ tcdo (i, k) = tld
+ endif
+ endif
+ enddo
+ enddo
+
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamdem (i, k) * dz
+ factor = 1. + tem
+ ptem = tem - pgcon
+ ptem1 = tem + pgcon
+
+ ucdo (i, k) = ((1. - tem) * ucdo (i, k + 1) + ptem * u1 (i, k + 1) + &
+ ptem1 * u1 (i, k)) / factor
+ vcdo (i, k) = ((1. - tem) * vcdo (i, k + 1) + ptem * v1 (i, k + 1) + &
+ ptem1 * v1 (i, k)) / factor
+ endif
+ endif
+ enddo
+ enddo
+
+ if (ntcw > 2) then
+
+ do n = 2, ntcw - 1
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ qcdo (i, k, n) = ((1. - tem) * qcdo (i, k + 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k + 1, n))) / factor
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ndc = ntrac1 - ntcw
+
+ if (ndc > 0) then
+
+ do n = ntcw + 1, ntrac1
+ do k = kmscu, 1, - 1
+ do i = 1, im
+ if (cnvflg (i) .and. k < krad (i)) then
+ if (k >= mrad (i)) then
+ dz = zl (i, k + 1) - zl (i, k)
+ tem = 0.5 * xlamde (i, k) * dz
+ factor = 1. + tem
+
+ qcdo (i, k, n) = ((1. - tem) * qcdo (i, k + 1, n) + tem * &
+ (q1 (i, k, n) + q1 (i, k + 1, n))) / factor
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ return
+
+end subroutine mfscuq
+
+! =======================================================================
+! routine to solve the tridiagonal system to calculate temperature and
+! moisture at \f$ t + \delta t \f$; part of two - part process to
+! calculate time tendencies due to vertical diffusion.
+! =======================================================================
+
+subroutine tridi2 (l, n, cl, cm, cu, r1, r2, au, a1, a2)
+
+ implicit none
+
+ integer :: k, n, l, i
+
+ real :: fk
+
+ real :: cl (l, 2:n), cm (l, n), cu (l, n - 1), r1 (l, n), r2 (l, n), &
+ au (l, n - 1), a1 (l, n), a2 (l, n)
+
+ do i = 1, l
+ fk = 1. / cm (i, 1)
+ au (i, 1) = fk * cu (i, 1)
+ a1 (i, 1) = fk * r1 (i, 1)
+ a2 (i, 1) = fk * r2 (i, 1)
+ enddo
+ do k = 2, n - 1
+ do i = 1, l
+ fk = 1. / (cm (i, k) - cl (i, k) * au (i, k - 1))
+ au (i, k) = fk * cu (i, k)
+ a1 (i, k) = fk * (r1 (i, k) - cl (i, k) * a1 (i, k - 1))
+ a2 (i, k) = fk * (r2 (i, k) - cl (i, k) * a2 (i, k - 1))
+ enddo
+ enddo
+ do i = 1, l
+ fk = 1. / (cm (i, n) - cl (i, n) * au (i, n - 1))
+ a1 (i, n) = fk * (r1 (i, n) - cl (i, n) * a1 (i, n - 1))
+ a2 (i, n) = fk * (r2 (i, n) - cl (i, n) * a2 (i, n - 1))
+ enddo
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ a1 (i, k) = a1 (i, k) - au (i, k) * a1 (i, k + 1)
+ a2 (i, k) = a2 (i, k) - au (i, k) * a2 (i, k + 1)
+ enddo
+ enddo
+
+end subroutine tridi2
+
+! =======================================================================
+! routine to solve the tridiagonal system to calculate u - and v -
+! momentum at \f$ t + \delta t \f$; part of two - part process to
+! calculate time tendencies due to vertical diffusion.
+! =======================================================================
+
+subroutine tridin (l, n, nt, cl, cm, cu, r1, r2, au, a1, a2)
+
+ implicit none
+
+ integer :: is, k, kk, n, nt, l, i
+
+ real :: fk (l)
+
+ real :: cl (l, 2:n), cm (l, n), cu (l, n - 1), &
+ r1 (l, n), r2 (l, n * nt), &
+ au (l, n - 1), a1 (l, n), a2 (l, n * nt), &
+ fkk (l, 2:n - 1)
+
+ do i = 1, l
+ fk (i) = 1. / cm (i, 1)
+ au (i, 1) = fk (i) * cu (i, 1)
+ a1 (i, 1) = fk (i) * r1 (i, 1)
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ a2 (i, 1 + is) = fk (i) * r2 (i, 1 + is)
+ enddo
+ enddo
+ do k = 2, n - 1
+ do i = 1, l
+ fkk (i, k) = 1. / (cm (i, k) - cl (i, k) * au (i, k - 1))
+ au (i, k) = fkk (i, k) * cu (i, k)
+ a1 (i, k) = fkk (i, k) * (r1 (i, k) - cl (i, k) * a1 (i, k - 1))
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = 2, n - 1
+ do i = 1, l
+ a2 (i, k + is) = fkk (i, k) * (r2 (i, k + is) - cl (i, k) * a2 (i, k + is - 1))
+ enddo
+ enddo
+ enddo
+ do i = 1, l
+ fk (i) = 1. / (cm (i, n) - cl (i, n) * au (i, n - 1))
+ a1 (i, n) = fk (i) * (r1 (i, n) - cl (i, n) * a1 (i, n - 1))
+ enddo
+ do k = 1, nt
+ is = (k - 1) * n
+ do i = 1, l
+ a2 (i, n + is) = fk (i) * (r2 (i, n + is) - cl (i, n) * a2 (i, n + is - 1))
+ enddo
+ enddo
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ a1 (i, k) = a1 (i, k) - au (i, k) * a1 (i, k + 1)
+ enddo
+ enddo
+ do kk = 1, nt
+ is = (kk - 1) * n
+ do k = n - 1, 1, - 1
+ do i = 1, l
+ a2 (i, k + is) = a2 (i, k + is) - au (i, k) * a2 (i, k + is + 1)
+ enddo
+ enddo
+ enddo
+
+end subroutine tridin
+
+end module sa_tke_edmf_new_mod
diff --git a/tools/external_ic.F90 b/tools/external_ic.F90
index eb95a201f..c1097c8bb 100644
--- a/tools/external_ic.F90
+++ b/tools/external_ic.F90
@@ -441,12 +441,49 @@ subroutine get_nggps_ic (Atm)
call register_axis(SFC_restart, dim_names_alloc(2), "y")
call register_axis(SFC_restart, dim_names_alloc(1), "x")
call register_restart_field(SFC_restart, 'tsea', Atm%ts, dim_names_alloc)
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ call register_restart_field(SFC_restart, 'slmsk', Atm%inline_pbl%lsm, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'zorl', Atm%inline_pbl%zorl, dim_names_alloc)
+ !call register_restart_field(SFC_restart, 'ztrl', Atm%inline_pbl%ztrl, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'ffmm', Atm%inline_pbl%ffmm, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'ffhh', Atm%inline_pbl%ffhh, dim_names_alloc)
+ Atm%inline_pbl%tsfc = Atm%ts
+ call register_restart_field(SFC_restart, 'shdmax', Atm%inline_pbl%shdmax, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'vtype', Atm%inline_pbl%vtype, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'vfrac', Atm%inline_pbl%vfrac, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'snwdph', Atm%inline_pbl%snowd, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'uustar', Atm%inline_pbl%uustar, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'srflag', Atm%inline_pbl%srflag, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'hice', Atm%inline_pbl%hice, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'fice', Atm%inline_pbl%fice, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'tisfc', Atm%inline_pbl%tice, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'sheleg', Atm%inline_pbl%weasd, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'tprcp', Atm%inline_pbl%tprcp, dim_names_alloc)
+ endif
call read_restart(SFC_restart)
call close_file(SFC_restart)
deallocate (dim_names_alloc)
else
call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_sfc_ics)//' for NGGPS IC does not exist')
endif
+
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ if( open_file(SFC_restart, fn_sfc_ics, "read", Atm%domain_for_read, is_restart=.true., dont_add_res_to_filename=.true.) ) then
+ naxis_dims = get_variable_num_dimensions(SFC_restart, 'stc')
+ allocate (dim_names_alloc(naxis_dims))
+ call get_variable_dimension_names(SFC_restart, 'stc', dim_names_alloc)
+ call register_axis(SFC_restart, dim_names_alloc(3), size(Atm%inline_pbl%stc,3))
+ call register_axis(SFC_restart, dim_names_alloc(2), "y")
+ call register_axis(SFC_restart, dim_names_alloc(1), "x")
+ call register_restart_field(SFC_restart, 'stc', Atm%inline_pbl%stc, dim_names_alloc)
+ call read_restart(SFC_restart)
+ call close_file(SFC_restart)
+ deallocate (dim_names_alloc)
+ else
+ call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_sfc_ics)//' for NGGPS IC does not exist')
+ endif
+ endif
+
call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_sfc_ics)//' for NGGPS IC')
! set dimensions for register restart
@@ -474,6 +511,23 @@ subroutine get_nggps_ic (Atm)
endif
endif
+ if ( Atm%flagstruct%do_inline_gwd ) then
+ call register_restart_field(ORO_restart, 'stddev', Atm%inline_gwd%hprime, dim_names_2d)
+ call register_restart_field(ORO_restart, 'convexity', Atm%inline_gwd%oc, dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa1', Atm%inline_gwd%oa(:,:,1), dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa2', Atm%inline_gwd%oa(:,:,2), dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa3', Atm%inline_gwd%oa(:,:,3), dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa4', Atm%inline_gwd%oa(:,:,4), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol1', Atm%inline_gwd%ol(:,:,1), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol2', Atm%inline_gwd%ol(:,:,2), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol3', Atm%inline_gwd%ol(:,:,3), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol4', Atm%inline_gwd%ol(:,:,4), dim_names_2d)
+ call register_restart_field(ORO_restart, 'theta', Atm%inline_gwd%theta, dim_names_2d)
+ call register_restart_field(ORO_restart, 'sigma', Atm%inline_gwd%sigma, dim_names_2d)
+ call register_restart_field(ORO_restart, 'gamma', Atm%inline_gwd%gamma, dim_names_2d)
+ call register_restart_field(ORO_restart, 'elvmax', Atm%inline_gwd%elvmax, dim_names_2d)
+ endif
+
if ( Atm%flagstruct%fv_land ) then
! stddev
call register_restart_field(ORO_restart, 'stddev', Atm%sgh, dim_names_2d)
@@ -1760,6 +1814,7 @@ subroutine get_ecmwf_ic( Atm )
0.97771, 0.98608, 0.99347, 1./
character(len=128) :: fname
+ character(len=8), allocatable :: dim_names_alloc(:)
character(len=8), dimension(2) :: dim_names_2d
character(len=8), dimension(3) :: dim_names_3d3, dim_names_3d4
real, allocatable:: wk2(:,:)
@@ -1797,14 +1852,15 @@ subroutine get_ecmwf_ic( Atm )
real(kind=R_GRID), dimension(3):: e1, e2, ex, ey
real, allocatable:: ps_gfs(:,:), zh_gfs(:,:,:), o3mr_gfs(:,:,:)
real, allocatable:: ak_gfs(:), bk_gfs(:)
- integer :: id_res, ntprog, ntracers, ks, iq, nt, levsp
+ integer :: id_res, ntprog, ntracers, ks, iq, nt, levsp, naxis_dims
character(len=64) :: tracer_name
integer :: levp_gfs = 64
- type(FmsNetcdfDomainFile_t) :: ORO_restart, GFS_restart
+ type(FmsNetcdfDomainFile_t) :: ORO_restart, GFS_restart, SFC_restart
type(FmsNetcdfFile_t) :: Gfs_ctl
integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist
character(len=64) :: fn_oro_ics = 'INPUT/oro_data.nc'
character(len=64) :: fn_gfs_ics = 'INPUT/gfs_data.nc'
+ character(len=64) :: fn_sfc_ics = 'INPUT/sfc_data.nc'
character(len=64) :: fn_gfs_ctl = 'INPUT/gfs_ctrl.nc'
character(len=20) :: suffix
character(len=1) :: tile_num
@@ -1877,6 +1933,57 @@ subroutine get_ecmwf_ic( Atm )
dim_names_3d4 = dim_names_3d3
dim_names_3d4(1) = "levp"
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ if( open_file(SFC_restart, fn_sfc_ics, "read", Atm%domain_for_read, is_restart=.true., dont_add_res_to_filename=.true.) ) then
+ naxis_dims = get_variable_num_dimensions(SFC_restart, 'slmsk')
+ allocate (dim_names_alloc(naxis_dims))
+ call get_variable_dimension_names(SFC_restart, 'slmsk', dim_names_alloc)
+ call register_axis(SFC_restart, dim_names_alloc(2), "y")
+ call register_axis(SFC_restart, dim_names_alloc(1), "x")
+ call register_restart_field(SFC_restart, 'slmsk', Atm%inline_pbl%lsm, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'zorl', Atm%inline_pbl%zorl, dim_names_alloc)
+ !call register_restart_field(SFC_restart, 'ztrl', Atm%inline_pbl%ztrl, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'ffmm', Atm%inline_pbl%ffmm, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'ffhh', Atm%inline_pbl%ffhh, dim_names_alloc)
+ Atm%inline_pbl%tsfc = Atm%ts
+ call register_restart_field(SFC_restart, 'shdmax', Atm%inline_pbl%shdmax, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'vtype', Atm%inline_pbl%vtype, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'vfrac', Atm%inline_pbl%vfrac, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'snwdph', Atm%inline_pbl%snowd, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'uustar', Atm%inline_pbl%uustar, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'srflag', Atm%inline_pbl%srflag, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'hice', Atm%inline_pbl%hice, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'fice', Atm%inline_pbl%fice, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'tisfc', Atm%inline_pbl%tice, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'sheleg', Atm%inline_pbl%weasd, dim_names_alloc)
+ call register_restart_field(SFC_restart, 'tprcp', Atm%inline_pbl%tprcp, dim_names_alloc)
+ call read_restart(SFC_restart)
+ call close_file(SFC_restart)
+ deallocate (dim_names_alloc)
+ else
+ call mpp_error(FATAL,'==> Error in External_ic::get_ecmwf_ic: tiled file '//trim(fn_sfc_ics)//' for ECMWF IC does not exist')
+ endif
+ endif
+
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ if( open_file(SFC_restart, fn_sfc_ics, "read", Atm%domain_for_read, is_restart=.true., dont_add_res_to_filename=.true.) ) then
+ naxis_dims = get_variable_num_dimensions(SFC_restart, 'stc')
+ allocate (dim_names_alloc(naxis_dims))
+ call get_variable_dimension_names(SFC_restart, 'stc', dim_names_alloc)
+ call register_axis(SFC_restart, dim_names_alloc(3), size(Atm%inline_pbl%stc,3))
+ call register_axis(SFC_restart, dim_names_alloc(2), "y")
+ call register_axis(SFC_restart, dim_names_alloc(1), "x")
+ call register_restart_field(SFC_restart, 'stc', Atm%inline_pbl%stc, dim_names_alloc)
+ call read_restart(SFC_restart)
+ call close_file(SFC_restart)
+ deallocate (dim_names_alloc)
+ else
+ call mpp_error(FATAL,'==> Error in External_ic::get_ecmwf_ic: tiled file '//trim(fn_sfc_ics)//' for ECMWF IC does not exist')
+ endif
+ endif
+
+ call mpp_error(NOTE,'==> External_ic::get_ecmwf_ic: using tiled data file '//trim(fn_sfc_ics)//' for ECMWF IC')
+
!! Read in model terrain from oro_data.tile?.nc
if( open_file(ORO_restart, fn_oro_ics, "read", Atm%domain_for_read, is_restart=.true., dont_add_res_to_filename=.true.) ) then
call register_axis(ORO_restart, "lat", "y")
@@ -1886,9 +1993,30 @@ subroutine get_ecmwf_ic( Atm )
elseif (.not. filtered_terrain) then
call register_restart_field(ORO_restart, 'orog_raw', Atm%phis, dim_names_2d)
endif
+ if ( Atm%flagstruct%do_inline_gwd ) then
+ call register_restart_field(ORO_restart, 'stddev', Atm%inline_gwd%hprime, dim_names_2d)
+ call register_restart_field(ORO_restart, 'convexity', Atm%inline_gwd%oc, dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa1', Atm%inline_gwd%oa(:,:,1), dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa2', Atm%inline_gwd%oa(:,:,2), dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa3', Atm%inline_gwd%oa(:,:,3), dim_names_2d)
+ call register_restart_field(ORO_restart, 'oa4', Atm%inline_gwd%oa(:,:,4), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol1', Atm%inline_gwd%ol(:,:,1), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol2', Atm%inline_gwd%ol(:,:,2), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol3', Atm%inline_gwd%ol(:,:,3), dim_names_2d)
+ call register_restart_field(ORO_restart, 'ol4', Atm%inline_gwd%ol(:,:,4), dim_names_2d)
+ call register_restart_field(ORO_restart, 'theta', Atm%inline_gwd%theta, dim_names_2d)
+ call register_restart_field(ORO_restart, 'sigma', Atm%inline_gwd%sigma, dim_names_2d)
+ call register_restart_field(ORO_restart, 'gamma', Atm%inline_gwd%gamma, dim_names_2d)
+ call register_restart_field(ORO_restart, 'elvmax', Atm%inline_gwd%elvmax, dim_names_2d)
+ endif
call read_restart(ORO_restart)
call close_file(ORO_restart)
+ else
+ call mpp_error(FATAL,'==> Error in External_ic::get_ecmwf_ic: tiled file '//trim(fn_oro_ics)//' for ECMWF IC does not exist')
endif
+
+ call mpp_error(NOTE,'==> External_ic::get_ecmwf_ic: using tiled data file '//trim(fn_oro_ics)//' for ECMWF IC')
+
Atm%phis = Atm%phis*grav
if(is_master()) write(*,*) 'done reading model terrain from oro_data.nc'
call mpp_update_domains( Atm%phis, Atm%domain )
@@ -1912,8 +2040,12 @@ subroutine get_ecmwf_ic( Atm )
call register_restart_field(GFS_restart, 'zh', zh_gfs, dim_names_3d4)
call read_restart(GFS_restart)
call close_file(GFS_restart)
+ else
+ call mpp_error(FATAL,'==> Error in External_ic::get_ecmwf_ic: file '//trim(fn_gfs_ctl)//' for ECMWF IC does not exist')
endif
+ call mpp_error(NOTE,'==> External_ic::get_ecmwf_ic: using tiled data file '//trim(fn_gfs_ctl)//' for ECMWF IC')
+
! Get GFS ak, bk for o3mr vertical interpolation
allocate (wk2(levp_gfs+1,2))
allocate (ak_gfs(levp_gfs+1))
diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90
index 8a2446d5a..718c15cdb 100644
--- a/tools/fv_diagnostics.F90
+++ b/tools/fv_diagnostics.F90
@@ -640,6 +640,8 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
!-------------------
id_pret = register_diag_field ( trim(field), 'pret', axes(1:2), Time, &
'total precipitation', 'mm/day', missing_value=missing_value )
+ id_prec = register_diag_field ( trim(field), 'prec', axes(1:2), Time, &
+ 'convective 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, &
@@ -1496,6 +1498,71 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
npx, npy, isc, iec, jsc, jec, Atm(n)%ng)
endif
+ if (Atm(1)%flagstruct%do_inline_mp) then
+ idiag%id_inline_mp_fast_te_a_chg = register_diag_field (trim(field), 'inline_mp_fast_te_a_chg', axes(1:2), Time, &
+ 'Inline MP Fast Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_fast_te_b_chg = register_diag_field (trim(field), 'inline_mp_fast_te_b_chg', axes(1:2), Time, &
+ 'Inline MP Fast Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_fast_tw_a_chg = register_diag_field (trim(field), 'inline_mp_fast_tw_a_chg', axes(1:2), Time, &
+ 'Inline MP Fast Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_fast_tw_b_chg = register_diag_field (trim(field), 'inline_mp_fast_tw_b_chg', axes(1:2), Time, &
+ 'Inline MP Fast Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_intm_te_a_chg = register_diag_field (trim(field), 'inline_mp_intm_te_a_chg', axes(1:2), Time, &
+ 'Inline MP Intermediate Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_intm_te_b_chg = register_diag_field (trim(field), 'inline_mp_intm_te_b_chg', axes(1:2), Time, &
+ 'Inline MP Intermediate Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_intm_tw_a_chg = register_diag_field (trim(field), 'inline_mp_intm_tw_a_chg', axes(1:2), Time, &
+ 'Inline MP Intermediate Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_mp_intm_tw_b_chg = register_diag_field (trim(field), 'inline_mp_intm_tw_b_chg', axes(1:2), Time, &
+ 'Inline MP Intermediate Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ endif
+ if (Atm(1)%flagstruct%do_inline_pbl) then
+ idiag%id_inline_pbl_fast_te_a_chg = register_diag_field (trim(field), 'inline_pbl_fast_te_a_chg', axes(1:2), Time, &
+ 'Inline PBL Fast Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_fast_te_b_chg = register_diag_field (trim(field), 'inline_pbl_fast_te_b_chg', axes(1:2), Time, &
+ 'Inline PBL Fast Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_fast_tw_a_chg = register_diag_field (trim(field), 'inline_pbl_fast_tw_a_chg', axes(1:2), Time, &
+ 'Inline PBL Fast Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_fast_tw_b_chg = register_diag_field (trim(field), 'inline_pbl_fast_tw_b_chg', axes(1:2), Time, &
+ 'Inline PBL Fast Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_intm_te_a_chg = register_diag_field (trim(field), 'inline_pbl_intm_te_a_chg', axes(1:2), Time, &
+ 'Inline PBL Intermediate Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_intm_te_b_chg = register_diag_field (trim(field), 'inline_pbl_intm_te_b_chg', axes(1:2), Time, &
+ 'Inline PBL Intermediate Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_intm_tw_a_chg = register_diag_field (trim(field), 'inline_pbl_intm_tw_a_chg', axes(1:2), Time, &
+ 'Inline PBL Intermediate Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_pbl_intm_tw_b_chg = register_diag_field (trim(field), 'inline_pbl_intm_tw_b_chg', axes(1:2), Time, &
+ 'Inline PBL Intermediate Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ endif
+ if (Atm(1)%flagstruct%do_inline_cnv) then
+ idiag%id_inline_cnv_intm_te_a_chg = register_diag_field (trim(field), 'inline_cnv_intm_te_a_chg', axes(1:2), Time, &
+ 'Inline CNV Intermediate Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_cnv_intm_te_b_chg = register_diag_field (trim(field), 'inline_cnv_intm_te_b_chg', axes(1:2), Time, &
+ 'Inline CNV Intermediate Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_cnv_intm_tw_a_chg = register_diag_field (trim(field), 'inline_cnv_intm_tw_a_chg', axes(1:2), Time, &
+ 'Inline CNV Intermediate Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_cnv_intm_tw_b_chg = register_diag_field (trim(field), 'inline_cnv_intm_tw_b_chg', axes(1:2), Time, &
+ 'Inline CNV Intermediate Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ endif
+ if (Atm(1)%flagstruct%do_inline_gwd) then
+ idiag%id_inline_gwd_fast_te_a_chg = register_diag_field (trim(field), 'inline_gwd_fast_te_a_chg', axes(1:2), Time, &
+ 'Inline GWD Fast Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_fast_te_b_chg = register_diag_field (trim(field), 'inline_gwd_fast_te_b_chg', axes(1:2), Time, &
+ 'Inline GWD Fast Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_fast_tw_a_chg = register_diag_field (trim(field), 'inline_gwd_fast_tw_a_chg', axes(1:2), Time, &
+ 'Inline GWD Fast Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_fast_tw_b_chg = register_diag_field (trim(field), 'inline_gwd_fast_tw_b_chg', axes(1:2), Time, &
+ 'Inline GWD Fast Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_intm_te_a_chg = register_diag_field (trim(field), 'inline_gwd_intm_te_a_chg', axes(1:2), Time, &
+ 'Inline GWD Intermediate Total Energy Change in the Atmosphere', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_intm_te_b_chg = register_diag_field (trim(field), 'inline_gwd_intm_te_b_chg', axes(1:2), Time, &
+ 'Inline GWD Intermediate Total Energy Change at the Boundary', 'J/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_intm_tw_a_chg = register_diag_field (trim(field), 'inline_gwd_intm_tw_a_chg', axes(1:2), Time, &
+ 'Inline GWD Intermediate Total Mass Change in the Atmosphere', 'kg/m^2', missing_value=missing_value )
+ idiag%id_inline_gwd_intm_tw_b_chg = register_diag_field (trim(field), 'inline_gwd_intm_tw_b_chg', axes(1:2), Time, &
+ 'Inline GWD Intermediate Total Mass Change at the Boundary', 'kg/m^2', missing_value=missing_value )
+ endif
+
! end do
@@ -1845,11 +1912,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
if (Atm(n)%flagstruct%do_inline_mp) then
if(id_pret > 0) used=send_data(id_pret, &
+ Atm(n)%inline_cnv%prec(isc:iec,jsc:jec)+&
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_prec > 0) used=send_data(id_prec, Atm(n)%inline_cnv%prec(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)
diff --git a/tools/fv_diagnostics.h b/tools/fv_diagnostics.h
index 1191858f8..109951478 100644
--- a/tools/fv_diagnostics.h
+++ b/tools/fv_diagnostics.h
@@ -77,7 +77,7 @@
logical, allocatable :: conv_vmr_mmr(:)
! Microphysical diagnostics
- integer :: id_pret, id_prew, id_prer, id_prei, id_pres, id_preg
+ integer :: id_pret, id_prec, id_prew, id_prer, id_prei, id_pres, id_preg
integer :: id_prefluxw, id_prefluxr, id_prefluxi, id_prefluxs, id_prefluxg
integer :: id_qv_dt_gfdlmp, id_T_dt_gfdlmp, id_ql_dt_gfdlmp, id_qi_dt_gfdlmp
integer :: id_qr_dt_gfdlmp, id_qg_dt_gfdlmp, id_qs_dt_gfdlmp
@@ -95,7 +95,6 @@
integer :: id_mppms, id_mppmg, id_mppar, id_mppas, id_mppag
integer :: id_mpprs, id_mpprg, id_mppxr, id_mppxs, id_mppxg
integer :: id_mppm1, id_mppm2, id_mppm3
-
integer :: id_qcw, id_qcr, id_qci, id_qcs, id_qcg
integer :: id_rew, id_rer, id_rei, id_res, id_reg, id_cld
diff --git a/tools/fv_io.F90 b/tools/fv_io.F90
index 356418c36..f5325d231 100644
--- a/tools/fv_io.F90
+++ b/tools/fv_io.F90
@@ -438,6 +438,173 @@ subroutine fv_io_register_restart(Atm)
call register_variable_attribute(Atm%Tra_restart, tracer_name, "units", "none", str_len=len("none"))
endif
enddo
+
+ ! fname = 'oro_data.res'//trim(stile_name)//'.nc'
+ elseif (Atm%Oro_restart_is_open) then
+ if ( Atm%flagstruct%do_inline_gwd ) then
+ call fv_io_register_axis(Atm%Oro_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos)
+ call register_restart_field (Atm%Oro_restart, 'stddev', Atm%inline_gwd%hprime, dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'convexity', Atm%inline_gwd%oc, dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'oa1', Atm%inline_gwd%oa(:,:,1), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'oa2', Atm%inline_gwd%oa(:,:,2), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'oa3', Atm%inline_gwd%oa(:,:,3), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'oa4', Atm%inline_gwd%oa(:,:,4), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'ol1', Atm%inline_gwd%ol(:,:,1), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'ol2', Atm%inline_gwd%ol(:,:,2), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'ol3', Atm%inline_gwd%ol(:,:,3), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'ol4', Atm%inline_gwd%ol(:,:,4), dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'theta', Atm%inline_gwd%theta, dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'sigma', Atm%inline_gwd%sigma, dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'gamma', Atm%inline_gwd%gamma, dim_names_3d2)
+ call register_restart_field (Atm%Oro_restart, 'elvmax', Atm%inline_gwd%elvmax, dim_names_3d2)
+ if (.not. Atm%Oro_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Oro_restart, 'stddev', "long_name", "stddev", str_len=len("stddev"))
+ call register_variable_attribute(Atm%Oro_restart, 'stddev', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'convexity', "long_name", "convexity", str_len=len("convexity"))
+ call register_variable_attribute(Atm%Oro_restart, 'convexity', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa1', "long_name", "oa1", str_len=len("oa1"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa1', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa2', "long_name", "oa2", str_len=len("oa2"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa2', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa3', "long_name", "oa3", str_len=len("oa3"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa3', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa4', "long_name", "oa4", str_len=len("oa4"))
+ call register_variable_attribute(Atm%Oro_restart, 'oa4', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol1', "long_name", "ol1", str_len=len("ol1"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol1', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol2', "long_name", "ol2", str_len=len("ol2"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol2', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol3', "long_name", "ol3", str_len=len("ol3"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol3', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol4', "long_name", "ol4", str_len=len("ol4"))
+ call register_variable_attribute(Atm%Oro_restart, 'ol4', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'theta', "long_name", "theta", str_len=len("theta"))
+ call register_variable_attribute(Atm%Oro_restart, 'theta', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'sigma', "long_name", "sigma", str_len=len("sigma"))
+ call register_variable_attribute(Atm%Oro_restart, 'sigma', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'gamma', "long_name", "gamma", str_len=len("gamma"))
+ call register_variable_attribute(Atm%Oro_restart, 'gamma', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Oro_restart, 'elvmax', "long_name", "elvmax", str_len=len("elvmax"))
+ call register_variable_attribute(Atm%Oro_restart, 'elvmax', "units", "none", str_len=len("none"))
+ endif
+ endif
+
+ ! fname = 'phy_data.res'//trim(stile_name)//'.nc'
+ elseif (Atm%Phy_restart_is_open) then
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ zsize = (/size(Atm%inline_pbl%radh,3)/)
+ call fv_io_register_axis(Atm%Phy_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos, numz=numz, zsize=zsize)
+ call register_restart_field (Atm%Phy_restart, 'radh', Atm%inline_pbl%radh, dim_names_4d)
+ if (.not. Atm%Phy_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Phy_restart, 'radh', "long_name", "radh", str_len=len("radh"))
+ call register_variable_attribute(Atm%Phy_restart, 'radh', "units", "none", str_len=len("none"))
+ endif
+ endif
+
+ ! fname = 'sfc_data.res'//trim(stile_name)//'.nc'
+ elseif (Atm%Sfc_restart_is_open) then
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ call fv_io_register_axis(Atm%Sfc_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos)
+ call register_restart_field (Atm%Sfc_restart, 'hflx', Atm%inline_pbl%hflx, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'evap', Atm%inline_pbl%evap, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'tsfc', Atm%inline_pbl%tsfc, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'vfrac', Atm%inline_pbl%vfrac, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'vtype', Atm%inline_pbl%vtype, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'ffmm', Atm%inline_pbl%ffmm, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'ffhh', Atm%inline_pbl%ffhh, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'snowd', Atm%inline_pbl%snowd, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'lsm', Atm%inline_pbl%lsm, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'zorl', Atm%inline_pbl%zorl, dim_names_3d2)
+ !call register_restart_field (Atm%Sfc_restart, 'ztrl', Atm%inline_pbl%ztrl, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'uustar', Atm%inline_pbl%uustar, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'shdmax', Atm%inline_pbl%shdmax, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'sfcemis', Atm%inline_pbl%sfcemis, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'dlwflx', Atm%inline_pbl%dlwflx, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'sfcnsw', Atm%inline_pbl%sfcnsw, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'sfcdsw', Atm%inline_pbl%sfcdsw, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'srflag', Atm%inline_pbl%srflag, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'hice', Atm%inline_pbl%hice, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'fice', Atm%inline_pbl%fice, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'tice', Atm%inline_pbl%tice, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'weasd', Atm%inline_pbl%weasd, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'tprcp', Atm%inline_pbl%tprcp, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'qsurf', Atm%inline_pbl%qsurf, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'cmm', Atm%inline_pbl%cmm, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'chh', Atm%inline_pbl%chh, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'gflux', Atm%inline_pbl%gflux, dim_names_3d2)
+ call register_restart_field (Atm%Sfc_restart, 'ep', Atm%inline_pbl%ep, dim_names_3d2)
+ if (.not. Atm%Sfc_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Sfc_restart, 'hflx', "long_name", "hflx", str_len=len("hflx"))
+ call register_variable_attribute(Atm%Sfc_restart, 'hflx', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'evap', "long_name", "evap", str_len=len("evap"))
+ call register_variable_attribute(Atm%Sfc_restart, 'evap', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'tsfc', "long_name", "tsfc", str_len=len("tsfc"))
+ call register_variable_attribute(Atm%Sfc_restart, 'tsfc', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'vfrac', "long_name", "vfrac", str_len=len("vfrac"))
+ call register_variable_attribute(Atm%Sfc_restart, 'vfrac', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'vtype', "long_name", "vtype", str_len=len("vtype"))
+ call register_variable_attribute(Atm%Sfc_restart, 'vtype', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'ffmm', "long_name", "ffmm", str_len=len("ffmm"))
+ call register_variable_attribute(Atm%Sfc_restart, 'ffmm', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'ffhh', "long_name", "ffhh", str_len=len("ffhh"))
+ call register_variable_attribute(Atm%Sfc_restart, 'ffhh', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'snowd', "long_name", "snowd", str_len=len("snowd"))
+ call register_variable_attribute(Atm%Sfc_restart, 'snowd', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'lsm', "long_name", "lsm", str_len=len("lsm"))
+ call register_variable_attribute(Atm%Sfc_restart, 'lsm', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'zorl', "long_name", "zorl", str_len=len("zorl"))
+ call register_variable_attribute(Atm%Sfc_restart, 'zorl', "units", "none", str_len=len("none"))
+ !call register_variable_attribute(Atm%Sfc_restart, 'ztrl', "long_name", "ztrl", str_len=len("ztrl"))
+ !call register_variable_attribute(Atm%Sfc_restart, 'ztrl', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'uustar', "long_name", "uustar", str_len=len("uustar"))
+ call register_variable_attribute(Atm%Sfc_restart, 'uustar', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'shdmax', "long_name", "shdmax", str_len=len("shdmax"))
+ call register_variable_attribute(Atm%Sfc_restart, 'shdmax', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'sfcemis', "long_name", "sfcemis", str_len=len("sfcemis"))
+ call register_variable_attribute(Atm%Sfc_restart, 'sfcemis', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'dlwflx', "long_name", "dlwflx", str_len=len("dlwflx"))
+ call register_variable_attribute(Atm%Sfc_restart, 'dlwflx', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'sfcnsw', "long_name", "sfcnsw", str_len=len("sfcnsw"))
+ call register_variable_attribute(Atm%Sfc_restart, 'sfcnsw', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'sfcdsw', "long_name", "sfcdsw", str_len=len("sfcdsw"))
+ call register_variable_attribute(Atm%Sfc_restart, 'sfcdsw', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'srflag', "long_name", "srflag", str_len=len("srflag"))
+ call register_variable_attribute(Atm%Sfc_restart, 'srflag', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'hice', "long_name", "hice", str_len=len("hice"))
+ call register_variable_attribute(Atm%Sfc_restart, 'hice', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'fice', "long_name", "fice", str_len=len("fice"))
+ call register_variable_attribute(Atm%Sfc_restart, 'fice', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'tice', "long_name", "tice", str_len=len("tice"))
+ call register_variable_attribute(Atm%Sfc_restart, 'tice', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'weasd', "long_name", "weasd", str_len=len("weasd"))
+ call register_variable_attribute(Atm%Sfc_restart, 'weasd', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'tprcp', "long_name", "tprcp", str_len=len("tprcp"))
+ call register_variable_attribute(Atm%Sfc_restart, 'tprcp', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'qsurf', "long_name", "qsurf", str_len=len("qsurf"))
+ call register_variable_attribute(Atm%Sfc_restart, 'qsurf', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'cmm', "long_name", "cmm", str_len=len("cmm"))
+ call register_variable_attribute(Atm%Sfc_restart, 'cmm', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'chh', "long_name", "chh", str_len=len("chh"))
+ call register_variable_attribute(Atm%Sfc_restart, 'chh', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'gflux', "long_name", "gflux", str_len=len("gflux"))
+ call register_variable_attribute(Atm%Sfc_restart, 'gflux', "units", "none", str_len=len("none"))
+ call register_variable_attribute(Atm%Sfc_restart, 'ep', "long_name", "ep", str_len=len("ep"))
+ call register_variable_attribute(Atm%Sfc_restart, 'ep', "units", "none", str_len=len("none"))
+ endif
+ endif
+
+ ! fname = 'soi_data.res'//trim(stile_name)//'.nc'
+ elseif (Atm%Soi_restart_is_open) then
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ zsize = (/size(Atm%inline_pbl%stc,3)/)
+ call fv_io_register_axis(Atm%Soi_restart, numx=numx, numy=numy, xpos=xpos, ypos=ypos, numz=numz, zsize=zsize)
+ call register_restart_field (Atm%Soi_restart, 'stc', Atm%inline_pbl%stc, dim_names_4d)
+ if (.not. Atm%Soi_restart%is_readonly) then !if writing file
+ call register_variable_attribute(Atm%Soi_restart, 'stc', "long_name", "stc", str_len=len("stc"))
+ call register_variable_attribute(Atm%Soi_restart, 'stc', "units", "none", str_len=len("none"))
+ endif
+ endif
+
endif
end subroutine fv_io_register_restart
! NAME="fv_io_register_restart"
@@ -566,6 +733,56 @@ subroutine fv_io_read_restart(fv_domain,Atm,prefix,directory)
endif
endif
+ if ( Atm(1)%flagstruct%do_inline_gwd ) then
+!--- restore data for oro_data - if it exists
+ fname = ''//trim(dir)//'/'//trim(pre)//'oro_data.res'//trim(suffix)//'.nc'
+ Atm(1)%Oro_restart_is_open = open_file(Atm(1)%Oro_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Oro_restart_is_open) then
+ call fv_io_register_restart(Atm(1))
+ call read_restart(Atm(1)%Oro_restart)
+ call close_file(Atm(1)%Oro_restart)
+ Atm(1)%Oro_restart_is_open = .false.
+ else
+ call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+ endif
+
+ if ( Atm(1)%flagstruct%do_inline_pbl ) then
+!--- restore data for phy_data - if it exists
+ fname = ''//trim(dir)//'/'//trim(pre)//'phy_data.res'//trim(suffix)//'.nc'
+ Atm(1)%Phy_restart_is_open = open_file(Atm(1)%Phy_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Phy_restart_is_open) then
+ call fv_io_register_restart(Atm(1))
+ call read_restart(Atm(1)%Phy_restart)
+ call close_file(Atm(1)%Phy_restart)
+ Atm(1)%Phy_restart_is_open = .false.
+ else
+ call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+!--- restore data for sfc_data - if it exists
+ fname = ''//trim(dir)//'/'//trim(pre)//'sfc_data.res'//trim(suffix)//'.nc'
+ Atm(1)%Sfc_restart_is_open = open_file(Atm(1)%Sfc_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Sfc_restart_is_open) then
+ call fv_io_register_restart(Atm(1))
+ call read_restart(Atm(1)%Sfc_restart)
+ call close_file(Atm(1)%Sfc_restart)
+ Atm(1)%Sfc_restart_is_open = .false.
+ else
+ call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+!--- restore data for soi_data - if it exists
+ fname = ''//trim(dir)//'/'//trim(pre)//'soi_data.res'//trim(suffix)//'.nc'
+ Atm(1)%Soi_restart_is_open = open_file(Atm(1)%Soi_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Soi_restart_is_open) then
+ call fv_io_register_restart(Atm(1))
+ call read_restart(Atm(1)%Soi_restart)
+ call close_file(Atm(1)%Soi_restart)
+ Atm(1)%Soi_restart_is_open = .false.
+ else
+ call mpp_error(NOTE,'==> Warning from fv_read_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+ endif
+
return
end subroutine fv_io_read_restart
@@ -818,6 +1035,88 @@ subroutine remap_restart(Atm)
call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist')
endif
+ if ( Atm(1)%flagstruct%do_inline_gwd ) then
+!--- restore data for oro_data - if it exists
+ fname = 'INPUT/oro_data.res'//trim(stile_name)//'.nc'
+ Atm(1)%Oro_restart_is_open = open_file(Atm(1)%Oro_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Oro_restart_is_open) then
+ call read_data(Atm(1)%Oro_restart, 'stddev', Atm(1)%inline_gwd%hprime)
+ call read_data(Atm(1)%Oro_restart, 'convexity', Atm(1)%inline_gwd%oc)
+ call read_data(Atm(1)%Oro_restart, 'oa1', Atm(1)%inline_gwd%oa(:,:,1))
+ call read_data(Atm(1)%Oro_restart, 'oa2', Atm(1)%inline_gwd%oa(:,:,2))
+ call read_data(Atm(1)%Oro_restart, 'oa3', Atm(1)%inline_gwd%oa(:,:,3))
+ call read_data(Atm(1)%Oro_restart, 'oa4', Atm(1)%inline_gwd%oa(:,:,4))
+ call read_data(Atm(1)%Oro_restart, 'ol1', Atm(1)%inline_gwd%ol(:,:,1))
+ call read_data(Atm(1)%Oro_restart, 'ol2', Atm(1)%inline_gwd%ol(:,:,2))
+ call read_data(Atm(1)%Oro_restart, 'ol3', Atm(1)%inline_gwd%ol(:,:,3))
+ call read_data(Atm(1)%Oro_restart, 'ol4', Atm(1)%inline_gwd%ol(:,:,4))
+ call read_data(Atm(1)%Oro_restart, 'theta', Atm(1)%inline_gwd%theta)
+ call read_data(Atm(1)%Oro_restart, 'sigma', Atm(1)%inline_gwd%sigma)
+ call read_data(Atm(1)%Oro_restart, 'gamma', Atm(1)%inline_gwd%gamma)
+ call read_data(Atm(1)%Oro_restart, 'elvmax', Atm(1)%inline_gwd%elvmax)
+ call close_file(Atm(1)%Oro_restart)
+ else
+ call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+ endif
+
+ if ( Atm(1)%flagstruct%do_inline_pbl ) then
+!--- restore data for phy_data - if it exists
+ fname = 'INPUT/phy_data.res'//trim(stile_name)//'.nc'
+ Atm(1)%Phy_restart_is_open = open_file(Atm(1)%Phy_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Phy_restart_is_open) then
+ call read_data(Atm(1)%Phy_restart, 'radh', Atm(1)%inline_pbl%radh)
+ call close_file(Atm(1)%Phy_restart)
+ else
+ call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+!--- restore data for sfc_data - if it exists
+ fname = 'INPUT/sfc_data.res'//trim(stile_name)//'.nc'
+ Atm(1)%Sfc_restart_is_open = open_file(Atm(1)%Sfc_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Sfc_restart_is_open) then
+ call read_data(Atm(1)%Sfc_restart, 'hflx', Atm(1)%inline_pbl%hflx)
+ call read_data(Atm(1)%Sfc_restart, 'evap', Atm(1)%inline_pbl%evap)
+ call read_data(Atm(1)%Sfc_restart, 'tsfc', Atm(1)%inline_pbl%tsfc)
+ call read_data(Atm(1)%Sfc_restart, 'vfrac', Atm(1)%inline_pbl%vfrac)
+ call read_data(Atm(1)%Sfc_restart, 'vtype', Atm(1)%inline_pbl%vtype)
+ call read_data(Atm(1)%Sfc_restart, 'ffmm', Atm(1)%inline_pbl%ffmm)
+ call read_data(Atm(1)%Sfc_restart, 'ffhh', Atm(1)%inline_pbl%ffhh)
+ call read_data(Atm(1)%Sfc_restart, 'snowd', Atm(1)%inline_pbl%snowd)
+ call read_data(Atm(1)%Sfc_restart, 'lsm', Atm(1)%inline_pbl%lsm)
+ call read_data(Atm(1)%Sfc_restart, 'zorl', Atm(1)%inline_pbl%zorl)
+ !call read_data(Atm(1)%Sfc_restart, 'ztrl', Atm(1)%inline_pbl%ztrl)
+ call read_data(Atm(1)%Sfc_restart, 'uustar', Atm(1)%inline_pbl%uustar)
+ call read_data(Atm(1)%Sfc_restart, 'shdmax', Atm(1)%inline_pbl%shdmax)
+ call read_data(Atm(1)%Sfc_restart, 'sfcemis', Atm(1)%inline_pbl%sfcemis)
+ call read_data(Atm(1)%Sfc_restart, 'dlwflx', Atm(1)%inline_pbl%dlwflx)
+ call read_data(Atm(1)%Sfc_restart, 'sfcnsw', Atm(1)%inline_pbl%sfcnsw)
+ call read_data(Atm(1)%Sfc_restart, 'sfcdsw', Atm(1)%inline_pbl%sfcdsw)
+ call read_data(Atm(1)%Sfc_restart, 'srflag', Atm(1)%inline_pbl%srflag)
+ call read_data(Atm(1)%Sfc_restart, 'hice', Atm(1)%inline_pbl%hice)
+ call read_data(Atm(1)%Sfc_restart, 'fice', Atm(1)%inline_pbl%fice)
+ call read_data(Atm(1)%Sfc_restart, 'tice', Atm(1)%inline_pbl%tice)
+ call read_data(Atm(1)%Sfc_restart, 'weasd', Atm(1)%inline_pbl%weasd)
+ call read_data(Atm(1)%Sfc_restart, 'tprcp', Atm(1)%inline_pbl%tprcp)
+ call read_data(Atm(1)%Sfc_restart, 'qsurf', Atm(1)%inline_pbl%qsurf)
+ call read_data(Atm(1)%Sfc_restart, 'cmm', Atm(1)%inline_pbl%cmm)
+ call read_data(Atm(1)%Sfc_restart, 'chh', Atm(1)%inline_pbl%chh)
+ call read_data(Atm(1)%Sfc_restart, 'gflux', Atm(1)%inline_pbl%gflux)
+ call read_data(Atm(1)%Sfc_restart, 'ep', Atm(1)%inline_pbl%ep)
+ call close_file(Atm(1)%Sfc_restart)
+ else
+ call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+!--- restore data for soi_data - if it exists
+ fname = 'INPUT/soi_data.res'//trim(stile_name)//'.nc'
+ Atm(1)%Soi_restart_is_open = open_file(Atm(1)%Soi_restart, fname, "read", fv_domain, is_restart=.true.)
+ if (Atm(1)%Soi_restart_is_open) then
+ call read_data(Atm(1)%Soi_restart, 'stc', Atm(1)%inline_pbl%stc)
+ call close_file(Atm(1)%Soi_restart)
+ else
+ call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist')
+ endif
+ endif
+
! ====== PJP added DA functionality ======
if (Atm(1)%flagstruct%read_increment) then
! print point in middle of domain for a sanity check
@@ -1266,6 +1565,44 @@ subroutine fv_io_write_restart(Atm, prefix, directory)
Atm%Tra_restart_is_open = .false.
endif
+ if ( Atm%flagstruct%do_inline_gwd ) then
+ fname = ''//trim(dir)//'/'//trim(pre)//'oro_data.res'//trim(suffix)//'.nc'
+ Atm%Oro_restart_is_open = open_file(Atm%Oro_restart, fname, "overwrite", fv_domain, is_restart=.true.)
+ if (Atm%Oro_restart_is_open) then
+ call fv_io_register_restart(Atm)
+ call write_restart(Atm%Oro_restart)
+ call close_file(Atm%Oro_restart)
+ Atm%Oro_restart_is_open = .false.
+ endif
+ endif
+
+ if ( Atm%flagstruct%do_inline_pbl ) then
+ fname = ''//trim(dir)//'/'//trim(pre)//'phy_data.res'//trim(suffix)//'.nc'
+ Atm%Phy_restart_is_open = open_file(Atm%Phy_restart, fname, "overwrite", fv_domain, is_restart=.true.)
+ if (Atm%Phy_restart_is_open) then
+ call fv_io_register_restart(Atm)
+ call write_restart(Atm%Phy_restart)
+ call close_file(Atm%Phy_restart)
+ Atm%Phy_restart_is_open = .false.
+ endif
+ fname = ''//trim(dir)//'/'//trim(pre)//'sfc_data.res'//trim(suffix)//'.nc'
+ Atm%Sfc_restart_is_open = open_file(Atm%Sfc_restart, fname, "overwrite", fv_domain, is_restart=.true.)
+ if (Atm%Sfc_restart_is_open) then
+ call fv_io_register_restart(Atm)
+ call write_restart(Atm%Sfc_restart)
+ call close_file(Atm%Sfc_restart)
+ Atm%Sfc_restart_is_open = .false.
+ endif
+ fname = ''//trim(dir)//'/'//trim(pre)//'soi_data.res'//trim(suffix)//'.nc'
+ Atm%Soi_restart_is_open = open_file(Atm%Soi_restart, fname, "overwrite", fv_domain, is_restart=.true.)
+ if (Atm%Soi_restart_is_open) then
+ call fv_io_register_restart(Atm)
+ call write_restart(Atm%Soi_restart)
+ call close_file(Atm%Soi_restart)
+ Atm%Soi_restart_is_open = .false.
+ endif
+ endif
+
end subroutine fv_io_write_restart
diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90
index de076e8a6..ae465d570 100644
--- a/tools/fv_restart.F90
+++ b/tools/fv_restart.F90
@@ -377,7 +377,8 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_
Atm(n)%flagstruct%dry_mass, Atm(n)%flagstruct%mountain, &
Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, &
hybrid, Atm(n)%delz, Atm(n)%ze0, Atm(n)%ks, Atm(n)%ptop, &
- Atm(n)%domain, Atm(n)%tile_of_mosaic, Atm(n)%bd)
+ Atm(n)%domain, Atm(n)%tile_of_mosaic, Atm(n)%bd, &
+ Atm(n)%inline_pbl, Atm(n)%inline_gwd)
if( is_master() ) write(*,*) 'Doubly Periodic IC generated'
elseif (grid_type == 5 .or. grid_type == 6) then
call mpp_error(FATAL, "Idealized test cases for grid_type == 5,6 (global lat-lon) grid not supported")
diff --git a/tools/test_cases.F90 b/tools/test_cases.F90
index 37da15c42..d7ae6626b 100644
--- a/tools/test_cases.F90
+++ b/tools/test_cases.F90
@@ -49,7 +49,8 @@ module test_cases_mod
use gfdl_mp_mod, only: mqs3d
use fv_diagnostics_mod, only: prt_maxmin, ppme, eqv_pot, qcly0
use mpp_mod, only: mpp_pe, mpp_chksum, stdout
- use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID
+ use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID, &
+ inline_pbl_type, inline_gwd_type
use tracer_manager_mod, only: get_tracer_index
use field_manager_mod, only: MODEL_ATMOS
use w_forcing_mod, only: init_w_forcing
@@ -4535,7 +4536,8 @@ end subroutine get_pt_on_great_circle
!
subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, &
- mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd)
+ mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd, &
+ inline_pbl, inline_gwd)
type(fv_grid_bounds_type), intent(IN) :: bd
@@ -4578,6 +4580,10 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
type(domain2d), intent(IN), target :: domain_in
+ type (inline_pbl_type), intent (inout) :: inline_pbl
+
+ type (inline_gwd_type), intent (inout) :: inline_gwd
+
type(fv_grid_type), target :: gridstruct
type(fv_flags_type), target :: flagstruct
@@ -6101,6 +6107,31 @@ subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc,
end select
+ if (flagstruct%do_inline_pbl) then
+ inline_pbl%lsm = 0
+ inline_pbl%zorl = 0.1
+ inline_pbl%ztrl = 0.1
+ inline_pbl%ffmm = 10.0
+ inline_pbl%ffhh = 10.0
+ inline_pbl%tsfc = 300.
+ inline_pbl%shdmax = 0.0
+ inline_pbl%vtype = 0.0
+ inline_pbl%vfrac = 0.0
+ inline_pbl%snowd = 0.0
+ inline_pbl%uustar = 0.5
+ inline_pbl%srflag = 0.0
+ inline_pbl%hice = 0.0
+ inline_pbl%fice = 0.0
+ inline_pbl%tice = 300.
+ inline_pbl%weasd = 0.0
+ inline_pbl%tprcp = 0.0
+ inline_pbl%stc = 300.
+ endif
+
+ if (flagstruct%do_inline_gwd) then
+ inline_gwd%hprime = 0.0
+ endif
+
if (w_forcing) then
call init_w_forcing(bd, npx, npy, npz, flagstruct%grid_type, agrid, flagstruct)
endif