diff --git a/physics/GFS_DCNV_generic_post.F90 b/physics/GFS_DCNV_generic_post.F90
index 51a228122..3b69849a7 100644
--- a/physics/GFS_DCNV_generic_post.F90
+++ b/physics/GFS_DCNV_generic_post.F90
@@ -15,7 +15,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, &
index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, &
cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, &
ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, &
- ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac,clw, &
+ ntgnc, nthl, nthnc, nthv, ntgv, ntrz, ntgz, nthz, ntsigma, ntrac,clw, &
satmedmf, trans_trac, errmsg, errflg)
@@ -44,8 +44,9 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, &
real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend
integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, &
index_of_x_wind, index_of_y_wind, ntqv
- integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, &
- ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac
+ integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, &
+ ntgnc, nthl, nthnc, nthv, ntgv, ntrz, ntgz, nthz, &
+ ntsigma, ntrac
real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw
@@ -112,6 +113,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, &
n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. &
n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. &
n /= nthl .and. n /= nthnc .and. n /= nthv .and. &
+ n /= ntrz .and. n /= ntgz .and. n /= nthz .and. &
n /= ntgv .and. n /= ntsigma) then
tracers = tracers + 1
idtend = dtidx(100+n,index_of_process_dcnv)
diff --git a/physics/GFS_DCNV_generic_post.meta b/physics/GFS_DCNV_generic_post.meta
index 8428752ce..191e83a3a 100644
--- a/physics/GFS_DCNV_generic_post.meta
+++ b/physics/GFS_DCNV_generic_post.meta
@@ -454,6 +454,27 @@
dimensions = ()
type = integer
intent = in
+[ntrz]
+ standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array
+ long_name = tracer index for rain reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[ntgz]
+ standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array
+ long_name = tracer index for graupel reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[nthz]
+ standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array
+ long_name = tracer index for hail reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
[clw]
standard_name = convective_transportable_tracers
long_name = array to contain cloud water and other convective trans. tracers
diff --git a/physics/GFS_DCNV_generic_pre.F90 b/physics/GFS_DCNV_generic_pre.F90
index b31daf5d6..1dd3aafc7 100644
--- a/physics/GFS_DCNV_generic_pre.F90
+++ b/physics/GFS_DCNV_generic_pre.F90
@@ -13,7 +13,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc
gu0, gv0, gt0, gq0, nsamftrac, ntqv, &
save_u, save_v, save_t, save_q, clw, &
ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, &
- ntgnc, nthl, nthnc, nthv, ntgv,ntsigma, &
+ ntgnc, nthl, nthnc, nthv, ntgv, &
+ ntrz, ntgz, nthz, ntsigma, &
cscnv, satmedmf, trans_trac, ras, ntrac, &
dtidx, index_of_process_dcnv, errmsg, errflg)
@@ -22,7 +23,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc
implicit none
integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), &
- ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv,ntsigma
+ ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv, &
+ ntrz, ntgz, nthz, ntsigma
logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm
real(kind=kind_phys), dimension(:,:), intent(in) :: gu0
real(kind=kind_phys), dimension(:,:), intent(in) :: gv0
@@ -68,6 +70,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc
n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. &
n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. &
n /= nthl .and. n /= nthnc .and. n /= nthv .and. &
+ n /= ntrz .and. n /= ntgz .and. n /= nthz .and. &
n /= ntgv .and. n/= ntsigma) then
tracers = tracers + 1
if(dtidx(100+n,index_of_process_dcnv)>0) then
diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/GFS_DCNV_generic_pre.meta
index ee2050926..a9008436e 100644
--- a/physics/GFS_DCNV_generic_pre.meta
+++ b/physics/GFS_DCNV_generic_pre.meta
@@ -267,6 +267,27 @@
dimensions = ()
type = integer
intent = in
+[ntrz]
+ standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array
+ long_name = tracer index for rain reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[ntgz]
+ standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array
+ long_name = tracer index for graupel reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[nthz]
+ standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array
+ long_name = tracer index for hail reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
[clw]
standard_name = convective_transportable_tracers
long_name = array to contain cloud water and other convective trans. tracers
diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90
index 201c0e817..d9d30fb90 100644
--- a/physics/GFS_MP_generic_post.F90
+++ b/physics/GFS_MP_generic_post.F90
@@ -21,7 +21,8 @@ module GFS_MP_generic_post
subroutine GFS_MP_generic_post_run( &
im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, &
imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rhowater, rainmin, dtf, &
- frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, &
+ frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, refl_10cm, &
+ imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf, con_t0c, snow, graupel, save_t, save_q, &
rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,&
totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, &
pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, &
@@ -40,12 +41,13 @@ subroutine GFS_MP_generic_post_run(
integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm
logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, exticeden
integer, intent(in) :: index_of_temperature,index_of_process_mp,use_lake_model(:)
-
+ integer, intent(in) :: imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf
+ integer, dimension (:), intent(in) :: htop
integer :: dfi_radar_max_intervals
- real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour
+ real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour, con_t0c
real(kind=kind_phys), intent(in) :: radar_tten_limits(:)
integer :: ix_dfi_radar(:)
- real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0
+ real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0,refl_10cm
real(kind=kind_phys), intent(in) :: dtf, frain, con_g, rainmin, rhowater
real(kind=kind_phys), dimension(:), intent(in) :: rain1, xlat, xlon, tsfc
@@ -53,7 +55,7 @@ subroutine GFS_MP_generic_post_run(
real(kind=kind_phys), dimension(:), intent(in) :: rain0, ice0, snow0, graupel0
real(kind=kind_phys), dimension(:,:), intent(in) :: rann
real(kind=kind_phys), dimension(:,:), intent(in) :: prsl, save_t, del
- real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii
+ real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii,phil
real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0, save_q
real(kind=kind_phys), dimension(:,:,:), intent(in) :: dfi_radar_tten
@@ -112,6 +114,17 @@ subroutine GFS_MP_generic_post_run(
real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr
real :: rhonewsnow,rhoprcpice,rhonewgr,rhonewice
+ real(kind_phys), parameter :: dbzmin=-20.0
+ real(kind_phys) :: cuprate
+ real(kind_phys) :: ze, ze_conv, dbz_sum
+
+ real(kind_phys), dimension(1:im,1:levs) :: zo
+ real(kind_phys), dimension(1:im) :: zfrz
+ real(kind_phys), dimension(1:im) :: factor
+ real(kind_phys) ze_mp, fctz, delz
+ logical :: lfrz
+
+
! Initialize CCPP error handling variables
errmsg = ''
errflg = 0
@@ -121,6 +134,52 @@ subroutine GFS_MP_generic_post_run(
do i = 1, im
rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit
enddo
+!
+! Combine convective reflectivity with MP reflectivity for selected
+! parameterizations.
+ if ( (imp_physics==imp_physics_thompson .or. imp_physics==imp_physics_nssl) .and. &
+ (imfdeepcnv==imfdeepcnv_samf .or. imfdeepcnv==imfdeepcnv_gf .or. imfshalcnv==imfshalcnv_gf) ) then
+ do i=1,im
+ factor(i) = 0.0
+ lfrz = .true.
+ zfrz(i) = phil(i,1)*onebg
+ do k = levs, 1, -1
+ zo(i,k) = phil(i,k)*onebg
+ if (gt0(i,k) >= con_t0c .and. lfrz) then
+ zfrz(i) = zo(i,k)
+ lfrz = .false.
+ endif
+ enddo
+ enddo
+!
+ do i=1,im
+ if(rainc (i) > 0.0 .and. htop(i) > 0) then
+ factor(i) = -2./max(1000., zo(i,htop(i)) - zfrz(i))
+ endif
+ enddo
+
+! combine the reflectivity from both Thompson MP and samfdeep convection
+
+ do k=1,levs
+ do i=1,im
+ if(rainc(i) > 0. .and. k <= htop(i)) then
+ fctz = 0.0
+ delz = zo(i,k) - zfrz(i)
+ if(delz <0.0) then
+ fctz = 1. ! wrong
+ else
+ fctz = 10.**(factor(i)*delz)
+ endif
+ cuprate = rainc(i) * 3.6e6 / dtp ! cu precip rate (mm/h)
+ ze_conv = 300.0 * cuprate**1.4
+ ze_conv = fctz * ze_conv
+ ze_mp = 10._kind_phys ** (0.1 * refl_10cm(i,k))
+ dbz_sum = max(DBZmin, 10.*log10(ze_mp + ze_conv))
+ refl_10cm(i,k) = dbz_sum
+ endif
+ enddo
+ enddo
+ endif
! compute surface snowfall, graupel/sleet, freezing rain and precip ice density
if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then
diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta
index 7cd2ca4b5..a6137643d 100644
--- a/physics/GFS_MP_generic_post.meta
+++ b/physics/GFS_MP_generic_post.meta
@@ -254,6 +254,72 @@
type = real
kind = kind_phys
intent = in
+[phil]
+ standard_name = geopotential
+ long_name = layer geopotential
+ units = m2 s-2
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = in
+[htop]
+ standard_name = vertical_index_at_cloud_top
+ long_name = index for cloud top
+ units = index
+ dimensions = (horizontal_loop_extent)
+ type = integer
+ intent = in
+[refl_10cm]
+ standard_name = radar_reflectivity_10cm
+ long_name = instantaneous refl_10cm
+ units = dBZ
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[imfshalcnv]
+ standard_name = control_for_shallow_convection_scheme
+ long_name = flag for mass-flux shallow convection scheme
+ units = flag
+ dimensions = ()
+ type = integer
+ intent = in
+[imfshalcnv_gf]
+ standard_name = identifier_for_grell_freitas_shallow_convection
+ long_name = flag for Grell-Freitas shallow convection scheme
+ units = flag
+ dimensions = ()
+ type = integer
+ intent = in
+[imfdeepcnv]
+ standard_name = control_for_deep_convection_scheme
+ long_name = flag for mass-flux deep convection scheme
+ units = flag
+ dimensions = ()
+ type = integer
+ intent = in
+[imfdeepcnv_gf]
+ standard_name = identifier_for_grell_freitas_deep_convection
+ long_name = flag for Grell-Freitas deep convection scheme
+ units = flag
+ dimensions = ()
+ type = integer
+ intent = in
+[imfdeepcnv_samf]
+ standard_name = identifer_for_scale_aware_mass_flux_deep_convection
+ long_name = flag for SAMF deep convection scheme
+ units = flag
+ dimensions = ()
+ type = integer
+ intent = in
+[con_t0c]
+ standard_name = temperature_at_zero_celsius
+ long_name = temperature at 0 degree Celsius
+ units = K
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
[tsfc]
standard_name = surface_skin_temperature
long_name = surface skin temperature
diff --git a/physics/GFS_PBL_generic_post.F90 b/physics/GFS_PBL_generic_post.F90
index 0d13dc5d8..a4e5f172a 100644
--- a/physics/GFS_PBL_generic_post.F90
+++ b/physics/GFS_PBL_generic_post.F90
@@ -10,9 +10,9 @@ module GFS_PBL_generic_post
!!
subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, &
ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, &
- trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, &
+ trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz, &
imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, &
- imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, mraerosol, nssl_hail_on, &
+ imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, mraerosol, nssl_hail_on, nssl_3moment, &
cplflx, cplaqm, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, &
shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, &
dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, &
@@ -30,12 +30,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac,
integer, parameter :: kp = kind_phys
integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt
integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef
- integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv
+ integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz
logical, intent(in) :: trans_aero
integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6
integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires
integer, intent(in) :: imp_physics_nssl
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_3moment
logical, intent(in) :: ltaerosol, cplflx, cplaqm, cplchm, lssav, ldiag3d, lsidea, use_med_flux, mraerosol
logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu
@@ -270,8 +270,16 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac,
dqdt(i,k,ntgv) = dvdftra(i,k,14)
dqdt(i,k,nthv) = dvdftra(i,k,15)
dqdt(i,k,ntoz) = dvdftra(i,k,16)
+ n = 16
IF ( nssl_ccn_on ) THEN
- dqdt(i,k,ntccn) = dvdftra(i,k,17)
+ dqdt(i,k,ntccn) = dvdftra(i,k,n+1)
+ n = n+1
+ ENDIF
+ IF ( nssl_3moment ) THEN
+ dqdt(i,k,ntrz) = dvdftra(i,k,n+1)
+ dqdt(i,k,ntgz) = dvdftra(i,k,n+2)
+ dqdt(i,k,nthz) = dvdftra(i,k,n+3)
+ n = n+3
ENDIF
enddo
enddo
@@ -292,9 +300,16 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac,
dqdt(i,k,ntsnc) = dvdftra(i,k,10)
dqdt(i,k,ntgnc) = dvdftra(i,k,11)
dqdt(i,k,ntgv) = dvdftra(i,k,12)
- dqdt(i,k,ntoz) = dvdftra(i,k,13)
+ dqdt(i,k,ntoz) = dvdftra(i,k,13)
+ n = 13
IF ( nssl_ccn_on ) THEN
- dqdt(i,k,ntccn) = dvdftra(i,k,14)
+ dqdt(i,k,ntccn) = dvdftra(i,k,n+1)
+ n = n+1
+ ENDIF
+ IF ( nssl_3moment ) THEN
+ dqdt(i,k,ntrz) = dvdftra(i,k,n+1)
+ dqdt(i,k,ntgz) = dvdftra(i,k,n+2)
+ n = n+2
ENDIF
enddo
enddo
diff --git a/physics/GFS_PBL_generic_post.meta b/physics/GFS_PBL_generic_post.meta
index b20142991..a53acbc64 100644
--- a/physics/GFS_PBL_generic_post.meta
+++ b/physics/GFS_PBL_generic_post.meta
@@ -211,6 +211,27 @@
dimensions = ()
type = integer
intent = in
+[ntrz]
+ standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array
+ long_name = tracer index for rain reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[ntgz]
+ standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array
+ long_name = tracer index for graupel reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[nthz]
+ standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array
+ long_name = tracer index for hail reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
[imp_physics]
standard_name = control_for_microphysics_scheme
long_name = choice of microphysics scheme
@@ -295,6 +316,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[cplflx]
standard_name = flag_for_surface_flux_coupling
long_name = flag controlling cplflx collection (default off)
diff --git a/physics/GFS_PBL_generic_pre.F90 b/physics/GFS_PBL_generic_pre.F90
index b9f7bb880..d8ed0f8fc 100644
--- a/physics/GFS_PBL_generic_pre.F90
+++ b/physics/GFS_PBL_generic_pre.F90
@@ -12,10 +12,10 @@ module GFS_PBL_generic_pre
subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, &
ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, &
ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, &
- ntccn, nthl, nthnc, ntgv, nthv, &
+ ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz, &
imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, &
imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, &
- ltaerosol, mraerosol, nssl_ccn_on, nssl_hail_on, &
+ ltaerosol, mraerosol, nssl_ccn_on, nssl_hail_on, nssl_3moment, &
hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, &
flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg)
@@ -29,13 +29,13 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index,
integer, intent(in) :: im, levs, nvdiff, ntrac
integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc
integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm
- integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv
+ integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz
logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav
integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6
integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires
logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend, mraerosol
integer, intent(in) :: imp_physics_nssl
- logical, intent(in) :: nssl_hail_on, nssl_ccn_on
+ logical, intent(in) :: nssl_hail_on, nssl_ccn_on, nssl_3moment
real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs
real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs
@@ -215,15 +215,23 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index,
vdftra(i,k,7) = qgrs(i,k,nthl)
vdftra(i,k,8) = qgrs(i,k,ntlnc)
vdftra(i,k,9) = qgrs(i,k,ntinc)
- vdftra(i,k,10) = qgrs(i,k,ntrnc)
- vdftra(i,k,11) = qgrs(i,k,ntsnc)
- vdftra(i,k,12) = qgrs(i,k,ntgnc)
- vdftra(i,k,13) = qgrs(i,k,nthnc)
- vdftra(i,k,14) = qgrs(i,k,ntgv)
- vdftra(i,k,15) = qgrs(i,k,nthv)
- vdftra(i,k,16) = qgrs(i,k,ntoz)
+ vdftra(i,k,10) = qgrs(i,k,ntrnc)
+ vdftra(i,k,11) = qgrs(i,k,ntsnc)
+ vdftra(i,k,12) = qgrs(i,k,ntgnc)
+ vdftra(i,k,13) = qgrs(i,k,nthnc)
+ vdftra(i,k,14) = qgrs(i,k,ntgv)
+ vdftra(i,k,15) = qgrs(i,k,nthv)
+ vdftra(i,k,16) = qgrs(i,k,ntoz)
+ n = 16
IF ( nssl_ccn_on ) THEN
- vdftra(i,k,17) = qgrs(i,k,ntccn)
+ vdftra(i,k,n+1) = qgrs(i,k,ntccn)
+ n = n+1
+ ENDIF
+ IF ( nssl_3moment ) THEN
+ vdftra(i,k,n+1) = qgrs(i,k,ntrz)
+ vdftra(i,k,n+2) = qgrs(i,k,ntgz)
+ vdftra(i,k,n+3) = qgrs(i,k,nthz)
+ n = n+3
ENDIF
enddo
enddo
@@ -241,12 +249,19 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index,
vdftra(i,k,7) = qgrs(i,k,ntlnc)
vdftra(i,k,8) = qgrs(i,k,ntinc)
vdftra(i,k,9) = qgrs(i,k,ntrnc)
- vdftra(i,k,10) = qgrs(i,k,ntsnc)
- vdftra(i,k,11) = qgrs(i,k,ntgnc)
- vdftra(i,k,12) = qgrs(i,k,ntgv)
- vdftra(i,k,13) = qgrs(i,k,ntoz)
+ vdftra(i,k,10) = qgrs(i,k,ntsnc)
+ vdftra(i,k,11) = qgrs(i,k,ntgnc)
+ vdftra(i,k,12) = qgrs(i,k,ntgv)
+ vdftra(i,k,13) = qgrs(i,k,ntoz)
+ n = 13
IF ( nssl_ccn_on ) THEN
- vdftra(i,k,14) = qgrs(i,k,ntccn)
+ vdftra(i,k,n+1) = qgrs(i,k,ntccn)
+ n = n+1
+ ENDIF
+ IF ( nssl_3moment ) THEN
+ vdftra(i,k,n+1) = qgrs(i,k,ntrz)
+ vdftra(i,k,n+2) = qgrs(i,k,ntgz)
+ n = n+2
ENDIF
enddo
enddo
diff --git a/physics/GFS_PBL_generic_pre.meta b/physics/GFS_PBL_generic_pre.meta
index a09b34b48..995fac565 100644
--- a/physics/GFS_PBL_generic_pre.meta
+++ b/physics/GFS_PBL_generic_pre.meta
@@ -217,6 +217,27 @@
dimensions = ()
type = integer
intent = in
+[ntrz]
+ standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array
+ long_name = tracer index for rain reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[ntgz]
+ standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array
+ long_name = tracer index for graupel reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[nthz]
+ standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array
+ long_name = tracer index for hail reflectivity
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
[imp_physics]
standard_name = control_for_microphysics_scheme
long_name = choice of microphysics scheme
@@ -301,6 +322,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[hybedmf]
standard_name = flag_for_hybrid_edmf_pbl_scheme
long_name = flag for hybrid edmf pbl scheme (moninedmf)
diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90
index fe63c1cea..ed26b795f 100644
--- a/physics/GFS_debug.F90
+++ b/physics/GFS_debug.F90
@@ -747,9 +747,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling,
call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_thl ', Diag%det_thl)
call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_sqv ', Diag%det_sqv)
end if
- call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%nupdraft ', Diag%nupdraft)
+ call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxwidth ', Diag%maxwidth)
call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxMF ', Diag%maxMF)
- call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ktop_plume ', Diag%ktop_plume)
+ call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ztop_plume ', Diag%ztop_plume)
call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h)
call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m)
end if
diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90
index 4100bdf6e..f53ab3928 100644
--- a/physics/GFS_phys_time_vary.fv3.F90
+++ b/physics/GFS_phys_time_vary.fv3.F90
@@ -2,7 +2,7 @@
!! Contains code related to GFS physics suite setup (physics part of time_vary_step)
!>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update
-!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor,
+!! This module contains GFS physics time vary subroutines including stratospheric water vapor,
!! aerosol, IN&CCN and surface properties updates.
module GFS_phys_time_vary
@@ -10,12 +10,11 @@ module GFS_phys_time_vary
use omp_lib
#endif
- use machine, only : kind_phys
+ use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec
use mersenne_twister, only: random_setseed, random_number
- use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin
- use ozinterp, only : read_o3data, setindxoz, ozinterpol
+ use module_ozphys, only: ty_ozphys
use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin
use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol
@@ -85,7 +84,7 @@ end subroutine copy_error
subroutine GFS_phys_time_vary_init ( &
me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, &
nx, ny, idate, xlat_d, xlon_d, &
- jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, &
+ jindx1_o3, jindx2_o3, ddy_o3, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, &
jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, &
jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, &
do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, &
@@ -98,7 +97,7 @@ subroutine GFS_phys_time_vary_init (
smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, &
slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, &
lkm, use_lake_model, lakefrac, lakedepth, iopt_lake, iopt_lake_clm, iopt_lake_flake, &
- lakefrac_threshold, lakedepth_threshold, errmsg, errflg)
+ lakefrac_threshold, lakedepth_threshold, ozphys, errmsg, errflg)
implicit none
@@ -115,7 +114,8 @@ subroutine GFS_phys_time_vary_init (
integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:)
real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:)
- real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:)
+ real(kind_phys), intent(in) :: h2opl(:,:,:)
+
integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:)
real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:)
real(kind_phys), intent(out) :: aer_nm(:,:,:)
@@ -132,6 +132,7 @@ subroutine GFS_phys_time_vary_init (
real(kind_phys), intent(in) :: min_seaice, fice(:)
real(kind_phys), intent(in) :: landfrac(:)
real(kind_phys), intent(inout) :: weasd(:)
+ type(ty_ozphys), intent(in) :: ozphys
! NoahMP - only allocated when NoahMP is used
integer, intent(in) :: lsoil, lsnow_lsm_lbound, lsnow_lsm_ubound
@@ -221,54 +222,12 @@ subroutine GFS_phys_time_vary_init (
jamin=999
jamax=-999
-!$OMP parallel num_threads(nthrds) default(none) &
-!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,levs,idate) &
-!$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) &
-!$OMP shared (levozp,oz_coeff,oz_pres,ozpl) &
-!$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) &
-!$OMP shared (iamin, iamax, jamin, jamax, lsm_noahmp) &
-!$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) &
-!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) &
-!$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) &
-!$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) &
-!$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) &
-!$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) &
-!$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) &
-!$OMP private (ix,i,j,rsnow,vegtyp,myerrmsg,myerrflg)
-
-!$OMP sections
-
-!$OMP section
-!> - Call read_o3data() to read ozone data
- need_o3data: if(ntoz > 0) then
- call read_o3data (ntoz, me, master)
-
- ! Consistency check that the hardcoded values for levozp and
- ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data
- ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff))
- if (size(ozpl, dim=2).ne.levozp) then
- myerrflg = 1
- write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", &
- "levozp from read_o3data does not match value in GFS_typedefs.F90: ", &
- levozp, " /= ", size(ozpl, dim=2)
- call copy_error(myerrmsg, myerrflg, errmsg, errflg)
- end if
- if (size(ozpl, dim=3).ne.oz_coeff) then
- myerrflg = 1
- write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", &
- "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", &
- oz_coeff, " /= ", size(ozpl, dim=3)
- call copy_error(myerrmsg, myerrflg, errmsg, errflg)
- end if
- endif need_o3data
-
-!$OMP section
!> - Call read_h2odata() to read stratospheric water vapor data
need_h2odata: if(h2o_phys) then
call read_h2odata (h2o_phys, me, master)
! Consistency check that the hardcoded values for levh2o and
- ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data
+ ! h2o_coeff in GFS_typedefs.F90 match what is set by read_h2odata
! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff))
if (size(h2opl, dim=2).ne.levh2o) then
write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", &
@@ -286,7 +245,6 @@ subroutine GFS_phys_time_vary_init (
end if
endif need_h2odata
-!$OMP section
!> - Call read_aerdata() to read aerosol climatology, Anning added coupled
!> added coupled gocart and radiation option to initializing aer_nm
if (iaerclm) then
@@ -308,7 +266,6 @@ subroutine GFS_phys_time_vary_init (
ntrcaer = 1
endif
-!$OMP section
!> - Call read_cidata() to read IN and CCN data
if (iccn == 1) then
call read_cidata (me,master)
@@ -316,7 +273,6 @@ subroutine GFS_phys_time_vary_init (
! hardcoded in module iccn_def.F and GFS_typedefs.F90
endif
-!$OMP section
!> - Call tau_amf dats for ugwp_v1
if (do_ugwp_v1) then
myerrflg = 0
@@ -325,14 +281,12 @@ subroutine GFS_phys_time_vary_init (
call copy_error(myerrmsg, myerrflg, errmsg, errflg)
endif
-!$OMP section
!> - Initialize soil vegetation (needed for sncovr calculation further down)
myerrflg = 0
myerrmsg = 'set_soilveg failed without a message'
call set_soilveg(me, isot, ivegsrc, nlunit, myerrmsg, myerrflg)
call copy_error(myerrmsg, myerrflg, errmsg, errflg)
-!$OMP section
!> - read in NoahMP table (needed for NoahMP init)
if(lsm == lsm_noahmp) then
myerrflg = 0
@@ -341,25 +295,19 @@ subroutine GFS_phys_time_vary_init (
call copy_error(myerrmsg, myerrflg, errmsg, errflg)
endif
-!$OMP end sections
! Need an OpenMP barrier here (implicit in "end sections")
-!$OMP sections
-
-!$OMP section
-!> - Call setindxoz() to initialize ozone data
+!> - Setup spatial interpolation indices for ozone physics.
if (ntoz > 0) then
- call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3)
+ call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3)
endif
-!$OMP section
!> - Call setindxh2o() to initialize stratospheric water vapor data
if (h2o_phys) then
call setindxh2o (im, xlat_d, jindx1_h, jindx2_h, ddy_h)
endif
-!$OMP section
!> - Call setindxaer() to initialize aerosols data
if (iaerclm) then
call setindxaer (im, xlat_d, jindx1_aer, &
@@ -372,7 +320,6 @@ subroutine GFS_phys_time_vary_init (
jamax = max(maxval(jindx2_aer), jamax)
endif
-!$OMP section
!> - Call setindxci() to initialize IN and CCN data
if (iccn == 1) then
call setindxci (im, xlat_d, jindx1_ci, &
@@ -380,14 +327,12 @@ subroutine GFS_phys_time_vary_init (
iindx1_ci, iindx2_ci, ddx_ci)
endif
-!$OMP section
!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs
if (do_ugwp_v1) then
call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, &
ddy_j1tau, ddy_j2tau)
endif
-!$OMP section
!--- initial calculation of maps local ix -> global i and j
ix = 0
do j = 1,ny
@@ -398,7 +343,6 @@ subroutine GFS_phys_time_vary_init (
enddo
enddo
-!$OMP section
!--- if sncovr does not exist in the restart, need to create it
if (all(sncovr < zero)) then
if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters'
@@ -427,10 +371,6 @@ subroutine GFS_phys_time_vary_init (
endif
endif
-!$OMP end sections
-
-!$OMP end parallel
-
if (errflg/=0) return
if (iaerclm) then
@@ -794,7 +734,7 @@ subroutine GFS_phys_time_vary_timestep_init (
lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, &
tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, &
zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, &
- cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, &
+ cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, ozphys, &
do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg)
implicit none
@@ -824,6 +764,7 @@ subroutine GFS_phys_time_vary_timestep_init (
integer, intent(in) :: jindx1_tau(:), jindx2_tau(:)
real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:)
real(kind_phys), intent(inout) :: tau_amf(:)
+ type(ty_ozphys), intent(in) :: ozphys
! For gcycle only
integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil
@@ -846,10 +787,13 @@ subroutine GFS_phys_time_vary_timestep_init (
integer, intent(out) :: errflg
! Local variables
- integer :: i, j, k, iseed, iskip, ix
- real(kind=kind_phys) :: wrk(1)
- real(kind=kind_phys) :: rannie(cny)
- real(kind=kind_phys) :: rndval(cnx*cny*nrcm)
+ integer :: i, j, k, iseed, iskip, ix, idat(8), jdat(8), iday, j1, j2, nc, n1, n2, jdow, &
+ jdoy, jday, w3kindreal, w3kindint
+ real(kind_phys) :: wrk(1), tem, tx1, tx2, rjday
+ real(kind_phys) :: rannie(cny)
+ real(kind_phys) :: rndval(cnx*cny*nrcm)
+ real(kind_dbl_prec) :: rinc(5)
+ real(kind_sngl_prec) :: rinc4(5)
! Initialize CCPP error handling variables
errmsg = ''
@@ -869,7 +813,8 @@ subroutine GFS_phys_time_vary_timestep_init (
!$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) &
!$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) &
!$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) &
-!$OMP shared(ddy_j2tau,tau_amf,iflip) &
+!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys,rjday,n1,n2,idat,jdat,rinc,rinc4) &
+!$OMP shared(w3kindreal,w3kindint,jdow,jdoy,jday) &
!$OMP private(iseed,iskip,i,j,k)
!$OMP sections
@@ -920,11 +865,41 @@ subroutine GFS_phys_time_vary_timestep_init (
endif ! imfdeepcnv, cal_re, random_clds
!$OMP section
-!> - Call ozinterpol() to make ozone interpolation
+ !> - Compute temporal interpolation indices for updating gas concentrations.
+ idat=0
+ idat(1)=idate(4)
+ idat(2)=idate(2)
+ idat(3)=idate(3)
+ idat(5)=idate(1)
+ rinc=0.
+ rinc(2)=fhour
+ call w3kind(w3kindreal,w3kindint)
+ if(w3kindreal==4) then
+ rinc4=rinc
+ CALL w3movdat(rinc4,idat,jdat)
+ else
+ CALL w3movdat(rinc,idat,jdat)
+ endif
+ jdow = 0
+ jdoy = 0
+ jday = 0
+ call w3doxdat(jdat,jdow,jdoy,jday)
+ rjday = jdoy + jdat(5) / 24.
+ if (rjday < ozphys%time(1)) rjday = rjday + 365.
+
+ n2 = ozphys%ntime + 1
+ do j=2,ozphys%ntime
+ if (rjday < ozphys%time(j)) then
+ n2 = j
+ exit
+ endif
+ enddo
+ n1 = n2 - 1
+ if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime
+
+!> - Update ozone concentration.
if (ntoz > 0) then
- call ozinterpol (me, im, idate, fhour, &
- jindx1_o3, jindx2_o3, &
- ozpl, ddy_o3)
+ call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl)
endif
!$OMP section
@@ -1024,12 +999,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg)
if (.not.is_initialized) return
- ! Deallocate ozone arrays
- if (allocated(oz_lat) ) deallocate(oz_lat)
- if (allocated(oz_pres) ) deallocate(oz_pres)
- if (allocated(oz_time) ) deallocate(oz_time)
- if (allocated(ozplin) ) deallocate(ozplin)
-
! Deallocate h2o arrays
if (allocated(h2o_lat) ) deallocate(h2o_lat)
if (allocated(h2o_pres)) deallocate(h2o_pres)
diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta
index 363469e91..968f33027 100644
--- a/physics/GFS_phys_time_vary.fv3.meta
+++ b/physics/GFS_phys_time_vary.fv3.meta
@@ -2,7 +2,7 @@
name = GFS_phys_time_vary
type = scheme
dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f
- dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90
+ dependencies = namelist_soilveg.f,set_soilveg.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90,module_ozphys.F90
########################################################################
[ccpp-arg-table]
@@ -138,14 +138,6 @@
type = real
kind = kind_phys
intent = inout
-[ozpl]
- standard_name = ozone_forcing
- long_name = ozone forcing data
- units = mixed
- dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
[jindx1_h]
standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation
long_name = interpolation low index for stratospheric water vapor
@@ -969,6 +961,13 @@
type = real
kind = kind_phys
intent = in
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
@@ -1206,7 +1205,7 @@
standard_name = ozone_forcing
long_name = ozone forcing data
units = mixed
- dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
+ dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data)
type = real
kind = kind_phys
intent = inout
@@ -1942,6 +1941,13 @@
type = real
kind = kind_phys
intent = inout
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90
index 85aba7b70..ff5a50d41 100644
--- a/physics/GFS_phys_time_vary.scm.F90
+++ b/physics/GFS_phys_time_vary.scm.F90
@@ -2,17 +2,16 @@
!! Contains code related to GFS physics suite setup (physics part of time_vary_step)
!>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update
-!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor,
+!! This module contains GFS physics time vary subroutines including stratospheric water vapor,
!! aerosol, IN&CCN and surface properties updates.
!> @{
module GFS_phys_time_vary
- use machine, only : kind_phys
+ use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec
use mersenne_twister, only: random_setseed, random_number
- use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin
- use ozinterp, only : read_o3data, setindxoz, ozinterpol
+ use module_ozphys, only: ty_ozphys
use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin
use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol
@@ -62,7 +61,7 @@ module GFS_phys_time_vary
!! @{
subroutine GFS_phys_time_vary_init ( &
me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, &
- jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, &
+ jindx1_o3, jindx2_o3, ddy_o3, ozphys, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, &
jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, &
jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, &
do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, &
@@ -87,7 +86,7 @@ subroutine GFS_phys_time_vary_init (
integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:)
real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:)
- real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:)
+ real(kind_phys), intent(in) :: h2opl(:,:,:)
integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:)
real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:)
real(kind_phys), intent(in) :: aer_nm(:,:,:)
@@ -104,6 +103,7 @@ subroutine GFS_phys_time_vary_init (
real(kind_phys), intent(in) :: min_seaice, fice(:)
real(kind_phys), intent(in) :: landfrac(:)
real(kind_phys), intent(inout) :: weasd(:)
+ type(ty_ozphys), intent(in) :: ozphys
! NoahMP - only allocated when NoahMP is used
integer, intent(in) :: lsoil, lsnow_lsm_lbound, lsnow_lsm_ubound
@@ -189,30 +189,11 @@ subroutine GFS_phys_time_vary_init (
jamin=999
jamax=-999
-!> - Call read_o3data() to read ozone data
- call read_o3data (ntoz, me, master)
-
- ! Consistency check that the hardcoded values for levozp and
- ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data
- ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff))
- if (size(ozpl, dim=2).ne.levozp) then
- write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", &
- "levozp from read_o3data does not match value in GFS_typedefs.F90: ", &
- levozp, " /= ", size(ozpl, dim=2)
- errflg = 1
- end if
- if (size(ozpl, dim=3).ne.oz_coeff) then
- write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", &
- "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", &
- oz_coeff, " /= ", size(ozpl, dim=3)
- errflg = 1
- end if
-
!> - Call read_h2odata() to read stratospheric water vapor data
call read_h2odata (h2o_phys, me, master)
! Consistency check that the hardcoded values for levh2o and
- ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data
+ ! h2o_coeff in GFS_typedefs.F90 match what is set by read_h2odata
! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff))
if (size(h2opl, dim=2).ne.levh2o) then
write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", &
@@ -266,9 +247,9 @@ subroutine GFS_phys_time_vary_init (
!> - Initialize soil vegetation (needed for sncovr calculation further down)
call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg)
-!> - Call setindxoz() to initialize ozone data
+!> - Setup spatial interpolation indices for ozone physics.
if (ntoz > 0) then
- call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3)
+ call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3)
endif
!> - Call setindxh2o() to initialize stratospheric water vapor data
@@ -652,7 +633,7 @@ end subroutine GFS_phys_time_vary_init
!! @{
subroutine GFS_phys_time_vary_timestep_init ( &
me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, &
- imfdeepcnv, cal_pre, random_clds, ntoz, h2o_phys, iaerclm, iccn, clstp, &
+ imfdeepcnv, cal_pre, random_clds, ozphys, ntoz, h2o_phys, iaerclm, iccn, clstp, &
jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, &
jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, &
jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, &
@@ -686,15 +667,19 @@ subroutine GFS_phys_time_vary_timestep_init (
integer, intent(in) :: jindx1_tau(:), jindx2_tau(:)
real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:)
real(kind_phys), intent(inout) :: tau_amf(:)
+ type(ty_ozphys), intent(in) :: ozphys
integer, intent(in) :: nthrds
character(len=*), intent(out) :: errmsg
integer, intent(out) :: errflg
! Local variables
- integer :: i, j, k, iseed, iskip, ix
- real(kind=kind_phys) :: wrk(1)
- real(kind=kind_phys) :: rannie(cny)
- real(kind=kind_phys) :: rndval(cnx*cny*nrcm)
+ integer :: i, j, k, iseed, iskip, ix, idat(8), jdat(8), iday, j1, j2, nc, n1, n2, jdow, &
+ jdoy, jday, w3kindreal, w3kindint
+ real(kind_phys) :: wrk(1), tem, tx1, tx2, rjday
+ real(kind_phys) :: rannie(cny)
+ real(kind_phys) :: rndval(cnx*cny*nrcm)
+ real(kind_dbl_prec) :: rinc(5)
+ real(kind_sngl_prec) :: rinc4(5)
! Initialize CCPP error handling variables
errmsg = ''
@@ -748,11 +733,41 @@ subroutine GFS_phys_time_vary_timestep_init (
endif ! imfdeepcnv, cal_re, random_clds
-!> - Call ozinterpol() to make ozone interpolation
+ !> - Compute temporal interpolation indices for updating gas concentrations.
+ idat=0
+ idat(1)=idate(4)
+ idat(2)=idate(2)
+ idat(3)=idate(3)
+ idat(5)=idate(1)
+ rinc=0.
+ rinc(2)=fhour
+ call w3kind(w3kindreal,w3kindint)
+ if(w3kindreal==4) then
+ rinc4=rinc
+ CALL w3movdat(rinc4,idat,jdat)
+ else
+ CALL w3movdat(rinc,idat,jdat)
+ endif
+ jdow = 0
+ jdoy = 0
+ jday = 0
+ call w3doxdat(jdat,jdow,jdoy,jday)
+ rjday = jdoy + jdat(5) / 24.
+ if (rjday < ozphys%time(1)) rjday = rjday + 365.
+
+ n2 = ozphys%ntime + 1
+ do j=2,ozphys%ntime
+ if (rjday < ozphys%time(j)) then
+ n2 = j
+ exit
+ endif
+ enddo
+ n1 = n2 - 1
+ if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime
+
+!> - Update ozone concentration.
if (ntoz > 0) then
- call ozinterpol (me, im, idate, fhour, &
- jindx1_o3, jindx2_o3, &
- ozpl, ddy_o3)
+ call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl)
endif
!> - Call h2ointerpol() to make stratospheric water vapor data interpolation
@@ -847,12 +862,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg)
if (.not.is_initialized) return
- ! Deallocate ozone arrays
- if (allocated(oz_lat) ) deallocate(oz_lat)
- if (allocated(oz_pres) ) deallocate(oz_pres)
- if (allocated(oz_time) ) deallocate(oz_time)
- if (allocated(ozplin) ) deallocate(ozplin)
-
! Deallocate h2o arrays
if (allocated(h2o_lat) ) deallocate(h2o_lat)
if (allocated(h2o_pres)) deallocate(h2o_pres)
diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta
index 8b59e4bed..d72e27fd5 100644
--- a/physics/GFS_phys_time_vary.scm.meta
+++ b/physics/GFS_phys_time_vary.scm.meta
@@ -2,7 +2,7 @@
name = GFS_phys_time_vary
type = scheme
dependencies = aerclm_def.F,aerinterp.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f
- dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,cires_tauamf_data.F90,noahmp_tables.f90
+ dependencies = namelist_soilveg.f,set_soilveg.f,module_ozphys.F90,cires_tauamf_data.F90,noahmp_tables.f90
########################################################################
[ccpp-arg-table]
@@ -124,14 +124,6 @@
type = real
kind = kind_phys
intent = inout
-[ozpl]
- standard_name = ozone_forcing
- long_name = ozone forcing data
- units = mixed
- dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
[jindx1_h]
standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation
long_name = interpolation low index for stratospheric water vapor
@@ -1118,7 +1110,7 @@
standard_name = ozone_forcing
long_name = ozone forcing data
units = mixed
- dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
+ dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data)
type = real
kind = kind_phys
intent = inout
@@ -1353,6 +1345,13 @@
type = real
kind = kind_phys
intent = inout
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = in
[nthrds]
standard_name = number_of_openmp_threads
long_name = number of OpenMP threads available for physics schemes
diff --git a/physics/GFS_physics_post.F90 b/physics/GFS_physics_post.F90
new file mode 100644
index 000000000..fe5409353
--- /dev/null
+++ b/physics/GFS_physics_post.F90
@@ -0,0 +1,158 @@
+! ###########################################################################################
+!> \file GFS_physics_post.F90
+!!
+!! This module contains GFS specific calculations (e.g. diagnostics) and suite specific
+!! code (e.g Saving fields for subsequent physics timesteps). For interoperability across a
+!! wide range of hosts, CCPP compliant schemes should avoid including such calculations. This
+!! module/scheme is intended for such "host-specific" computations.
+!!
+! ###########################################################################################
+module GFS_physics_post
+ use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec
+ implicit none
+ public GFS_physics_post_run
+contains
+
+! ###########################################################################################
+! SUBROUTINE GFS_physics_post_run
+! ###########################################################################################
+!! \section arg_table_GFS_physics_post_run Argument Table
+!! \htmlinclude GFS_physics_post_run.html
+!!
+ subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_summed, &
+ dtidx, is_photochem, ldiag3d, ip_physics, ip_photochem, ip_prod_loss, ip_ozmix, &
+ ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, &
+ dtend, errmsg, errflg)
+
+ ! Inputs
+ integer, intent(in) :: &
+ nCol, & ! Horizontal dimension
+ nLev, & ! Number of vertical layers
+ ntoz, & ! Index for ozone mixing ratio
+ ntracp100, & ! Number of tracers plus 100
+ nprocess, & ! Number of processes that cause changes in state variables
+ nprocess_summed,& ! Number of causes in dtidx per tracer summed for total physics tendency
+ ip_physics, & ! Index for process in diagnostic tendency output
+ ip_photochem, & ! Index for process in diagnostic tendency output
+ ip_prod_loss, & ! Index for process in diagnostic tendency output
+ ip_ozmix, & ! Index for process in diagnostic tendency output
+ ip_temp, & ! Index for process in diagnostic tendency output
+ ip_overhead_ozone ! Index for process in diagnostic tendency output
+ integer, intent(in), dimension(:,:) :: &
+ dtidx ! Bookkeeping indices for GFS diagnostic tendencies
+ logical, intent(in) :: &
+ ldiag3d ! Flag for 3d diagnostic fields
+ logical, intent(in), dimension(:) :: &
+ is_photochem ! Flags for photochemistry processes to sum
+
+ ! Inputs (optional)
+ real(kind=kind_phys), intent(in), dimension(:,:), pointer, optional :: &
+ do3_dt_prd, & ! Physics tendency: production and loss effect
+ do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect
+ do3_dt_temp, & ! Physics tendency: temperature effect
+ do3_dt_ohoz ! Physics tendency: overhead ozone effect
+
+ ! Outputs
+ real(kind=kind_phys), intent(inout), dimension(:,:,:) :: &
+ dtend ! Diagnostic tendencies for state variables
+ character(len=*), intent(out) :: &
+ errmsg ! CCPP error message
+ integer, intent(out) :: &
+ errflg ! CCPP error flag
+
+ ! Locals
+ integer :: idtend, ichem, iphys, itrac
+ logical :: all_true(nprocess)
+
+ ! Initialize CCPP error handling variables
+ errmsg = ''
+ errflg = 0
+
+ if(.not.ldiag3d) then
+ return
+ endif
+
+ ! #######################################################################################
+ !
+ ! Ozone physics diagnostics
+ !
+ ! #######################################################################################
+ idtend = dtidx(100+ntoz,ip_prod_loss)
+ if (idtend >= 1 .and. associated(do3_dt_prd)) then
+ dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_prd
+ endif
+ !
+ idtend = dtidx(100+ntoz,ip_ozmix)
+ if (idtend >= 1 .and. associated(do3_dt_ozmx)) then
+ dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ozmx
+ endif
+ !
+ idtend = dtidx(100+ntoz,ip_temp)
+ if (idtend >= 1 .and. associated(do3_dt_temp)) then
+ dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_temp
+ endif
+ !
+ idtend = dtidx(100+ntoz,ip_overhead_ozone)
+ if (idtend >= 1 .and. associated(do3_dt_ohoz)) then
+ dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ohoz
+ endif
+
+ ! #######################################################################################
+ !
+ ! Total (photochemical) tendencies.
+ !
+ ! #######################################################################################
+ itrac = ntoz+100
+ ichem = dtidx(itrac, ip_photochem)
+ if(ichem >= 1) then
+ call sum_it(ichem, itrac, is_photochem)
+ endif
+
+ ! #######################################################################################
+ !
+ ! Total (physics) tendencies
+ !
+ ! #######################################################################################
+ all_true = .true.
+ do itrac = 2,ntracp100
+ iphys = dtidx(itrac,ip_physics)
+ if(iphys >= 1) then
+ call sum_it(iphys, itrac, all_true)
+ endif
+ enddo
+
+ contains
+
+ subroutine sum_it(isum,itrac,sum_me)
+ integer, intent(in) :: isum ! third index of dtend of summary process
+ integer, intent(in) :: itrac ! tracer or state variable being summed
+ logical, intent(in) :: sum_me(nprocess) ! false = skip this process
+ logical :: first
+ integer :: idtend, iprocess
+
+ first=.true.
+ do iprocess=1,nprocess
+ if(iprocess>nprocess_summed) then
+ exit ! Don't sum up the sums.
+ else if(.not.sum_me(iprocess)) then
+ cycle ! We were asked to skip this one.
+ endif
+ idtend = dtidx(itrac,iprocess)
+ if(idtend>=1) then
+ ! This tendency was calculated for this tracer, so
+ ! accumulate it into the total tendency.
+ if(first) then
+ dtend(:,:,isum) = dtend(:,:,idtend)
+ first=.false.
+ else
+ dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend)
+ endif
+ endif
+ enddo
+ if(first) then
+ ! No tendencies were calculated, so sum is 0:
+ dtend(:,:,isum) = 0
+ endif
+ end subroutine sum_it
+ end subroutine GFS_physics_post_run
+end module GFS_physics_post
diff --git a/physics/ozphys_2015.meta b/physics/GFS_physics_post.meta
similarity index 59%
rename from physics/ozphys_2015.meta
rename to physics/GFS_physics_post.meta
index 8bce7defe..5701909fd 100644
--- a/physics/ozphys_2015.meta
+++ b/physics/GFS_physics_post.meta
@@ -1,130 +1,26 @@
[ccpp-table-properties]
- name = ozphys_2015
+ name = GFS_physics_post
type = scheme
dependencies = machine.F
########################################################################
[ccpp-arg-table]
- name = ozphys_2015_init
+ name = GFS_physics_post_run
type = scheme
-[oz_phys_2015]
- standard_name = flag_for_nrl_2015_ozone_scheme
- long_name = flag for new (2015) ozone physics
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
-
-########################################################################
-[ccpp-arg-table]
- name = ozphys_2015_run
- type = scheme
-[im]
+[nCol]
standard_name = horizontal_loop_extent
long_name = horizontal loop extent
units = count
dimensions = ()
type = integer
intent = in
-[levs]
+[nLev]
standard_name = vertical_layer_dimension
long_name = number of vertical layers
units = count
dimensions = ()
type = integer
intent = in
-[ko3]
- standard_name = vertical_dimension_of_ozone_forcing_data
- long_name = number of vertical layers in ozone forcing data
- units = count
- dimensions = ()
- type = integer
- intent = in
-[dt]
- standard_name = timestep_for_physics
- long_name = physics time step
- units = s
- dimensions = ()
- type = real
- kind = kind_phys
- intent = in
-[oz]
- standard_name = ozone_concentration_of_new_state
- long_name = ozone concentration updated by physics
- units = kg kg-1
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = inout
-[tin]
- standard_name = air_temperature_of_new_state
- long_name = updated air temperature
- units = K
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[po3]
- standard_name = natural_log_of_ozone_forcing_data_pressure_levels
- long_name = natural log of ozone forcing data pressure levels
- units = 1
- dimensions = (vertical_dimension_of_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
-[prsl]
- standard_name = air_pressure
- long_name = mid-layer pressure
- units = Pa
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[prdout]
- standard_name = ozone_forcing
- long_name = ozone forcing data
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
-[pl_coeff]
- standard_name = number_of_coefficients_in_ozone_forcing_data
- long_name = number of coefficients in ozone forcing data
- units = index
- dimensions = ()
- type = integer
- intent = in
-[delp]
- standard_name = air_pressure_difference_between_midlayers
- long_name = difference between mid-layer pressures
- units = Pa
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[ldiag3d]
- standard_name = flag_for_diagnostics_3D
- long_name = flag for calculating 3-D diagnostic fields
- units = flag
- dimensions = ()
- type = logical
- intent = in
[dtend]
standard_name = cumulative_change_of_state_variables
long_name = diagnostic tendencies for state variables
@@ -147,48 +43,114 @@
dimensions = ()
type = integer
intent = in
-[index_of_process_prod_loss]
+[ntracp100]
+ standard_name = number_of_tracers_plus_one_hundred
+ long_name = number of tracers plus one hundred
+ units = count
+ dimensions = ()
+ type = integer
+ intent = in
+[nprocess]
+ standard_name = number_of_cumulative_change_processes
+ long_name = number of processes that cause changes in state variables
+ units = count
+ dimensions = ()
+ type = integer
+ intent = in
+[nprocess_summed]
+ standard_name = number_of_physics_causes_of_tracer_changes
+ long_name = number of causes in dtidx per tracer summed for total physics tendency
+ units = count
+ dimensions = ()
+ type = integer
+ intent = in
+[ip_physics]
+ standard_name = index_of_all_physics_process_in_cumulative_change_index
+ long_name = index of all physics transport process in second dimension of array cumulative change index
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[ip_photochem]
+ standard_name = index_of_photochemistry_process_in_cumulative_change_index
+ long_name = index of photochemistry process in second dimension of array cumulative change index
+ units = index
+ dimensions = ()
+ type = integer
+ intent = in
+[is_photochem]
+ standard_name = flags_for_photochemistry_processes_to_sum
+ long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change
+ units = flag
+ dimensions = (number_of_cumulative_change_processes)
+ type = logical
+ intent = in
+[ldiag3d]
+ standard_name = flag_for_diagnostics_3D
+ long_name = flag for 3d diagnostic fields
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
+[ip_prod_loss]
standard_name = index_of_production_and_loss_process_in_cumulative_change_index
long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index
units = index
dimensions = ()
type = integer
intent = in
-[index_of_process_ozmix]
+[ip_ozmix]
standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index
long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index
units = index
dimensions = ()
type = integer
intent = in
-[index_of_process_temp]
+[ip_temp]
standard_name = index_of_temperature_process_in_cumulative_change_index
long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index
units = index
dimensions = ()
type = integer
intent = in
-[index_of_process_overhead_ozone]
+[ip_overhead_ozone]
standard_name = index_of_overhead_process_in_cumulative_change_index
long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index
units = index
dimensions = ()
type = integer
intent = in
-[con_g]
- standard_name = gravitational_acceleration
- long_name = gravitational acceleration
- units = m s-2
- dimensions = ()
+[do3_dt_prd]
+ standard_name = ozone_tendency_due_to_production_and_loss_rate
+ long_name = ozone tendency due to production and loss rate
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
type = real
kind = kind_phys
intent = in
-[me]
- standard_name = mpi_rank
- long_name = rank of the current MPI task
- units = index
- dimensions = ()
- type = integer
+[do3_dt_ozmx]
+ standard_name = ozone_tendency_due_to_ozone_mixing_ratio
+ long_name = ozone tendency due to ozone mixing ratio
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = in
+[do3_dt_temp]
+ standard_name = ozone_tendency_due_to_temperature
+ long_name = ozone tendency due to temperature
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = in
+[do3_dt_ohoz]
+ standard_name = ozone_tendency_due_to_overhead_ozone_column
+ long_name = ozone tendency due to overhead ozone column
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
intent = in
[errmsg]
standard_name = ccpp_error_message
@@ -204,4 +166,4 @@
units = 1
dimensions = ()
type = integer
- intent = out
+ intent = out
\ No newline at end of file
diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90
index fff4ae0b9..5da5c86fb 100644
--- a/physics/GFS_rrtmg_pre.F90
+++ b/physics/GFS_rrtmg_pre.F90
@@ -45,7 +45,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,&
gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, &
clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, &
faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd, &
- aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, errmsg, errflg)
+ aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, ozphys, &
+ errmsg, errflg)
use machine, only: kind_phys
@@ -53,7 +54,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,&
use funcphys, only: fpvs
use module_radiation_astronomy,only: coszmn ! sol_init, sol_update
- use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update,
+ use module_radiation_gases, only: NF_VGAS, getgases ! gas_init, gas_update,
use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update,
& NSPC1
use module_radiation_clouds, only: NF_CLDS, & ! cld_init
@@ -80,6 +81,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,&
make_IceNumber, &
make_DropletNumber, &
make_RainNumber
+ ! For NRL Ozone
+ use module_ozphys, only: ty_ozphys
implicit none
integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, &
@@ -250,6 +253,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,&
integer :: iflag
integer :: islmsk
+ ! For NRL Ozone
+ type(ty_ozphys),intent(in) :: ozphys
+
integer :: ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte
@@ -420,7 +426,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,&
!> - Get layer ozone mass mixing ratio (if use ozone climatology data,
-!! call getozn()).
if (ntoz > 0) then ! interactive ozone generation
do k=1,lmk
@@ -429,8 +434,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,&
enddo
enddo
else ! climatological ozone
- call getozn (prslk1, xlat, im, lmk, top_at_1, & ! --- inputs
- olyr) ! --- outputs
+ call ozphys%run_o3clim(xlat, prslk1, con_pi, olyr)
endif ! end_if_ntoz
!> - Call coszmn(), to compute cosine of zenith angle (only when SW is called)
diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta
index a8aecdbe0..a29b0ac3c 100644
--- a/physics/GFS_rrtmg_pre.meta
+++ b/physics/GFS_rrtmg_pre.meta
@@ -2,7 +2,7 @@
name = GFS_rrtmg_pre
type = scheme
dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90
- dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f
+ dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f,module_ozphys.F90
dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90
########################################################################
@@ -247,6 +247,13 @@
dimensions = ()
type = integer
intent = in
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = in
[iaermdl]
standard_name = control_for_aerosol_radiation_scheme
long_name = control of aerosol scheme in radiation
diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90
index 80c033bf1..cc8e950e8 100644
--- a/physics/GFS_rrtmg_setup.F90
+++ b/physics/GFS_rrtmg_setup.F90
@@ -7,7 +7,7 @@
module GFS_rrtmg_setup
use machine, only: kind_phys
-
+ use module_ozphys, only: ty_ozphys
implicit none
public GFS_rrtmg_setup_init, GFS_rrtmg_setup_timestep_init, GFS_rrtmg_setup_finalize
@@ -218,8 +218,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, &
con_pi )
call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, &
con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg)
- call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, &
- con_pi, errflg, errmsg)
+ call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, con_pi, errflg, errmsg )
call cld_init ( si, levr, imp_physics, me, con_g, con_rd, errflg, errmsg)
call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, &
iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, &
@@ -245,7 +244,8 @@ end subroutine GFS_rrtmg_setup_init
!!
subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, &
lsswr, me, iaermdl, iaerflg, isol, aeros_file, slag, sdec, cdec, &
- solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, errmsg, errflg)
+ solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, ozphys,&
+ errmsg, errflg)
implicit none
@@ -258,6 +258,7 @@ subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, &
logical, intent(in) :: lsswr
integer, intent(in) :: me
integer, intent(in) :: iaermdl, iaerflg, isol, ictm, ico2, ntoz
+ type(ty_ozphys), intent(inout) :: ozphys
character(len=26), intent(in) :: aeros_file, co2dat_file, co2gbl_file
real(kind=kind_phys), intent(out) :: slag
real(kind=kind_phys), intent(out) :: sdec
@@ -278,7 +279,7 @@ subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, &
errflg = 0
call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl, iaerflg,isol,aeros_file,&
- slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,errflg,errmsg)
+ slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,ozphys,errflg,errmsg)
end subroutine GFS_rrtmg_setup_timestep_init
@@ -326,7 +327,7 @@ end subroutine GFS_rrtmg_setup_finalize
!-----------------------------------
subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,&
iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, con_pi, &
- co2dat_file,co2gbl_file, ictm, ico2, ntoz, errflg, errmsg)
+ co2dat_file,co2gbl_file, ictm, ico2, ntoz, ozphys, errflg, errmsg)
!...................................
! ================= subprogram documentation block ================ !
@@ -370,6 +371,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,&
! --- inputs:
integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol, ictm, ntoz, ico2
+ type(ty_ozphys),intent(inout) :: ozphys
logical, intent(in) :: lsswr
character(len=26),intent(in) :: aeros_file,co2dat_file,co2gbl_file
@@ -462,8 +464,11 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,&
lco2_chg = .false.
endif
- call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, co2dat_file, &
- co2gbl_file, ictm, ico2, ntoz, errflg, errmsg )
+ call gas_update ( kyear,kmon,kday,khour,lco2_chg, me, co2dat_file, &
+ co2gbl_file, ictm, ico2, errflg, errmsg )
+ if (ntoz == 0) then
+ call ozphys%update_o3clim(kmon, kday, khour, loz1st)
+ endif
if ( loz1st ) loz1st = .false.
diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta
index adf6d8750..35713757b 100644
--- a/physics/GFS_rrtmg_setup.meta
+++ b/physics/GFS_rrtmg_setup.meta
@@ -2,7 +2,7 @@
name = GFS_rrtmg_setup
type = scheme
dependencies = iounitdef.f,module_bfmicrophysics.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f
- dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F
+ dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F,module_ozphys.F90
########################################################################
[ccpp-arg-table]
@@ -509,6 +509,13 @@
dimensions = ()
type = integer
intent = in
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = inout
[con_pi]
standard_name = pi
long_name = ratio of a circle's circumference to its diameter
diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90
index 009eb8c38..cbf8d161b 100644
--- a/physics/GFS_rrtmgp_pre.F90
+++ b/physics/GFS_rrtmgp_pre.F90
@@ -8,7 +8,8 @@ module GFS_rrtmgp_pre
use machine, only: kind_phys
use funcphys, only: fpvs
use module_radiation_astronomy, only: coszmn
- use module_radiation_gases, only: NF_VGAS, getgases, getozn
+ use module_radiation_gases, only: NF_VGAS, getgases
+ use module_ozphys, only: ty_ozphys
use mo_gas_concentrations, only: ty_gas_concs
use radiation_tools, only: check_error_msg,cmp_tlev
use rrtmgp_lw_gas_optics, only: lw_gas_props
@@ -117,15 +118,17 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl
vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, &
relhum, deltaZ, deltaZc, deltaP, active_gases_array, &
tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, &
- sfc_emiss_byband, ico2, con_pi, errmsg, errflg)
+ sfc_emiss_byband, ico2, ozphys, con_pi, errmsg, errflg)
- ! Inputs
+ ! Inputs
integer, intent(in) :: &
me, & ! MPI rank
nCol, & ! Number of horizontal grid points
nLev, & ! Number of vertical layers
ico2, & ! Flag for co2 radiation scheme
i_o3 ! Index into tracer array for ozone
+ type(ty_ozphys),intent(in) :: &
+ ozphys
logical, intent(in) :: &
doSWrad, & ! Call SW radiation?
doLWrad ! Call LW radiation
@@ -349,8 +352,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl
enddo
enddo
! OR Use climatological ozone data
- else
- call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, o3_lay)
+ else
+ call ozphys%run_o3clim(xlat, prslk, con_pi, o3_lay)
endif
! #######################################################################################
diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta
index abb07b825..4e2aa3a56 100644
--- a/physics/GFS_rrtmgp_pre.meta
+++ b/physics/GFS_rrtmgp_pre.meta
@@ -2,7 +2,7 @@
name = GFS_rrtmgp_pre
type = scheme
dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_aerosols.f
- dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90
+ dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90,module_ozphys.F90
########################################################################
[ccpp-arg-table]
@@ -503,6 +503,13 @@
dimensions = (horizontal_loop_extent)
type = integer
intent = inout
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90
index 3e90cc96b..2739c951b 100644
--- a/physics/GFS_rrtmgp_setup.F90
+++ b/physics/GFS_rrtmgp_setup.F90
@@ -6,6 +6,7 @@ module GFS_rrtmgp_setup
use module_radiation_astronomy, only : sol_init, sol_update
use module_radiation_aerosols, only : aer_init, aer_update
use module_radiation_gases, only : gas_init, gas_update
+ use module_ozphys, only : ty_ozphys
implicit none
public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize
@@ -37,9 +38,10 @@ module GFS_rrtmgp_setup
subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, &
imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, &
imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, &
- ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, me, aeros_file, &
- iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, solar_file, &
- con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, errmsg, errflg)
+ ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, &
+ me, aeros_file, iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, &
+ solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, &
+ errmsg, errflg)
! Inputs
logical, intent(in) :: do_RRTMGP
@@ -56,9 +58,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires,
con_pi, con_t0c, con_c, con_boltz, con_plnk, con_solr_2008, con_solr_2002
real(kind_phys), dimension(:), intent(in) :: &
si
- integer, intent(in) :: levr, ictm, isol, ico2, iaer, &
- ntcw, ntoz, iovr, isubc_sw, isubc_lw, &
- me
+ integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, ntoz, iovr, isubc_sw, isubc_lw, me
logical, intent(in) :: &
lalw1bd
integer, intent(in), dimension(:) :: &
@@ -129,7 +129,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires,
call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi )
call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, &
con_c, con_boltz, con_plnk, errflg, errmsg)
- call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, errflg, errmsg )
+ call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, con_pi, errflg, errmsg )
if ( me == 0 ) then
print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit'
@@ -148,7 +148,7 @@ end subroutine GFS_rrtmgp_setup_init
!!
subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, &
iaermdl, aeros_file, isol, slag, sdec, cdec, solcon, con_pi, co2dat_file, &
- co2gbl_file, ictm, ico2, ntoz, errmsg, errflg)
+ co2gbl_file, ictm, ico2, ntoz, ozphys, errmsg, errflg)
! Inputs
integer, intent(in) :: idate(:)
@@ -160,7 +160,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad
integer, intent(in) :: me
integer, intent(in) :: iaermdl,isol,ictm,ico2,ntoz
character(len=26), intent(in) :: aeros_file,co2dat_file,co2gbl_file
-
+ type(ty_ozphys),intent(inout) :: ozphys
! Outputs
real(kind_phys), intent(out) :: slag
real(kind_phys), intent(out) :: sdec
@@ -240,8 +240,11 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad
else
lco2_chg = .false.
endif
- call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, co2dat_file, &
- co2gbl_file, ictm, ico2, ntoz, errflg, errmsg )
+ call gas_update (kyear, kmon, kday, khour, lco2_chg, me, co2dat_file, co2gbl_file, ictm,&
+ ico2, errflg, errmsg )
+ if (ntoz == 0) then
+ call ozphys%update_o3clim(kmon, kday, khour, loz1st)
+ endif
if ( loz1st ) loz1st = .false.
diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta
index c4f7cfaa5..96f7e24e7 100644
--- a/physics/GFS_rrtmgp_setup.meta
+++ b/physics/GFS_rrtmgp_setup.meta
@@ -2,7 +2,7 @@
name = GFS_rrtmgp_setup
type = scheme
dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f
- dependencies = module_mp_thompson.F90,radiation_gases.f
+ dependencies = module_mp_thompson.F90,radiation_gases.f,module_ozphys.F90
########################################################################
[ccpp-arg-table]
@@ -389,6 +389,13 @@
dimensions = ()
type = integer
intent = in
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = inout
[iaermdl]
standard_name = control_for_aerosol_radiation_scheme
long_name = control of aerosol scheme in radiation
diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/GFS_suite_stateout_update.F90
index 2771c3e82..e9e477fce 100644
--- a/physics/GFS_suite_stateout_update.F90
+++ b/physics/GFS_suite_stateout_update.F90
@@ -1,63 +1,91 @@
+! #########################################################################################
!> \file GFS_suite_stateout_update.f90
-!! Contains code to update the state variables due to process-split physics from accumulated tendencies during that phase.
+!! Update the state variables due to process-split physics from accumulated tendencies
+!! during that phase.
+!! Update gas concentrations, if using prognostic photolysis schemes.
!! Also, set bounds on the mass-weighted rime factor when using Ferrier-Aligo microphysics.
-
- module GFS_suite_stateout_update
-
- contains
-
+! #########################################################################################
+module GFS_suite_stateout_update
+ use machine, only: kind_phys
+ use module_ozphys, only: ty_ozphys
+ implicit none
+contains
+! #########################################################################################
!> \section arg_table_GFS_suite_stateout_update_run Argument Table
!! \htmlinclude GFS_suite_stateout_update_run.html
!!
- subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, &
- tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, &
- gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, &
- imp_physics_fer_hires, epsq, errmsg, errflg)
-
- use machine, only: kind_phys
-
- implicit none
-
- ! Interface variables
- integer, intent(in ) :: im
- integer, intent(in ) :: levs
- integer, intent(in ) :: ntrac
- integer, intent(in ) :: imp_physics,imp_physics_fer_hires
- integer, intent(in ) :: ntiw, nqrimef
- real(kind=kind_phys), intent(in ) :: dtp, epsq
-
- real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs
- real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs
- real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt
- real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt
- real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0
- real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- integer :: i, k
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp
- gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp
- gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp
- gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp
-
- if (imp_physics == imp_physics_fer_hires) then
+! #########################################################################################
+ subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, tgrs, ugrs, vgrs, qgrs, &
+ dudt, dvdt, dtdt, dqdt, gt0, gu0, gv0, gq0, oz0, ntiw, nqrimef, imp_physics, &
+ imp_physics_fer_hires, epsq, ozphys, oz_phys_2015, oz_phys_2006, con_1ovg, prsl, &
+ dp, ozpl, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg)
+
+ ! Inputs
+ integer, intent(in ) :: im
+ integer, intent(in ) :: levs
+ integer, intent(in ) :: ntrac
+ integer, intent(in ) :: imp_physics,imp_physics_fer_hires
+ integer, intent(in ) :: ntiw, nqrimef
+ real(kind=kind_phys), intent(in ) :: dtp, epsq, con_1ovg
+ real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs, prsl, dp
+ real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs, ozpl
+ real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt
+ real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt
+ logical, intent(in) :: oz_phys_2015
+ logical, intent(in) :: oz_phys_2006
+ type(ty_ozphys), intent(in) :: ozphys
+
+ ! Outputs (optional)
+ real(kind=kind_phys), intent(inout), dimension(:,:), pointer, optional :: &
+ do3_dt_prd, & ! Physics tendency: production and loss effect
+ do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect
+ do3_dt_temp, & ! Physics tendency: temperature effect
+ do3_dt_ohoz ! Physics tendency: overhead ozone effect
+
+ ! Outputs
+ real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0, oz0
+ real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0
+ character(len=*), intent(out) :: errmsg
+ integer, intent(out) :: errflg
+
+ ! Locals
+ integer :: i, k
+
+ ! Initialize CCPP error handling variables
+ errmsg = ''
+ errflg = 0
+
+ ! Update prognostic state varaibles using accumulated tendencies from "process-split"
+ ! section of GFS suite.
+ gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp
+ gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp
+ gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp
+ gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp
+
+ ! If using photolysis physics schemes, update (prognostic) gas concentrations using
+ ! updated state.
+ if (oz_phys_2015) then
+ call ozphys%run_o3prog_2015(con_1ovg, dtp, prsl, gt0, dp, ozpl, oz0, do3_dt_prd, &
+ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz)
+ endif
+ if (oz_phys_2006) then
+ call ozphys%run_o3prog_2006(con_1ovg, dtp, prsl, gt0, dp, ozpl, oz0, do3_dt_prd, &
+ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz)
+ endif
+
+ ! If using Ferrier-Aligo microphysics, set bounds on the mass-weighted rime factor.
+ if (imp_physics == imp_physics_fer_hires) then
do k=1,levs
- do i=1,im
- if(gq0(i,k,ntiw) > epsq) then
- gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw))
- else
- gq0(i,k,nqrimef) = 1.
- end if
- end do
+ do i=1,im
+ if(gq0(i,k,ntiw) > epsq) then
+ gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw))
+ else
+ gq0(i,k,nqrimef) = 1.
+ end if
+ end do
end do
- end if
+ end if
- end subroutine GFS_suite_stateout_update_run
+ end subroutine GFS_suite_stateout_update_run
- end module GFS_suite_stateout_update
\ No newline at end of file
+end module GFS_suite_stateout_update
diff --git a/physics/GFS_suite_stateout_update.meta b/physics/GFS_suite_stateout_update.meta
index 580482b71..fae276d2f 100644
--- a/physics/GFS_suite_stateout_update.meta
+++ b/physics/GFS_suite_stateout_update.meta
@@ -2,7 +2,7 @@
[ccpp-table-properties]
name = GFS_suite_stateout_update
type = scheme
- dependencies = machine.F
+ dependencies = machine.F,module_ozphys.F90
########################################################################
[ccpp-arg-table]
@@ -37,6 +37,27 @@
type = real
kind = kind_phys
intent = in
+[ozphys]
+ standard_name = dataset_for_ozone_physics
+ long_name = dataset for NRL ozone physics
+ units = mixed
+ dimensions = ()
+ type = ty_ozphys
+ intent = in
+[oz_phys_2015]
+ standard_name = flag_for_nrl_2015_ozone_scheme
+ long_name = flag for new (2015) ozone physics
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
+[oz_phys_2006]
+ standard_name = flag_for_nrl_2006_ozone_scheme
+ long_name = flag for new (2006) ozone physics
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[tgrs]
standard_name = air_temperature
long_name = model layer mean temperature
@@ -133,6 +154,14 @@
type = real
kind = kind_phys
intent = out
+[oz0]
+ standard_name = ozone_concentration_of_new_state
+ long_name = ozone concentration updated by physics
+ units = kg kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
[ntiw]
standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array
long_name = tracer index for ice water
@@ -169,6 +198,70 @@
type = real
kind = kind_phys
intent = in
+[con_1ovg]
+ standard_name = one_divided_by_the_gravitational_acceleration
+ long_name = inverse of gravitational acceleration
+ units = s2 m-1
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[prsl]
+ standard_name = air_pressure
+ long_name = mid-layer pressure
+ units = Pa
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = in
+[ozpl]
+ standard_name = ozone_forcing
+ long_name = ozone forcing data
+ units = mixed
+ dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data)
+ type = real
+ kind = kind_phys
+ intent = in
+[dp]
+ standard_name = air_pressure_difference_between_midlayers
+ long_name = difference between mid-layer pressures
+ units = Pa
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = in
+[do3_dt_prd]
+ standard_name = ozone_tendency_due_to_production_and_loss_rate
+ long_name = ozone tendency due to production and loss rate
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[do3_dt_ozmx]
+ standard_name = ozone_tendency_due_to_ozone_mixing_ratio
+ long_name = ozone tendency due to ozone mixing ratio
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[do3_dt_temp]
+ standard_name = ozone_tendency_due_to_temperature
+ long_name = ozone tendency due to temperature
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[do3_dt_ohoz]
+ standard_name = ozone_tendency_due_to_overhead_ozone_column
+ long_name = ozone tendency due to overhead ozone column
+ units = kg kg-1 s-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90
index 98b9fecd2..fd16dea59 100644
--- a/physics/GFS_surface_composites_pre.F90
+++ b/physics/GFS_surface_composites_pre.F90
@@ -241,8 +241,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, iopt_lake, iopt_l
!mjz
tsfcl(i) = huge
endif
+ if (icy(i) .or. wet(i)) then ! init uustar_ice for all water/ice grids
+ uustar_ice(i) = uustar(i)
+ endif
if (icy(i)) then ! Ice
- uustar_ice(i) = uustar(i)
is_clm = lkm>0 .and. iopt_lake==iopt_lake_clm .and. use_lake_model(i)>0
if(lsm /= lsm_ruc .and. .not.is_clm) then
weasd_ice(i) = weasd(i)
diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90
index 620f79a96..91e8c71b7 100644
--- a/physics/clm_lake.f90
+++ b/physics/clm_lake.f90
@@ -238,7 +238,10 @@ subroutine calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake,dz_lake)
real(kind_lake) :: dz_lake(nlevlake) ! layer thickness for lake (m)
real(kind_lake) :: depthratio
- if (input_lakedepth(i) == spval) then
+ if (input_lakedepth(i) == spval .or. input_lakedepth(i) < 0.1) then
+ ! This is a safeguard against:
+ ! 1. missing in the lakedepth database (== spval)
+ ! 2. errors in model cycling or unexpected changes in the orography database (< 0.1)
clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake)
z_lake(1:nlevlake) = zlak(1:nlevlake)
dz_lake(1:nlevlake) = dzlak(1:nlevlake)
@@ -267,8 +270,8 @@ SUBROUTINE clm_lake_run( &
! Atmospheric model state inputs:
tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, &
- ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, rho0, tsfc, &
- flag_iter, ISLTYP, rainncprv, raincprv, &
+ ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, tsfc, &
+ flag_iter, flag_lakefreeze, ISLTYP, rainncprv, raincprv, &
! Feedback to atmosphere:
evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, &
@@ -283,7 +286,7 @@ SUBROUTINE clm_lake_run( &
salty, savedtke12d, snowdp2d, h2osno2d, snl2d, t_grnd2d, t_lake3d, &
lake_icefrac3d, t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, &
- z3d, dz3d, zi3d, &
+ z3d, dz3d, zi3d, t1, qv1, prsl1, &
input_lakedepth, clm_lakedepth, cannot_freeze, &
! Error reporting:
@@ -321,10 +324,12 @@ SUBROUTINE clm_lake_run( &
!
REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: &
tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, &
- dlwsfci, dswsfci, oro_lakedepth, wind, rho0, &
- rainncprv, raincprv
+ dlwsfci, dswsfci, oro_lakedepth, wind, &
+ rainncprv, raincprv, t1, qv1, prsl1
REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii
LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter
+ LOGICAL, DIMENSION(:), INTENT(INOUT) :: flag_lakefreeze
+
INTEGER, DIMENSION(:), INTENT(IN) :: ISLTYP
!
@@ -450,6 +455,7 @@ SUBROUTINE clm_lake_run( &
logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE
real(kind_lake) :: to_radians, lat_d, lon_d, qss, tkm, bd
+ real(kind_lake) :: rho0 ! lowest model level air density
integer :: month,num1,num2,day_of_month,isl
real(kind_lake) :: wght1,wght2,Tclim,depthratio
@@ -693,12 +699,13 @@ SUBROUTINE clm_lake_run( &
!-- The CLM output is combined for fractional ice and water
if( t_grnd(c) >= tfrz ) then
- qfx = eflx_lh_tot(c)*invhvap
+ qfx = eflx_lh_tot(c)*invhvap
else
- qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2))
+ qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2))
endif
- evap_wat(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water
- hflx_wat(i)=eflx_sh_tot(c)/(rho0(i)*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water
+ rho0 = prsl1(i) / (rair*t1(i)*(1.0 + con_fvirt*qv1(i)))
+ evap_wat(i) = qfx/rho0 ! kinematic_surface_upward_latent_heat_flux_over_water
+ hflx_wat(i) = eflx_sh_tot(c)/(rho0*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water
gflx_wat(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water
ep1d_water(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water
tsurf_water(I) = t_grnd(c) ![K] surface skin temperature after iteration over water
@@ -754,6 +761,11 @@ SUBROUTINE clm_lake_run( &
weasd(i) = weasdi(i)
snowd(i) = snodi(c) ! surface_snow_thickness_water_equivalent_over_ice
+
+ if (.not. icy(i)) then
+ flag_lakefreeze(i)=.true.
+ end if
+
! Ice points are icy:
icy(i)=.true. ! flag_nonzero_sea_ice_surface_fraction
ice_points = ice_points+1
diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta
index 11a44286a..373bfc308 100644
--- a/physics/clm_lake.meta
+++ b/physics/clm_lake.meta
@@ -305,14 +305,6 @@
type = real
kind = kind_phys
intent = in
-[rho0]
- standard_name = air_pressure_at_surface_adjacent_layer
- long_name = mean pressure at lowest model layer
- units = Pa
- dimensions = (horizontal_loop_extent)
- type = real
- kind = kind_phys
- intent = in
[tsfc]
standard_name = surface_skin_temperature
long_name = surface skin temperature
@@ -328,6 +320,13 @@
dimensions = (horizontal_loop_extent)
type = logical
intent = in
+[flag_lakefreeze]
+ standard_name = flag_for_lake_water_freeze
+ long_name = flag for lake water freeze
+ units = flag
+ dimensions = (horizontal_loop_extent)
+ type = logical
+ intent = inout
[isltyp]
standard_name = soil_type_classification
long_name = soil type at each grid cell
@@ -732,6 +731,30 @@
type = real
kind = kind_phys
intent = in
+[t1]
+ standard_name = air_temperature_at_surface_adjacent_layer
+ long_name = mean temperature at lowest model layer
+ units = K
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = in
+[qv1]
+ standard_name = specific_humidity_at_surface_adjacent_layer
+ long_name = water vapor specific humidity at lowest model layer
+ units = kg kg-1
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = in
+[prsl1]
+ standard_name = air_pressure_at_surface_adjacent_layer
+ long_name = mean pressure at lowest model layer
+ units = Pa
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90
index 7092840c3..b7cd5f62d 100644
--- a/physics/cu_c3_deep.F90
+++ b/physics/cu_c3_deep.F90
@@ -97,6 +97,9 @@ subroutine cu_c3_deep_run( &
,tmf & ! instantanious tendency from turbulence
,qmicro & ! instantanious tendency from microphysics
,forceqv_spechum & !instantanious tendency from dynamics
+ ,betascu & ! Tuning parameter for shallow clouds
+ ,betamcu & ! Tuning parameter for mid-level clouds
+ ,betadcu & ! Tuning parameter for deep clouds
,sigmain & ! input area fraction after advection
,sigmaout & ! updated prognostic area fraction
,z1 & ! terrain
@@ -233,8 +236,8 @@ subroutine cu_c3_deep_run( &
real(kind=kind_phys) &
- ,intent (in ) :: &
- dtime,ccnclean,fv,r_d
+ ,intent (in ) :: &
+ dtime,ccnclean,fv,r_d,betascu,betamcu,betadcu
!
@@ -386,13 +389,16 @@ subroutine cu_c3_deep_run( &
real(kind=kind_phys), dimension (its:ite) :: pefc
real(kind=kind_phys) entdo,dp,subin,detdo,entup, &
detup,subdown,entdoj,entupk,detupk,totmas
+ real(kind=kind_phys) :: &
+ sigmind,sigminm,sigmins
+ parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01)
real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec
!$acc declare create(lambau,flux_tun,zws,ztexec,zqexec)
integer :: jprnt,jmini,start_k22
logical :: keep_going,flg(its:ite),cnvflg(its:ite)
- logical :: flag_shallow
+ logical :: flag_shallow,flag_mid
!$acc declare create(flg)
@@ -1988,7 +1994,11 @@ subroutine cu_c3_deep_run( &
! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget
if(progsigma)then
+ flag_mid = .false.
flag_shallow = .false.
+ if(imid.eq.1)then
+ flag_mid = .true.
+ endif
do k=kts,ktf
do i=its,itf
del(i,k) = delp(i,k)*0.001
@@ -2003,9 +2013,9 @@ subroutine cu_c3_deep_run( &
endif
enddo
call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, &
- del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, &
- forceqv_spechum,kbcon,ktop,cnvflg, &
- sigmain,sigmaout,sigmab)
+ flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, &
+ forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, &
+ sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab)
endif
!$acc end kernels
@@ -3147,7 +3157,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
! pcrit,acrit,acritt
integer, dimension (its:ite) :: kloc
real(kind=kind_phys) :: &
- a1,a_ave,xff0,xomg,gravinv!,aclim1,aclim2,aclim3,aclim4
+ a1,a_ave,xff0,xomg,gravinv
real(kind=kind_phys), dimension (its:ite) :: ens_adj
!$acc declare create(kloc,ens_adj)
diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90
index 8592e08f9..c911ff5e4 100644
--- a/physics/cu_c3_driver.F90
+++ b/physics/cu_c3_driver.F90
@@ -30,7 +30,8 @@ module cu_c3_driver
!! \htmlinclude cu_c3_driver_init.html
!!
subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, &
- imfdeepcnv_c3,mpirank, mpiroot, errmsg, errflg)
+ imfdeepcnv_c3,progsigma, cnx, mpirank, mpiroot, &
+ errmsg, errflg)
implicit none
@@ -38,6 +39,8 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, &
integer, intent(in) :: imfdeepcnv, imfdeepcnv_c3
integer, intent(in) :: mpirank
integer, intent(in) :: mpiroot
+ integer, intent(in) :: cnx
+ logical, intent(inout) :: progsigma
character(len=*), intent( out) :: errmsg
integer, intent( out) :: errflg
@@ -45,6 +48,13 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, &
errmsg = ''
errflg = 0
+ if(progsigma)then
+ if(cnx < 384)then
+ progsigma=.false.
+ write(*,*)'Forcing prognostic closure to .false. due to coarse resolution'
+ endif
+ endif
+
end subroutine cu_c3_driver_init
!
@@ -60,7 +70,8 @@ end subroutine cu_c3_driver_init
subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,&
do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, &
forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, &
- qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, &
+ betascu,betamcu,betadcu,qv_spechum,t,cld1d,us,vs,t2di,w, &
+ qv2di_spechum,p2di,psuri, &
hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,&
pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, &
flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, &
@@ -96,10 +107,10 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,&
integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in
logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf
logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, &
- do_ca,progsigma
- real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v
+ do_ca
+ real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v,betascu,betamcu,betadcu
logical, intent(in ) :: ldiag3d
-
+ logical, intent(in ) :: progsigma
real(kind=kind_phys), intent(inout) :: dtend(:,:,:)
!$acc declare copy(dtend)
integer, intent(in) :: dtidx(:,:), &
@@ -587,7 +598,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,&
hfx(i)=hfx2(i)*cp*rhoi(i,1)
qfx(i)=qfx2(i)*xlv*rhoi(i,1)
dx(i) = sqrt(garea(i))
- enddo
+ enddo
do i=its,itf
do k=kts,kpbli(i)
@@ -669,7 +680,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,&
zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, &
! Prog closure
flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, &
- forceqv_spechum,sigmain,sigmaout,progsigma,dx, &
+ forceqv_spechum,betascu,betamcu,betadcu,sigmain, &
+ sigmaout,progsigma,dx, &
! output tendencies
outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, &
! dimesnional variables
@@ -714,6 +726,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,&
,tmfq &
,qmicro &
,forceqv_spechum &
+ ,betascu &
+ ,betamcu &
+ ,betadcu &
,sigmain &
,sigmaout &
,ter11 &
@@ -805,6 +820,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,&
,tmfq &
,qmicro &
,forceqv_spechum &
+ ,betascu &
+ ,betamcu &
+ ,betadcu &
,sigmain &
,sigmaout &
,ter11 &
diff --git a/physics/cu_c3_driver.meta b/physics/cu_c3_driver.meta
index 999b5c2bc..801b1e9d7 100644
--- a/physics/cu_c3_driver.meta
+++ b/physics/cu_c3_driver.meta
@@ -49,6 +49,20 @@
dimensions = ()
type = integer
intent = in
+[progsigma]
+ standard_name = do_prognostic_updraft_area_fraction
+ long_name = flag for prognostic sigma in cumuls scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = inout
+[cnx]
+ standard_name = number_of_x_points_for_current_cubed_sphere_tile
+ long_name = number of points in x direction for this cubed sphere face
+ units = count
+ dimensions = ()
+ type = integer
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
@@ -244,6 +258,29 @@
type = real
kind = kind_phys
intent = out
+[betascu]
+ standard_name = tuning_param_for_shallow_cu
+ long_name = tuning param for shallow cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[betamcu]
+ standard_name = tuning_param_for_midlevel_cu
+ long_name = tuning param for midlevel cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[betadcu]
+ standard_name = tuning_param_for_deep_cu
+ long_name = tuning param for deep cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ intent = in
[phil]
standard_name = geopotential
long_name = layer geopotential
diff --git a/physics/cu_c3_sh.F90 b/physics/cu_c3_sh.F90
index a79e1dfcf..736292092 100644
--- a/physics/cu_c3_sh.F90
+++ b/physics/cu_c3_sh.F90
@@ -68,7 +68,8 @@ subroutine cu_c3_sh_run ( &
hfx,qfx,xland,ichoice,tcrit,dtime, &
zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, &
flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, &
- forceqv_spechum,sigmain,sigmaout,progsigma,dx, &
+ forceqv_spechum,betascu,betamcu,betadcu,sigmain,&
+ sigmaout,progsigma,dx, &
outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies
itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables
!
@@ -131,7 +132,7 @@ subroutine cu_c3_sh_run ( &
real(kind=kind_phys) &
,intent (in ) :: &
- dtime,tcrit,fv,r_d
+ dtime,tcrit,fv,r_d,betascu,betamcu,betadcu
!$acc declare sigmaout
real(kind=kind_phys), dimension (its:,kts:) &
,intent (out) :: &
@@ -234,15 +235,18 @@ subroutine cu_c3_sh_run ( &
!$acc cap_max_increment,lambau, &
!$acc kstabi,xland1,kbmax,ktopx)
- logical :: flag_shallow
+ logical :: flag_shallow,flag_mid
logical, dimension(its:ite) :: cnvflg
integer :: &
kstart,i,k,ki
- real(kind=kind_phys) :: &
+ real(kind=kind_phys) :: &
dz,mbdt,zkbmax, &
cap_maxs,trash,trash2,frh,el2orc,gravinv
- real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas
+ real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas
+ real(kind=kind_phys) :: &
+ sigmind,sigminm,sigmins
+ parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01)
real(kind=kind_phys) xff_shal(3),blqe,xkshal
character*50 :: ierrc(its:)
@@ -672,13 +676,13 @@ subroutine cu_c3_sh_run ( &
dz=z_cup(i,k)-z_cup(i,k-1)
! cloud liquid water
c1d(i,k)=c1_shal! 0. !.02*up_massdetr(i,k-1)
+ clw_all(i,k)=max(0._kind_phys,qco(i,k)-trash)
qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz)
if(qrco(i,k).lt.0.)then ! hli new test 02/12/19
qrco(i,k)=0.
!c1d(i,k)=0.
endif
pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k)
- clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain
! cloud water vapor
qco (i,k)= trash+qrco(i,k)
@@ -960,6 +964,7 @@ subroutine cu_c3_sh_run ( &
! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget
if(progsigma)then
flag_shallow = .true.
+ flag_mid = .false.
do k=kts,ktf
do i=its,itf
del(i,k) = delp(i,k)*0.001
@@ -974,9 +979,9 @@ subroutine cu_c3_sh_run ( &
endif
enddo
call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, &
- del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, &
- forceqv_spechum,kbcon,ktop,cnvflg, &
- sigmain,sigmaout,sigmab)
+ flag_mid,del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, &
+ forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, &
+ sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab)
endif
diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90
index 5adf3ac42..111bf0863 100644
--- a/physics/cu_gf_driver_post.F90
+++ b/physics/cu_gf_driver_post.F90
@@ -15,7 +15,7 @@ module cu_gf_driver_post
!> \section arg_table_cu_gf_driver_post_run Argument Table
!! \htmlinclude cu_gf_driver_post_run.html
!!
- subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m,dt, garea, raincv, maxupmf, refl_10cm, errmsg, errflg)
+ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg)
use machine, only: kind_phys
@@ -25,25 +25,17 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m
integer, intent(in) :: im, km
real(kind_phys), intent(in) :: t(:,:)
real(kind_phys), intent(in) :: q(:,:)
- real(kind_phys), dimension(:),intent(in) :: garea
real(kind_phys), intent(out) :: prevst(:,:)
real(kind_phys), intent(out) :: prevsq(:,:)
integer, intent(in) :: cactiv(:)
integer, intent(in) :: cactiv_m(:)
real(kind_phys), intent(out) :: conv_act(:)
real(kind_phys), intent(out) :: conv_act_m(:)
- ! for Radar reflectivity
- real(kind_phys), intent(in) :: dt
- real(kind_phys), intent(in) :: raincv(:), maxupmf(:)
- real(kind_phys), intent(inout) :: refl_10cm(:,:)
character(len=*), intent(out) :: errmsg
!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m)
integer, intent(out) :: errflg
! Local variables
- real(kind_phys), parameter :: dbzmin=-10.0
- real(kind_phys) :: cuprate
- real(kind_phys) :: ze, ze_conv, dbz_sum
integer :: i, k
! Initialize CCPP error handling variables
@@ -65,20 +57,6 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m
else
conv_act_m(i)=0.0
endif
- ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f)
- ze = 0.0
- ze_conv = 0.0
- dbz_sum = 0.0
- cuprate = 1.e3*raincv(i) * 3600.0 / dt ! cu precip rate (mm/h)
- if(cuprate .lt. 0.05) cuprate=0.
- ze_conv = 300.0 * cuprate**1.5
- if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then
- do k = 1, km
- ze = 10._kind_phys ** (0.1 * refl_10cm(i,k))
- dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv))
- refl_10cm(i,k) = dbz_sum
- enddo
- endif
enddo
!$acc end kernels
diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta
index 48e762cb4..6c6ceeb66 100644
--- a/physics/cu_gf_driver_post.meta
+++ b/physics/cu_gf_driver_post.meta
@@ -83,46 +83,6 @@
type = real
kind = kind_phys
intent = out
-[dt]
- standard_name = timestep_for_physics
- long_name = physics time step
- units = s
- dimensions = ()
- type = real
- kind = kind_phys
- intent = in
-[garea]
- standard_name = cell_area
- long_name = grid cell area
- units = m2
- dimensions = (horizontal_loop_extent)
- type = real
- kind = kind_phys
- intent = in
-[raincv]
- standard_name = lwe_thickness_of_deep_convective_precipitation_amount
- long_name = deep convective rainfall amount on physics timestep
- units = m
- dimensions = (horizontal_loop_extent)
- type = real
- kind = kind_phys
- intent = in
-[maxupmf]
- standard_name = maximum_convective_updraft_mass_flux
- long_name = maximum convective updraft mass flux within a column
- units = m s-1
- dimensions = (horizontal_loop_extent)
- type = real
- kind = kind_phys
- intent = in
-[refl_10cm]
- standard_name = radar_reflectivity_10cm
- long_name = instantaneous refl_10cm
- units = dBZ
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = inout
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/docs/library.bib b/physics/docs/library.bib
index 34bb54e8f..4260fc3c2 100644
--- a/physics/docs/library.bib
+++ b/physics/docs/library.bib
@@ -3760,8 +3760,6 @@ @inproceedings{yudin_et_al_2019
@article{mansell_2013,
author = {Edward R. Mansell and Conrad L. Ziegler},
- date-added = {2015-02-26 22:32:59 +0000},
- date-modified = {2020-02-10 23:06:41 +0000},
doi = {10.1175/JAS-D-12-0264.1},
journal = {Journal of the Atmospheric Sciences},
keywords = {storm electrification, microphysics 2-moment},
@@ -3774,8 +3772,6 @@ @article{mansell_2013
@article{mansell_2010,
author = {Edward R. Mansell},
- date-added = {2011-02-22 10:34:11 -0600},
- date-modified = {2011-02-22 10:35:34 -0600},
doi = {10.1175/2010JAS3341.1},
journal = {Journal of the Atmospheric Sciences},
keywords = {advection, microphysics 2-moment},
@@ -3787,8 +3783,6 @@ @article{mansell_2010
@article{mansell_etal_2010,
author = {E. R. Mansell and C. L. Ziegler and E. C. Bruning},
- date-added = {2007-08-20 15:44:13 -0500},
- date-modified = {2010-04-13 16:55:16 -0500},
doi = {10.1175/2009JAS2965.1},
journal = {Journal of the Atmospheric Sciences},
keywords = {storm electrification, microphysics 2-moment},
@@ -3798,6 +3792,17 @@ @article{mansell_etal_2010
year = {2010},
bdsk-url-1 = {https://doi.org/10.1175/2009JAS2965.1}}
+@article{mansell:2020,
+ Author = {Edward R. Mansell and Dawson, II, Daniel T. and Jerry M. Straka},
+ Doi = {10.1175/JAS-D-19-0268.1},
+ Journal = jas,
+ Keywords = {microphysics 3-moment},
+ Pages = {3361-3385},
+ Title = {Bin-emulating Hail Melting in 3-moment bulk microphysics},
+ Volume = {77},
+ Year = {2020},
+ Bdsk-Url-1 = {https://dx.doi.org/10.1175/JAS-D-12-0264.1},
+
@inproceedings{yudin_et_al_2020,
author = {Yudin, V. A. and Yang, F. and Karol, S. I. and Fuller-Rowell T. J. and Kubaryk, A. and Juang, H. and Kar, S. and Alpert, J. C. and Li, Z.},
booktitle = {1st UFS Users' Workshop},
diff --git a/physics/docs/pdftxt/NSSLMICRO.txt b/physics/docs/pdftxt/NSSLMICRO.txt
index 3d35c9fd2..44d1f069b 100644
--- a/physics/docs/pdftxt/NSSLMICRO.txt
+++ b/physics/docs/pdftxt/NSSLMICRO.txt
@@ -2,7 +2,7 @@
\page NSSLMICRO_page NSSL 2-moment Cloud Microphysics Scheme
\section nssl2m_descrp Description
-The NSSL two-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010 and Mansell and Ziegler (2013) \cite Mansell_2013. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail.
+The NSSL 2/3-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010, Mansell and Ziegler (2013) \cite Mansell_2013, and Mansell et al. (2020) \cite Mansell_etal_2020. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. Optionally, a third moment (reflectivity or 6th moment) of rain, graupel, and hail can be activated.
The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel.
@@ -10,7 +10,7 @@ Hydrometeor size distributions are assumed to follow a gamma functional form. Mi
Cloud concentration nuclei (CCN) concentration is predicted as in Mansell et al. (2010) \cite Mansell_etal_2010 with a bulk activation spectrum approximating small aerosols. The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present. Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration.
-Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010).
+Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). Activating the 3-moment scheme provides a natural sedimentation feedback that narrows the size spectrum as size-sorting procedes without the the artificial breakup induced by the 2-moment scheme.
The NSSL scheme is designed with deep (severe) convection in mind at grid spacings of up to 4 km, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather.
diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt
index e986fc322..c4bb5003b 100644
--- a/physics/docs/pdftxt/suite_input.nml.txt
+++ b/physics/docs/pdftxt/suite_input.nml.txt
@@ -54,7 +54,7 @@ show some variables in the namelist that must match the SDF.
<li> 10: Morrison-Gettelman microphysics scheme
<li> 11: GFDL microphysics scheme
<li> 17: NSSL microphysics scheme with background CCN
- <li> 18: NSSL microphysics scheme with predicted CCN (compatibility)
+ <li> 18: NSSL microphysics scheme with predicted CCN (compatibility: 18 = 17 + nssl_ccn_on=.true.)
</ul>
<td>99
<tr><td colspan="4" align= center>\b Parameters \b related \b to \b radiation \b scheme \b options
@@ -406,6 +406,7 @@ show some variables in the namelist that must match the SDF.
<tr><td>nssl_ehw0_in <td>mp_nssl <td>constant or max assumed graupel-droplet collection efficiency <td>0.9
<tr><td>nssl_ehlw0_in <td>mp_nssl <td>constant or max assumed hail-droplet collection efficiency <td>0.9
<tr><td>nssl_hail_on <td>mp_nssl <td>NSSL flag to activate the hail category <td>.false.
+<tr><td>nssl_3moment <td>mp_nssl <td>NSSL flag to activate 3-moment for rain/graupel (and hail if activated)<td>.false.
<tr><td>nssl_ccn_on <td>mp_nssl <td>NSSL flag to activate the CCN category <td>.true.
<tr><td>nssl_invertccn <td>mp_nssl <td>NSSL flag to treat CCN as activated or unactivated <td>.true.
<tr><td>nssl_ehw0 <td>mp_nssl <td>NSSL graupel-droplet collection efficiency <td>0.9
diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90
index 22f122e71..ff68f4216 100644
--- a/physics/drag_suite.F90
+++ b/physics/drag_suite.F90
@@ -460,6 +460,8 @@ subroutine drag_suite_run( &
real(kind=kind_phys), parameter :: ce = 0.8
real(kind=kind_phys), parameter :: cg = 0.5
real(kind=kind_phys), parameter :: sgmalolev = 0.5 ! max sigma lvl for dtfac
+ real(kind=kind_phys), parameter :: plolevmeso = 70.0 ! pres lvl for mesosphere OGWD reduction (Pa)
+ real(kind=kind_phys), parameter :: facmeso = 0.5 ! fractional velocity reduction for OGWD
integer,parameter :: kpblmin = 2
!
@@ -472,7 +474,7 @@ subroutine drag_suite_run( &
rcsks,wdir,ti,rdz,tem2,dw2,shr2, &
bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, &
rim,temc,tem1,efact,temv,dtaux,dtauy, &
- dtauxb,dtauyb,eng0,eng1
+ dtauxb,dtauyb,eng0,eng1,ksmax,dtfac_meso
!
logical :: ldrag(im),icrilv(im), &
flag(im),kloop1(im)
@@ -887,6 +889,14 @@ subroutine drag_suite_run( &
ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0
ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0
ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0
+! Check if mesoscale gravity waves will propagate vertically or be evanescent
+! and not impart a drag force -- consider the maximum sub-grid horizontal
+! topographic wavelength to be one-half the horizontal grid spacing -- calculate
+! ksmax accordingly
+ ksmax = 4.0*pi/dx(i) ! based on wavelength = 0.5*dx(i)
+ if ( bnv2(i,1).gt.0.0 ) then
+ ldrag(i) = ldrag(i) .or. sqrt(bnv2(i,1))*rulow(i).lt.ksmax
+ endif
!
! set all ri low level values to the low level value
!
@@ -1106,7 +1116,19 @@ subroutine drag_suite_run( &
enddo
!
do k = kts,km
- taud_ms(i,k) = taud_ms(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i))
+
+ ! Check if well into mesosphere -- if so, perform similar reduction of
+ ! velocity tendency due to mesoscale GWD to prevent sudden reversal of
+ ! wind direction (similar to above)
+ dtfac_meso = 1.0
+ if (prsl(i,k).le.plolevmeso) then
+ if (taud_ms(i,k).ne.0.) &
+ dtfac_meso = min(dtfac_meso,facmeso*abs(velco(i,k) &
+ /(deltim*rcs*taud_ms(i,k))))
+ end if
+
+ taud_ms(i,k) = taud_ms(i,k)*dtfac(i)*dtfac_meso* &
+ ls_taper(i) *(1.-rstoch(i))
taud_bl(i,k) = taud_bl(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i))
dtaux = taud_ms(i,k) * xn(i)
diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90
index 665fe6d14..ba1b1b4e9 100644
--- a/physics/lsm_ruc.F90
+++ b/physics/lsm_ruc.F90
@@ -359,6 +359,8 @@ subroutine lsm_ruc_run & ! inputs
& qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, &
& cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, &
& albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, &
+ & add_fire_heat_flux, fire_heat_flux_out, &
+ & frac_grid_burned_out, &
! --- out
& rhosnf, sbsno, &
& cmm_lnd, chh_lnd, cmm_ice, chh_ice, &
@@ -381,7 +383,7 @@ subroutine lsm_ruc_run & ! inputs
real (kind_phys), dimension(:), intent(in) :: oro, sigma
real (kind_phys), dimension(:), intent(in) :: &
- & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, &
+ & t1, sigmaf, dlwflx, dswsfc, tg3, &
& coszen, prsl1, wind, shdmin, shdmax, &
& sfalb_lnd_bck, snoalb, zf, qc, q1, &
! for land
@@ -417,7 +419,7 @@ subroutine lsm_ruc_run & ! inputs
real (kind_phys), dimension(:), intent(in) :: zs
real (kind_phys), dimension(:), intent(in) :: srflag
real (kind_phys), dimension(:), intent(inout) :: &
- & canopy, trans, smcwlt2, smcref2, &
+ & canopy, trans, smcwlt2, smcref2, laixy, &
! for land
& weasd_lnd, snwdph_lnd, tskin_lnd, &
& tsurf_lnd, z0rl_lnd, tsnow_lnd, &
@@ -430,6 +432,9 @@ subroutine lsm_ruc_run & ! inputs
! --- in
real (kind_phys), dimension(:), intent(in) :: &
& rainnc, rainc, ice, snow, graupel, rhonewsn1
+ real (kind_phys), dimension(:), intent(in) :: fire_heat_flux_out, &
+ frac_grid_burned_out
+ logical, intent(in) :: add_fire_heat_flux
! --- in/out:
! --- on RUC levels
real (kind_phys), dimension(:,:), intent(inout) :: &
@@ -505,12 +510,13 @@ subroutine lsm_ruc_run & ! inputs
& solnet_lnd, sfcexc, &
& runoff1, runoff2, acrunoff, semis_bck, &
& sfcems_lnd, hfx_lnd, shdfac, shdmin1d, shdmax1d, &
+ & fire_heat_flux1d, &
& sneqv_lnd, snoalb1d_lnd, snowh_lnd, snoh_lnd, tsnav_lnd, &
& snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, &
& soilt_lnd, tbot, &
& xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, &
- & precipfr, snfallac_lnd, acsn_lnd, &
- & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq
+ & precipfr, snfallac_lnd, acsn_lnd, soilt1_lnd, chklowq, &
+ & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, smcwlt, smcref
! ice
real (kind_phys),dimension (im,1) :: &
& albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, &
@@ -540,7 +546,7 @@ subroutine lsm_ruc_run & ! inputs
integer :: l, k, i, j, fractional_seaice, ilst
real (kind_phys) :: dm, cimin(im)
logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im)
- logical :: rdlai2d, myj, frpcpn
+ logical :: myj, frpcpn
logical :: debug_print
!-- diagnostic point
@@ -645,15 +651,27 @@ subroutine lsm_ruc_run & ! inputs
nsoil = lsoil_ruc
do i = 1, im ! i - horizontal loop
- ! reassign smcref2 and smcwlt2 to RUC values
if(.not. land(i)) then
!water and sea ice
- smcref2 (i) = one
- smcwlt2 (i) = zero
+ smcref (i,1) = one
+ smcwlt (i,1) = zero
+ xlai (i,1) = zero
+ elseif (kdt == 1) then
+ !land
+ ! reassign smcref2 and smcwlt2 to RUC values at kdt=1
+ smcref (i,1) = REFSMC(stype(i))
+ smcwlt (i,1) = WLTSMC(stype(i))
+ !-- rdlai is .true. when the LAI data is available in the INPUT/sfc_data.nc on cold-start
+ if(rdlai) then
+ xlai(i,1) = laixy(i)
+ else
+ xlai(i,1) = LAITBL(vtype(i))
+ endif
else
- !land
- smcref2 (i) = REFSMC(stype(i))
- smcwlt2 (i) = WLTSMC(stype(i))
+ !-- land and kdt > 1, parameters has sub-grid heterogeneity
+ smcref (i,1) = smcref2 (i)
+ smcwlt (i,1) = smcwlt2 (i)
+ xlai (i,1) = laixy (i)
endif
enddo
@@ -813,10 +831,6 @@ subroutine lsm_ruc_run & ! inputs
ffrozp(i,j) = real(nint(srflag(i)),kind_phys)
endif
- !-- rdlai is .false. when the LAI data is not available in the
- ! - INPUT/sfc_data.nc
-
- rdlai2d = rdlai
conflx2(i,1,j) = zf(i) * 2._kind_phys ! factor 2. is needed to get the height of
! atm. forcing inside RUC LSM (inherited
@@ -843,14 +857,15 @@ subroutine lsm_ruc_run & ! inputs
!!\n \a graupelncv - time-step graupel (\f$kg m^{-2} \f$)
!!\n \a snowncv - time-step snow (\f$kg m^{-2} \f$)
!!\n \a precipfr - time-step precipitation in solid form (\f$kg m^{-2} \f$)
-!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-1.0)
-!!\n \a shdmin - minimum areal fractional coverage of green vegetation -> !shdmin1d
-!!\n \a shdmax - maximum areal fractional coverage of green vegetation -> !shdmax1d
+!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-100.%)
+!!\n \a shdmin - minimum areal fractional coverage of green vegetation in % -> !shdmin1d
+!!\n \a shdmax - maximum areal fractional coverage of green vegetation in % -> !shdmax1d
!!\n \a tbot - bottom soil temperature (local yearly-mean sfc air temp)
lwdn(i,j) = dlwflx(i) !..downward lw flux at sfc in w/m2
swdn(i,j) = dswsfc(i) !..downward sw flux at sfc in w/m2
+
! all precip input to RUC LSM is in [mm]
!prcp(i,j) = rhoh2o * tprcp(i) ! tprcp in [m] - convective plus explicit
!raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip
@@ -918,17 +933,12 @@ subroutine lsm_ruc_run & ! inputs
write (0,*)'MODIS landuse is not available'
endif
- if(rdlai2d) then
- xlai(i,j) = laixy(i)
- else
- xlai(i,j) = zero
- endif
-
semis_bck(i,j) = semisbase(i)
! --- units %
shdfac(i,j) = sigmaf(i)*100._kind_phys
shdmin1d(i,j) = shdmin(i)*100._kind_phys
shdmax1d(i,j) = shdmax(i)*100._kind_phys
+ fire_heat_flux1d(i,j) = fire_heat_flux_out(i) ! JLS
if (land(i)) then ! at least some land in the grid cell
@@ -976,7 +986,6 @@ subroutine lsm_ruc_run & ! inputs
snoalb1d_lnd(i,j) = snoalb(i)
albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i)
-
!-- spp_lsm
if (spp_lsm == 1) then
!-- spp for LSM is dimentioned as (1:lsoil_ruc)
@@ -999,6 +1008,19 @@ subroutine lsm_ruc_run & ! inputs
alb_lnd(i,j) = albbck_lnd(i,j) * (one-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i)
solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2
+ IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS
+ if (debug_print) then
+ print *,'alb_lnd before fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i)
+ print *,'fire_heat_flux_out, frac_grid_burned_out, xlat/xlon ', &
+ fire_heat_flux_out(i),frac_grid_burned_out(i),xlat_d(i),xlon_d(i)
+ endif
+ ! limit albedo in the areas affected by the fire
+ alb_lnd(i,j) = alb_lnd(i,j) * (one-frac_grid_burned_out(i)) + 0.08_kind_phys*frac_grid_burned_out(i)
+ if (debug_print) then
+ print *,'alb_lnd after fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i)
+ endif
+ ENDIF
+
cmc(i,j) = canopy(i) ! [mm]
soilt_lnd(i,j) = tsurf_lnd(i)
! sanity check for snow temperature tsnow
@@ -1163,7 +1185,7 @@ subroutine lsm_ruc_run & ! inputs
& wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), &
& z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), &
& xlai(i,j), landusef(i,:,j), nlcat, &
- & soilctop(i,:,j), nscat, &
+ & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), &
& qsfc_lnd(i,j), qsg_lnd(i,j), qvg_lnd(i,j), qcg_lnd(i,j), &
& dew_lnd(i,j), soilt1_lnd(i,j), &
& tsnav_lnd(i,j), tbot(i,j), vtype_lnd(i,j), stype_lnd(i,j), &
@@ -1178,8 +1200,9 @@ subroutine lsm_ruc_run & ! inputs
& infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), &
& sfcexc(i,j), acceta(i,j), ssoil_lnd(i,j), &
& snfallac_lnd(i,j), acsn_lnd(i,j), snomlt_lnd(i,j), &
- & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., &
- & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, &
+ & smfrsoil(i,:,j),keepfrsoil(i,:,j), &
+ & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., &
+ & shdmin1d(i,j), shdmax1d(i,j), rdlai, &
& ims,ime, jms,jme, kms,kme, &
& its,ite, jts,jte, kts,kte, errmsg, errflg )
if(debug_print) then
@@ -1218,7 +1241,7 @@ subroutine lsm_ruc_run & ! inputs
'ssoil(i,j) =',ssoil_lnd(i,j), &
'snfallac(i,j) =',snfallac_lnd(i,j), &
'acsn_lnd(i,j) =',acsn_lnd(i,j), &
- 'snomlt(i,j) =',snomlt_lnd(i,j)
+ 'snomlt(i,j) =',snomlt_lnd(i,j),'xlai(i,j) =',xlai(i,j)
endif
endif
@@ -1289,6 +1312,10 @@ subroutine lsm_ruc_run & ! inputs
! --- ... unit conversion (from m to mm)
snwdph_lnd(i) = snowh_lnd(i,j) * rhoh2o
+ laixy(i) = xlai(i,j)
+ smcwlt2(i) = smcwlt(i,j)
+ smcref2(i) = smcref(i,j)
+
canopy(i) = cmc(i,j) ! mm
weasd_lnd(i) = sneqv_lnd(i,j) ! mm
sncovr1_lnd(i) = sncovr_lnd(i,j)
@@ -1318,6 +1345,7 @@ subroutine lsm_ruc_run & ! inputs
write (0,*)'LAND -i,j,stype_lnd,vtype_lnd',i,j,stype_lnd(i,j),vtype_lnd(i,j)
write (0,*)'i,j,tsurf_lnd(i)',i,j,tsurf_lnd(i)
write (0,*)'kdt,iter,stsoil(i,:,j)',kdt,iter,stsoil(i,:,j)
+ write (0,*)'laixy(i)',laixy(i)
endif
endif ! end of land
@@ -1449,7 +1477,7 @@ subroutine lsm_ruc_run & ! inputs
& wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), &
& znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), &
& albbck_ice(i,j), xlai(i,j),landusef(i,:,j), nlcat, &
- & soilctop(i,:,j), nscat, &
+ & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), &
& qsfc_ice(i,j), qsg_ice(i,j), qvg_ice(i,j), qcg_ice(i,j), &
& dew_ice(i,j), soilt1_ice(i,j), &
& tsnav_ice(i,j), tbot(i,j), vtype_ice(i,j), stype_ice(i,j), &
@@ -1464,8 +1492,9 @@ subroutine lsm_ruc_run & ! inputs
& infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), &
& sfcexc(i,j), acceta(i,j), ssoil_ice(i,j), &
& snfallac_ice(i,j), acsn_ice(i,j), snomlt_ice(i,j), &
- & smfrice(i,:,j),keepfrice(i,:,j), .false., &
- & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, &
+ & smfrice(i,:,j),keepfrice(i,:,j), &
+ & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., &
+ & shdmin1d(i,j), shdmax1d(i,j), rdlai, &
& ims,ime, jms,jme, kms,kme, &
& its,ite, jts,jte, kts,kte, &
& errmsg, errflg)
@@ -1502,6 +1531,10 @@ subroutine lsm_ruc_run & ! inputs
albivis_ice(i) = sfalb_ice(i)
albinir_ice(i) = sfalb_ice(i)
+ laixy(i) = zero
+ smcwlt2(i) = zero
+ smcref2(i) = one
+ stm(i) = 3.e3_kind_phys ! kg m-2
do k = 1, lsoil_ruc
tsice(i,k) = stsice(i,k,j)
@@ -1517,6 +1550,7 @@ subroutine lsm_ruc_run & ! inputs
write (0,*)'ICE - i,j,stype_ice,vtype_ice)',i,j,stype_ice(i,j),vtype_ice(i,j)
write (0,*)'i,j,tsurf_ice(i)',i,j,tsurf_ice(i)
write (0,*)'kdt,iter,stsice(i,:,j)',kdt,iter,stsice(i,:,j)
+ write (0,*)'laixy(i)',laixy(i)
endif
endif ! ice
@@ -1762,6 +1796,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in
tbot(i,j) = tg3(i)
ivgtyp(i,j) = vtype(i)
isltyp(i,j) = stype(i)
+ if(isltyp(i,j)==0) isltyp(i,j)=14
+ if(ivgtyp(i,j)==0) ivgtyp(i,j)=17
if (landfrac(i) > zero .or. fice(i) > zero) then
!-- land or ice
tsk(i,j) = tskin_lnd(i)
diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta
index 34a5b8a8b..9bc7fa10a 100644
--- a/physics/lsm_ruc.meta
+++ b/physics/lsm_ruc.meta
@@ -813,7 +813,7 @@
dimensions = (horizontal_loop_extent)
type = real
kind = kind_phys
- intent = in
+ intent = inout
[dlwflx]
standard_name = surface_downwelling_longwave_flux
long_name = surface downwelling longwave flux at current time
@@ -1747,6 +1747,29 @@
dimensions = ()
type = logical
intent = in
+[add_fire_heat_flux]
+ standard_name = flag_for_fire_heat_flux
+ long_name = flag to add fire heat flux to LSM
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
+[fire_heat_flux_out]
+ standard_name = surface_fire_heat_flux
+ long_name = heat flux of fire at the surface
+ units = W m-2
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = in
+[frac_grid_burned_out]
+ standard_name = fraction_of_grid_cell_burning
+ long_name = ration of the burnt area to the grid cell area
+ units = frac
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90
index ec6b5700d..6840f80bf 100644
--- a/physics/module_bl_mynn.F90
+++ b/physics/module_bl_mynn.F90
@@ -232,6 +232,18 @@
! bl_mynn_cloudpdf = 2 (Chab-Becht).
! Removed WRF_CHEM dependencies.
! Many miscellaneous tweaks.
+! v4.5.2 / CCPP
+! Some code optimization. Removed many conditions from loops. Redesigned the mass-
+! flux scheme to use 8 plumes instead of a variable n plumes. This results in
+! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume.
+! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all
+! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility
+! for tuning near-surface cloud fractions to remove excess fog/low ceilings.
+! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This
+! results in a change in the pre-radiation code to no longer multiply mixing ratios
+! by cloud fractions.
+! Lots of code cleanup: removal of test code, comments, changing text case, etc.
+! Many misc tuning/tweaks.
!
! Many of these changes are now documented in references listed above.
!====================================================================
@@ -256,11 +268,11 @@ MODULE module_bl_mynn
!===================================================================
! From here on, these are MYNN-specific parameters:
! The parameters below depend on stability functions of module_sf_mynn.
- real(kind_phys), PARAMETER :: cphm_st=5.0, cphm_unst=16.0, &
+ real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, &
cphh_st=5.0, cphh_unst=16.0
! Closure constants
- real(kind_phys), PARAMETER :: &
+ real(kind_phys), parameter :: &
&pr = 0.74, &
&g1 = 0.235, & ! NN2009 = 0.235
&b1 = 24.0, &
@@ -275,7 +287,7 @@ MODULE module_bl_mynn
&a2 = a1*( g1-c1 )/( g1*pr ), &
&g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 )
- real(kind_phys), PARAMETER :: &
+ real(kind_phys), parameter :: &
&cc2 = 1.0-c2, &
&cc3 = 1.0-c3, &
&e1c = 3.0*a2*b2*cc3, &
@@ -286,15 +298,15 @@ MODULE module_bl_mynn
! Constants for min tke in elt integration (qmin), max z/L in els (zmax),
! and factor for eddy viscosity for TKE (Kq = Sqfac*Km):
- real(kind_phys), PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0
+ real(kind_phys), parameter :: qmin=0.0, zmax=1.0, Sqfac=3.0
! Note that the following mixing-length constants are now specified in mym_length
! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2
- real(kind_phys), PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12
- real(kind_phys), PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq
+ real(kind_phys), parameter :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12
+ real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq
! Constants for cloud PDF (mym_condensation)
- real(kind_phys), PARAMETER :: rr2=0.7071068, rrp=0.3989423
+ real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423
!>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no)
!!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the
@@ -304,35 +316,35 @@ MODULE module_bl_mynn
!!(above) back to NN2009 values (see commented out lines next to the
!!parameters above). This only removes the negative TKE problem
!!but does not necessarily improve performance - neutral impact.
- real(kind_phys), PARAMETER :: CKmod=1.
+ real(kind_phys), parameter :: CKmod=1.
!>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts
!!on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function
!!for TKE in the upper PBL/cloud layer.
- real(kind_phys), PARAMETER :: scaleaware=1.
+ real(kind_phys), parameter :: scaleaware=1.
!>Of the following the options, use one OR the other, not both.
!>Adding top-down diffusion driven by cloud-top radiative cooling
- INTEGER, PARAMETER :: bl_mynn_topdown = 0
+ integer, parameter :: bl_mynn_topdown = 0
!>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active)
- INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0
+ integer, parameter :: bl_mynn_edmf_dd = 0
!>Option to activate heating due to dissipation of TKE (to activate, set to 1.0)
- INTEGER, PARAMETER :: dheat_opt = 1
+ integer, parameter :: dheat_opt = 1
!Option to activate environmental subsidence in mass-flux scheme
- LOGICAL, PARAMETER :: env_subs = .false.
+ logical, parameter :: env_subs = .false.
!Option to switch flux-profile relationship for surface (from Puhales et al. 2020)
!0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE
- INTEGER, PARAMETER :: bl_mynn_stfunc = 1
+ integer, parameter :: bl_mynn_stfunc = 1
!option to print out more stuff for debugging purposes
- LOGICAL, PARAMETER :: debug_code = .false.
- INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out
+ logical, parameter :: debug_code = .false.
+ integer, parameter :: idbg = 23 !specific i-point to write out
! Used in WRF-ARW module_physics_init.F
- INTEGER :: mynn_level
+ integer :: mynn_level
CONTAINS
@@ -388,7 +400,8 @@ SUBROUTINE mynn_bl_driver( &
&edmf_thl,edmf_ent,edmf_qc, &
&sub_thl3D,sub_sqv3D, &
&det_thl3D,det_sqv3D, &
- &nupdraft,maxMF,ktop_plume, &
+ &maxwidth,maxMF,ztop_plume, &
+ &ktop_plume, &
&spp_pbl,pattern_spp_pbl, &
&rthraten, &
&FLAG_QC,FLAG_QI,FLAG_QNC, &
@@ -401,30 +414,30 @@ SUBROUTINE mynn_bl_driver( &
!-------------------------------------------------------------------
- INTEGER, INTENT(in) :: initflag
+ integer, intent(in) :: initflag
!INPUT NAMELIST OPTIONS:
- LOGICAL, INTENT(in) :: restart,cycling
- INTEGER, INTENT(in) :: tke_budget
- INTEGER, INTENT(in) :: bl_mynn_cloudpdf
- INTEGER, INTENT(in) :: bl_mynn_mixlength
- INTEGER, INTENT(in) :: bl_mynn_edmf
- LOGICAL, INTENT(in) :: bl_mynn_tkeadvect
- INTEGER, INTENT(in) :: bl_mynn_edmf_mom
- INTEGER, INTENT(in) :: bl_mynn_edmf_tke
- INTEGER, INTENT(in) :: bl_mynn_mixscalars
- INTEGER, INTENT(in) :: bl_mynn_output
- INTEGER, INTENT(in) :: bl_mynn_cloudmix
- INTEGER, INTENT(in) :: bl_mynn_mixqt
- INTEGER, INTENT(in) :: icloud_bl
- real(kind_phys), INTENT(in) :: closure
-
- LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,&
+ logical, intent(in) :: restart,cycling
+ integer, intent(in) :: tke_budget
+ integer, intent(in) :: bl_mynn_cloudpdf
+ integer, intent(in) :: bl_mynn_mixlength
+ integer, intent(in) :: bl_mynn_edmf
+ logical, intent(in) :: bl_mynn_tkeadvect
+ integer, intent(in) :: bl_mynn_edmf_mom
+ integer, intent(in) :: bl_mynn_edmf_tke
+ integer, intent(in) :: bl_mynn_mixscalars
+ integer, intent(in) :: bl_mynn_output
+ integer, intent(in) :: bl_mynn_cloudmix
+ integer, intent(in) :: bl_mynn_mixqt
+ integer, intent(in) :: icloud_bl
+ real(kind_phys), intent(in) :: closure
+
+ logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,&
FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &
FLAG_OZONE,FLAG_QS
- LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg
+ logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg
- INTEGER, INTENT(in) :: &
+ integer, intent(in) :: &
& IDS,IDE,JDS,JDE,KDS,KDE &
&,IMS,IME,JMS,JME,KMS,KME &
&,ITS,ITE,JTS,JTE,KTS,KTE
@@ -444,81 +457,82 @@ SUBROUTINE mynn_bl_driver( &
! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs
! on Cheyenne with the GNU compiler.
- real(kind_phys), INTENT(in) :: delt
- real(kind_phys), DIMENSION(:), INTENT(in) :: dx
- real(kind_phys), DIMENSION(:,:), INTENT(in) :: dz, &
+ real(kind_phys), intent(in) :: delt
+ real(kind_phys), dimension(:), intent(in) :: dx
+ real(kind_phys), dimension(:,:), intent(in) :: dz, &
&u,v,w,th,sqv3D,p,exner,rho,T3D
- real(kind_phys), DIMENSION(:,:), INTENT(in) :: &
+ real(kind_phys), dimension(:,:), intent(in) :: &
&sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca
- real(kind_phys), DIMENSION(:,:), INTENT(in):: ozone
- real(kind_phys), DIMENSION(:), INTENT(in):: ust, &
+ real(kind_phys), dimension(:,:), intent(in):: ozone
+ real(kind_phys), dimension(:), intent(in):: ust, &
&ch,qsfc,ps,wspd
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: &
+ real(kind_phys), dimension(:,:), intent(inout) :: &
&Qke,Tsq,Qsq,Cov,qke_adv
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: &
+ real(kind_phys), dimension(:,:), intent(inout) :: &
&rublten,rvblten,rthblten,rqvblten,rqcblten, &
&rqiblten,rqsblten,rqniblten,rqncblten, &
&rqnwfablten,rqnifablten,rqnbcablten
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone
- real(kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten
+ real(kind_phys), dimension(:,:), intent(inout) :: dozone
+ real(kind_phys), dimension(:,:), intent(in) :: rthraten
- real(kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m
- real(kind_phys), DIMENSION(:), INTENT(in) :: xland, &
+ real(kind_phys), dimension(:,:), intent(out) :: exch_h,exch_m
+ real(kind_phys), dimension(:), intent(in) :: xland, &
&ts,znt,hfx,qfx,uoce,voce
!These 10 arrays are only allocated when bl_mynn_output > 0
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: &
+ real(kind_phys), dimension(:,:), intent(inout) :: &
& edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, &
& sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D
-! real, DIMENSION(IMS:IME,KMS:KME) :: &
+! real, dimension(ims:ime,kms:kme) :: &
! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd
- real(kind_phys), DIMENSION(:), INTENT(inout) :: Pblh
- real(kind_phys), DIMENSION(:), INTENT(inout) :: rmol
+ real(kind_phys), dimension(:), intent(inout) :: Pblh
+ real(kind_phys), dimension(:), intent(inout) :: rmol
- real(kind_phys), DIMENSION(IMS:IME) :: psig_bl,psig_shcu
+ real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu
- INTEGER,DIMENSION(:),INTENT(INOUT) :: &
- &KPBL,nupdraft,ktop_plume
+ integer,dimension(:),intent(INOUT) :: &
+ &KPBL,ktop_plume
- real(kind_phys), DIMENSION(:), INTENT(out) :: maxmf
+ real(kind_phys), dimension(:), intent(out) :: &
+ &maxmf,maxwidth,ztop_plume
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl
+ real(kind_phys), dimension(:,:), intent(inout) :: el_pbl
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: &
+ real(kind_phys), dimension(:,:), intent(inout) :: &
&qWT,qSHEAR,qBUOY,qDISS,dqke
! 3D budget arrays are not allocated when tke_budget == 0
! 1D (local) budget arrays are used for passing between subroutines.
- real(kind_phys), DIMENSION(kts:kte) :: &
+ real(kind_phys), dimension(kts:kte) :: &
&qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat
- real(kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D
+ real(kind_phys), dimension(:,:), intent(out) :: Sh3D,Sm3D
- real(kind_phys), DIMENSION(:,:), INTENT(inout) :: &
+ real(kind_phys), dimension(:,:), intent(inout) :: &
&qc_bl,qi_bl,cldfra_bl
- real(kind_phys), DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D, &
+ real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D, &
&cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old
! smoke/chemical arrays
- INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel
- real(kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d
- real(kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep
- real(kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO
+ integer, intent(IN ) :: nchem, kdvel, ndvel
+ real(kind_phys), dimension(:,:,:), intent(INOUT) :: chem3d
+ real(kind_phys), dimension(:,:), intent(IN) :: vdep
+ real(kind_phys), dimension(:), intent(IN) :: frp,EMIS_ANT_NO
!local
- real(kind_phys), DIMENSION(kts:kte ,nchem) :: chem1
- real(kind_phys), DIMENSION(kts:kte+1,nchem) :: s_awchem1
- real(kind_phys), DIMENSION(ndvel) :: vd1
- INTEGER :: ic
+ real(kind_phys), dimension(kts:kte ,nchem) :: chem1
+ real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1
+ real(kind_phys), dimension(ndvel) :: vd1
+ integer :: ic
!local vars
- INTEGER :: ITF,JTF,KTF, IMD,JMD
- INTEGER :: i,j,k,kproblem
- real(kind_phys), DIMENSION(KTS:KTE) :: &
+ integer :: ITF,JTF,KTF, IMD,JMD
+ integer :: i,j,k,kproblem
+ real(kind_phys), dimension(kts:kte) :: &
&thl,tl,qv1,qc1,qi1,qs1,sqw, &
&el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, &
- &vt, vq, sgm
- real(kind_phys), DIMENSION(KTS:KTE) :: &
+ &vt, vq, sgm, kzero
+ real(kind_phys), dimension(kts:kte) :: &
&thetav,sh,sm,u1,v1,w1,p1, &
&ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, &
&sqv,sqi,sqc,sqs, &
@@ -527,45 +541,45 @@ SUBROUTINE mynn_bl_driver( &
&qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1
!mass-flux variables
- real(kind_phys), DIMENSION(KTS:KTE) :: &
+ real(kind_phys), dimension(kts:kte) :: &
&dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf
- real(kind_phys), DIMENSION(KTS:KTE) :: &
+ real(kind_phys), dimension(kts:kte) :: &
&edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, &
&edmf_ent1,edmf_qc1
- real(kind_phys), DIMENSION(KTS:KTE) :: &
+ real(kind_phys), dimension(kts:kte) :: &
&edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, &
&edmf_ent_dd1,edmf_qc_dd1
- real(kind_phys), DIMENSION(KTS:KTE) :: &
+ real(kind_phys), dimension(kts:kte) :: &
&sub_thl,sub_sqv,sub_u,sub_v, &
&det_thl,det_sqv,det_sqc,det_u,det_v
- real(kind_phys), DIMENSION(KTS:KTE+1) :: &
+ real(kind_phys), dimension(kts:kte+1) :: &
&s_aw1,s_awthl1,s_awqt1, &
&s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, &
&s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, &
&s_awqnbca1
- real(kind_phys), DIMENSION(KTS:KTE+1) :: &
+ real(kind_phys), dimension(kts:kte+1) :: &
&sd_aw1,sd_awthl1,sd_awqt1, &
&sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1
- real(kind_phys), DIMENSION(KTS:KTE+1) :: zw
+ real(kind_phys), dimension(kts:kte+1) :: zw
real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, &
&pmz,phh,exnerg,zet,phi_m, &
&afk,abk,ts_decay, qc_bl2, qi_bl2, &
- &th_sfc,ztop_plume,wsp
+ &th_sfc,wsp
!top-down diffusion
- real(kind_phys), DIMENSION(ITS:ITE) :: maxKHtopdown
- real(kind_phys), DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD
+ real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown
+ real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD
- LOGICAL :: INITIALIZE_QKE,problem
+ logical :: INITIALIZE_QKE,problem
! Stochastic fields
- INTEGER, INTENT(IN) :: spp_pbl
- real(kind_phys), DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl
- real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col
+ integer, intent(IN) :: spp_pbl
+ real(kind_phys), dimension(:,:), intent(IN) :: pattern_spp_pbl
+ real(kind_phys), dimension(KTS:KTE) :: rstoch_col
! Substepping TKE
- INTEGER :: nsub
+ integer :: nsub
real(kind_phys) :: delt2
@@ -629,9 +643,11 @@ SUBROUTINE mynn_bl_driver( &
!edmf_qc_dd(its:ite,kts:kte)=0.
ENDIF
ktop_plume(its:ite)=0 !int
- nupdraft(its:ite)=0 !int
+ ztop_plume(its:ite)=0.
+ maxwidth(its:ite)=0.
maxmf(its:ite)=0.
maxKHtopdown(its:ite)=0.
+ kzero(kts:kte)=0.
! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS
!> - Within the MYNN-EDMF, there is a dependecy check for the first time step,
@@ -740,7 +756,7 @@ SUBROUTINE mynn_bl_driver( &
!keep snow out for now - increases ceiling bias
sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k)
thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) &
- & - xlscp/ex1(k)*(sqi(k)+sqs(k))
+ & - xlscp/ex1(k)*(sqi(k))!+sqs(k))
!Use form from Tripoli and Cotton (1981) with their
!suggested min temperature to improve accuracy.
!thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
@@ -987,10 +1003,10 @@ SUBROUTINE mynn_bl_driver( &
else
zw(k)=zw(k-1)+dz(i,k-1)
endif
- !keep snow out for now - increases ceiling bias
+ !keep snow out for now - increases ceiling bias
sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k)
thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) &
- & - xlscp/ex1(k)*(sqi(k)+sqs(k))
+ & - xlscp/ex1(k)*(sqi(k))!+sqs(k))
!Use form from Tripoli and Cotton (1981) with their
!suggested min temperature to improve accuracy.
!thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
@@ -1021,7 +1037,7 @@ SUBROUTINE mynn_bl_driver( &
endif
s_awchem1 = 0.0
-!> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$
+!> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$
!! PBL height diagnostic.
CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,&
& Qke1,zw,dz1,xland(i),KPBL(i))
@@ -1147,8 +1163,8 @@ SUBROUTINE mynn_bl_driver( &
&FLAG_QNC,FLAG_QNI, &
&FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &
&Psig_shcu(i), &
- &nupdraft(i),ktop_plume(i), &
- &maxmf(i),ztop_plume, &
+ &maxwidth(i),ktop_plume(i), &
+ &maxmf(i),ztop_plume(i), &
&spp_pbl,rstoch_col )
endif
@@ -1220,9 +1236,9 @@ SUBROUTINE mynn_bl_driver( &
call mynn_tendencies(kts,kte,i, &
&delt, dz1, rho1, &
&u1, v1, th1, tk1, qv1, &
- &qc1, qi1, qs1, qnc1, qni1, &
+ &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow
&ps(i), p1, ex1, thl, &
- &sqv, sqc, sqi, sqs, sqw, &
+ &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow
&qnwfa1, qnifa1, qnbca1, ozone1, &
&ust(i),flt,flq,flqv,flqc, &
&wspd(i),uoce(i),voce(i), &
@@ -1295,27 +1311,27 @@ SUBROUTINE mynn_bl_driver( &
&dfm, dfh, dz1, K_m1, K_h1 )
!UPDATE 3D ARRAYS
- exch_m(i,:) =k_m1(:)
- exch_h(i,:) =k_h1(:)
- rublten(i,:) =du1(:)
- rvblten(i,:) =dv1(:)
- rthblten(i,:)=dth1(:)
- rqvblten(i,:)=dqv1(:)
+ exch_m(i,kts:kte) =k_m1(kts:kte)
+ exch_h(i,kts:kte) =k_h1(kts:kte)
+ rublten(i,kts:kte) =du1(kts:kte)
+ rvblten(i,kts:kte) =dv1(kts:kte)
+ rthblten(i,kts:kte)=dth1(kts:kte)
+ rqvblten(i,kts:kte)=dqv1(kts:kte)
if (bl_mynn_cloudmix > 0) then
- if (flag_qc) rqcblten(i,:)=dqc1(:)
- if (flag_qi) rqiblten(i,:)=dqi1(:)
- if (flag_qs) rqsblten(i,:)=dqs1(:)
+ if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte)
+ if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte)
+ if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte)
else
if (flag_qc) rqcblten(i,:)=0.
if (flag_qi) rqiblten(i,:)=0.
if (flag_qs) rqsblten(i,:)=0.
endif
if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then
- if (flag_qnc) rqncblten(i,:) =dqnc1(:)
- if (flag_qni) rqniblten(i,:) =dqni1(:)
- if (flag_qnwfa) rqnwfablten(i,:)=dqnwfa1(:)
- if (flag_qnifa) rqnifablten(i,:)=dqnifa1(:)
- if (flag_qnbca) rqnbcablten(i,:)=dqnbca1(:)
+ if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte)
+ if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte)
+ if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte)
+ if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte)
+ if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte)
else
if (flag_qnc) rqncblten(i,:) =0.
if (flag_qni) rqniblten(i,:) =0.
@@ -1323,19 +1339,19 @@ SUBROUTINE mynn_bl_driver( &
if (flag_qnifa) rqnifablten(i,:)=0.
if (flag_qnbca) rqnbcablten(i,:)=0.
endif
- dozone(i,:)=dozone1(:)
+ dozone(i,kts:kte)=dozone1(kts:kte)
if (icloud_bl > 0) then
- qc_bl(i,:) =qc_bl1D(:)
- qi_bl(i,:) =qi_bl1D(:)
- cldfra_bl(i,:)=cldfra_bl1D(:)
+ qc_bl(i,kts:kte) =qc_bl1D(kts:kte)
+ qi_bl(i,kts:kte) =qi_bl1D(kts:kte)
+ cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte)
endif
- el_pbl(i,:)=el(:)
- qke(i,:) =qke1(:)
- tsq(i,:) =tsq1(:)
- qsq(i,:) =qsq1(:)
- cov(i,:) =cov1(:)
- sh3d(i,:) =sh(:)
- sm3d(i,:) =sm(:)
+ el_pbl(i,kts:kte)=el(kts:kte)
+ qke(i,kts:kte) =qke1(kts:kte)
+ tsq(i,kts:kte) =tsq1(kts:kte)
+ qsq(i,kts:kte) =qsq1(kts:kte)
+ cov(i,kts:kte) =cov1(kts:kte)
+ sh3d(i,kts:kte) =sh(kts:kte)
+ sm3d(i,kts:kte) =sm(kts:kte)
if (tke_budget .eq. 1) then
!! TKE budget is now given in m**2/s**-3 (Puhales, 2020)
@@ -1363,24 +1379,24 @@ SUBROUTINE mynn_bl_driver( &
!update updraft/downdraft properties
if (bl_mynn_output > 0) then !research mode == 1
if (bl_mynn_edmf > 0) then
- edmf_a(i,:) =edmf_a1(:)
- edmf_w(i,:) =edmf_w1(:)
- edmf_qt(i,:) =edmf_qt1(:)
- edmf_thl(i,:) =edmf_thl1(:)
- edmf_ent(i,:) =edmf_ent1(:)
- edmf_qc(i,:) =edmf_qc1(:)
- sub_thl3D(i,:)=sub_thl(:)
- sub_sqv3D(i,:)=sub_sqv(:)
- det_thl3D(i,:)=det_thl(:)
- det_sqv3D(i,:)=det_sqv(:)
+ edmf_a(i,kts:kte) =edmf_a1(kts:kte)
+ edmf_w(i,kts:kte) =edmf_w1(kts:kte)
+ edmf_qt(i,kts:kte) =edmf_qt1(kts:kte)
+ edmf_thl(i,kts:kte) =edmf_thl1(kts:kte)
+ edmf_ent(i,kts:kte) =edmf_ent1(kts:kte)
+ edmf_qc(i,kts:kte) =edmf_qc1(kts:kte)
+ sub_thl3D(i,kts:kte)=sub_thl(kts:kte)
+ sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte)
+ det_thl3D(i,kts:kte)=det_thl(kts:kte)
+ det_sqv3D(i,kts:kte)=det_sqv(kts:kte)
endif
!if (bl_mynn_edmf_dd > 0) THEN
- ! edmf_a_dd(i,:) =edmf_a_dd1(:)
- ! edmf_w_dd(i,:) =edmf_w_dd1(:)
- ! edmf_qt_dd(i,:) =edmf_qt_dd1(:)
- ! edmf_thl_dd(i,:)=edmf_thl_dd1(:)
- ! edmf_ent_dd(i,:)=edmf_ent_dd1(:)
- ! edmf_qc_dd(i,:) =edmf_qc_dd1(:)
+ ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte)
+ ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte)
+ ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte)
+ ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte)
+ ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte)
+ ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte)
!endif
endif
@@ -1509,27 +1525,27 @@ SUBROUTINE mym_initialize ( &
!
!-------------------------------------------------------------------
- integer, INTENT(IN) :: kts,kte
- integer, INTENT(IN) :: bl_mynn_mixlength
- logical, INTENT(IN) :: INITIALIZE_QKE
-! real(kind_phys), INTENT(IN) :: ust, rmo, pmz, phh, flt, flq
- real(kind_phys), INTENT(IN) :: rmo, Psig_bl, xland
- real(kind_phys), INTENT(IN) :: dx, ust, zi
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,&
+ integer, intent(in) :: kts,kte
+ integer, intent(in) :: bl_mynn_mixlength
+ logical, intent(in) :: INITIALIZE_QKE
+! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq
+ real(kind_phys), intent(in) :: rmo, Psig_bl, xland
+ real(kind_phys), intent(in) :: dx, ust, zi
+ real(kind_phys), dimension(kts:kte), intent(in) :: dz
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
+ real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,&
&qw,cldfra_bl1D,edmf_w1,edmf_a1
- real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov
- real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: el,qke
- real(kind_phys), DIMENSION(kts:kte) :: &
+ real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov
+ real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke
+ real(kind_phys), dimension(kts:kte) :: &
&ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, &
&gm,gh,sm,sh,qkw,vt,vq
- INTEGER :: k,l,lmax
+ integer :: k,l,lmax
real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., &
&flt=0.,fltv=0.,flq=0.,tmpq
- real(kind_phys), DIMENSION(kts:kte) :: theta,thetav
- real(kind_phys), DIMENSION(kts:kte) :: rstoch_col
- INTEGER ::spp_pbl
+ real(kind_phys), dimension(kts:kte) :: theta,thetav
+ real(kind_phys), dimension(kts:kte) :: rstoch_col
+ integer ::spp_pbl
!> - At first ql, vt and vq are set to zero.
DO k = kts,kte
@@ -1706,17 +1722,17 @@ SUBROUTINE mym_level2 (kts,kte, &
!
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: kts,kte
+ integer, intent(in) :: kts,kte
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v, &
+ real(kind_phys), dimension(kts:kte), intent(in) :: dz
+ real(kind_phys), dimension(kts:kte), intent(in) :: u,v, &
&thl,qw,ql,vt,vq,thetav
- real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: &
+ real(kind_phys), dimension(kts:kte), intent(out) :: &
&dtl,dqw,dtv,gm,gh,sm,sh
integer :: k
@@ -1844,25 +1860,25 @@ SUBROUTINE mym_length ( &
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: kts,kte
+ integer, intent(in) :: kts,kte
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- INTEGER, INTENT(IN) :: bl_mynn_mixlength
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw
- real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland
- real(kind_phys), INTENT(IN) :: dx,zi
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: u1,v1, &
+ integer, intent(in) :: bl_mynn_mixlength
+ real(kind_phys), dimension(kts:kte), intent(in) :: dz
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
+ real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland
+ real(kind_phys), intent(in) :: dx,zi
+ real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, &
&qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1
- real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: qkw, el
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dtv
+ real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el
+ real(kind_phys), dimension(kts:kte), intent(in) :: dtv
real(kind_phys):: elt,vsc
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: theta
- real(kind_phys), DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw
+ real(kind_phys), dimension(kts:kte), intent(in) :: theta
+ real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw
real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg
! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE
@@ -1879,22 +1895,22 @@ SUBROUTINE mym_length ( &
!THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH
!SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES
!NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt).
- real(kind_phys), PARAMETER :: minzi = 300. !< min mixed-layer height
- real(kind_phys), PARAMETER :: maxdz = 750. !< max (half) transition layer depth
+ real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height
+ real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth
!! =0.3*2500 m PBLH, so the transition
!! layer stops growing for PBLHs > 2.5 km.
- real(kind_phys), PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth
+ real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth
!SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER
- real(kind_phys), PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m)
- real(kind_phys), PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1)
+ real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m)
+ real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1)
- INTEGER :: i,j,k
+ integer :: i,j,k
real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, &
& wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, &
& PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les
- real(kind_phys), PARAMETER :: ctau = 1000. !constant for tau_cloud
+ real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud
! tv0 = 0.61*tref
! gtr = 9.81/tref
@@ -2254,13 +2270,13 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2)
! lb2 = the average of the length up and length down
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: k,kts,kte
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta
- real(kind_phys), INTENT(OUT) :: lb1,lb2
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw
+ integer, intent(in) :: k,kts,kte
+ real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta
+ real(kind_phys), intent(out) :: lb1,lb2
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
!LOCAL VARS
- INTEGER :: izz, found
+ integer :: izz, found
real(kind_phys):: dlu,dld
real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
@@ -2404,15 +2420,15 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
! lb2 = the average of the length up and length down
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: kts,kte
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta
- real(kind_phys), DIMENSION(kts:kte), INTENT(OUT):: lb1,lb2
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw
+ integer, intent(in) :: kts,kte
+ real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta
+ real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
!LOCAL VARS
- INTEGER :: iz, izz, found
- real(kind_phys), DIMENSION(kts:kte) :: dlu,dld
- real(kind_phys), PARAMETER :: Lmax=2000. !soft limit
+ integer :: iz, izz, found
+ real(kind_phys), dimension(kts:kte) :: dlu,dld
+ real(kind_phys), parameter :: Lmax=2000. !soft limit
real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
!print*,"IN MYNN-BouLac",kts, kte
@@ -2618,40 +2634,40 @@ SUBROUTINE mym_turbulence ( &
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: kts,kte
+ integer, intent(in) :: kts,kte
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget
- real(kind_phys), INTENT(IN) :: closure
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw
- real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq, &
+ integer, intent(in) :: bl_mynn_mixlength,tke_budget
+ real(kind_phys), intent(in) :: closure
+ real(kind_phys), dimension(kts:kte), intent(in) :: dz
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
+ real(kind_phys), intent(in) :: rmo,flt,fltv,flq, &
&Psig_bl,Psig_shcu,xland,dx,zi
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, &
+ real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, &
&ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, &
&TKEprodTD
- real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, &
+ real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, &
&pdk,pdt,pdq,pdc,tcd,qcd,el
- real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: &
+ real(kind_phys), dimension(kts:kte), intent(inout) :: &
qWT1D,qSHEAR1D,qBUOY1D,qDISS1D
real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new
real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp
- real(kind_phys), DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh
+ real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh
- INTEGER :: k
+ integer :: k
! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c
real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, &
&cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh
real(kind_phys):: cldavg
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: theta
+ real(kind_phys), dimension(kts:kte), intent(in) :: theta
real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod
@@ -2664,10 +2680,10 @@ SUBROUTINE mym_turbulence ( &
DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden
! Stochastic
- INTEGER, INTENT(IN) :: spp_pbl
- real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col
+ integer, intent(in) :: spp_pbl
+ real(kind_phys), dimension(kts:kte) :: rstoch_col
real(kind_phys):: Prnum, shb
- real(kind_phys), PARAMETER :: Prlimit = 5.0
+ real(kind_phys), parameter :: Prlimit = 5.0
!
! tv0 = 0.61*tref
@@ -3042,7 +3058,7 @@ SUBROUTINE mym_turbulence ( &
! q-variance (pdq), and covariance (pdc)
pdk(k) = elq*( sm(k)*gm(k) &
& +sh(k)*gh(k)+gamv ) + &
- & TKEprodTD(k)
+ & 0.5*TKEprodTD(k) ! xmchen
pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k)
pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k)
pdc(k) = elh*( sh(k)*dtl(k)+gamt ) &
@@ -3086,9 +3102,9 @@ SUBROUTINE mym_turbulence ( &
!qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE
!! Buoyncy term takes the TKEprodTD(k) production now
- qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered
+ qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen
- !!!Dissipation Term (now it evaluated on mym_predict)
+ !!!Dissipation Term (now it evaluated in mym_predict)
!qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE
!! >> EOB
@@ -3113,8 +3129,6 @@ SUBROUTINE mym_turbulence ( &
qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk )
END DO
!
-
-
if (spp_pbl==1) then
DO k = kts,kte
dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001)
@@ -3181,43 +3195,43 @@ SUBROUTINE mym_predict (kts,kte, &
& delt, &
& dz, &
& ust, flt, flq, pmz, phh, &
- & el, dfq, rho, &
+ & el, dfq, rho, &
& pdk, pdt, pdq, pdc, &
& qke, tsq, qsq, cov, &
& s_aw,s_awqke,bl_mynn_edmf_tke, &
& qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020)
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: kts,kte
+ integer, intent(in) :: kts,kte
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- real(kind_phys), INTENT(IN) :: closure
- INTEGER, INTENT(IN) :: bl_mynn_edmf_tke,tke_budget
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho
- real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc
- real(kind_phys), INTENT(IN) :: flt, flq, pmz, phh
- real(kind_phys), INTENT(IN) :: ust, delt
- real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov
+ real(kind_phys), intent(in) :: closure
+ integer, intent(in) :: bl_mynn_edmf_tke,tke_budget
+ real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho
+ real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc
+ real(kind_phys), intent(in) :: flt, flq, pmz, phh
+ real(kind_phys), intent(in) :: ust, delt
+ real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov
! WA 8/3/15
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw
+ real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw
!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
- real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D
- real(kind_phys), DIMENSION(kts:kte) :: tke_up,dzinv
+ real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D
+ real(kind_phys), dimension(kts:kte) :: tke_up,dzinv
!! >> EOB
- INTEGER :: k
- real(kind_phys), DIMENSION(kts:kte) :: qkw, bp, rp, df3q
+ integer :: k
+ real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q
real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff
- real(kind_phys), DIMENSION(kts:kte) :: dtz
- real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x
+ real(kind_phys), dimension(kts:kte) :: dtz
+ real(kind_phys), dimension(kts:kte) :: a,b,c,d,x
- real(kind_phys), DIMENSION(kts:kte) :: rhoinv
- real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz
+ real(kind_phys), dimension(kts:kte) :: rhoinv
+ real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz
! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)
IF (bl_mynn_edmf_tke == 0) THEN
@@ -3263,7 +3277,7 @@ SUBROUTINE mym_predict (kts,kte, &
kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k))
kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
ENDDO
-!JOE-end conservation mods
+ !end conservation mods
pdk1 = 2.0*ust**3*pmz/( vkz )
phm = 2.0/ust *phh/( vkz )
@@ -3271,8 +3285,8 @@ SUBROUTINE mym_predict (kts,kte, &
pdq1 = phm*flq**2
pdc1 = phm*flt*flq
!
-! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. **
- pdk(kts) = pdk1 -pdk(kts+1)
+! ** pdk(1)+pdk(2) corresponds to pdk1. **
+ pdk(kts) = pdk1 - pdk(kts+1)
!! pdt(kts) = pdt1 -pdt(kts+1)
!! pdq(kts) = pdq1 -pdq(kts+1)
@@ -3367,7 +3381,7 @@ SUBROUTINE mym_predict (kts,kte, &
ENDDO
k=kte
qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) &
- & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared
+ & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered
!! >> EOBvt
qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered
END IF
@@ -3596,39 +3610,43 @@ SUBROUTINE mym_condensation (kts,kte, &
!-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf
+ integer, intent(in) :: kts,kte, bl_mynn_cloudpdf
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- real(kind_phys), INTENT(IN) :: HFX1,rmo,xland
- real(kind_phys), INTENT(IN) :: dx,pblh1
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw, &
+ real(kind_phys), intent(in) :: HFX1,rmo,xland
+ real(kind_phys), intent(in) :: dx,pblh1
+ real(kind_phys), dimension(kts:kte), intent(in) :: dz
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
+ real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, &
&qv,qc,qi,qs,tsq,qsq,cov,th
- real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm
+ real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm
- real(kind_phys), DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH
- real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, &
+ real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH
+ real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, &
&cldfra_bl1D
DOUBLE PRECISION :: t3sq, r3sq, c3sq
real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, &
&q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, &
- &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, &
- &qmq,qsat_tk,q1_rh,rh_hack
- real(kind_phys), PARAMETER :: rhcrit=0.83 !for hom pdf min sigma
- INTEGER :: i,j,k
+ &ls,wt,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, &
+ &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc
+ real(kind_phys), parameter :: qpct_sfc=0.025
+ real(kind_phys), parameter :: qpct_pbl=0.030
+ real(kind_phys), parameter :: qpct_trp=0.040
+ real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2
+ real(kind_phys), parameter :: rhmax =1.01 !for cloudpdf = 2
+ integer :: i,j,k
real(kind_phys):: erf
!VARIABLES FOR ALTERNATIVE SIGMA
real:: dth,dtl,dqw,dzk,els
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: Sh,el
+ real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el
!variables for SGS BL clouds
real(kind_phys) :: zagl,damp,PBLH2
@@ -3636,11 +3654,11 @@ SUBROUTINE mym_condensation (kts,kte, &
!JAYMES: variables for tropopause-height estimation
real(kind_phys) :: theta1, theta2, ht1, ht2
- INTEGER :: k_tropo
+ integer :: k_tropo
! Stochastic
- INTEGER, INTENT(IN) :: spp_pbl
- real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col
+ integer, intent(in) :: spp_pbl
+ real(kind_phys), dimension(kts:kte) :: rstoch_col
real(kind_phys) :: qw_pert
! First, obtain an estimate for the tropopause height (k), using the method employed in the
@@ -3794,29 +3812,31 @@ SUBROUTINE mym_condensation (kts,kte, &
!Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS
!but with use of higher-order moments to estimate sigma
- PBLH2=MAX(10.,PBLH1)
+ pblh2=MAX(10._kind_phys,pblh1)
zagl = 0.
+ dzm1 = 0.
DO k = kts,kte-1
- zagl = zagl + dz(k)
- t = th(k)*exner(k)
+ zagl = zagl + 0.5*(dz(k) + dzm1)
+ dzm1 = dz(k)
- xl = xl_blend(t) ! obtain latent heat
- qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p
- rh(k)=MAX(MIN(1.00,qw(k)/MAX(1.E-10,qsat_tk)),0.001)
+ t = th(k)*exner(k)
+ xl = xl_blend(t) ! obtain latent heat
+ qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p
+ rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys)
!dqw/dT: Clausius-Clapeyron
- dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 )
+ dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 )
alp(k) = 1.0/( 1.0+dqsl*xlvcp )
bet(k) = dqsl*exner(k)
- rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature)
+ rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature)
! CB02, Eqn. 4
- cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1
- a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a"
- b(k) = a(k)*rsl ! CB02 variable "b"
+ cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1
+ a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a"
+ b(k) = a(k)*rsl ! CB02 variable "b"
!SPP
- qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl)
+ qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl)
!This form of qmq (the numerator of Q1) no longer uses the a(k) factor
qmq = qw_pert - qsat_tk ! saturation deficit/excess;
@@ -3826,28 +3846,46 @@ SUBROUTINE mym_condensation (kts,kte, &
r3sq = max( qsq(k), 0.0 )
!Calculate sigma using higher-order moments:
sgm(k) = SQRT( r3sq )
- !Set limits on sigma relative to saturation water vapor
+ !Set constraints on sigma relative to saturation water vapor
sgm(k) = min( sgm(k), qsat_tk*0.666 )
- sgm(k) = max( sgm(k), qsat_tk*0.035 )
+ !sgm(k) = max( sgm(k), qsat_tk*0.035 )
+
+ !introduce vertical grid spacing dependence on min sgm
+ wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m
+ sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz
+
+ !allow min sgm to vary with dz and z.
+ qpct = qpct_pbl*wt + qpct_trp*(1.0-wt)
+ qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) )
+ sgm(k) = max( sgm(k), qsat_tk*qpct )
+
q1(k) = qmq / sgm(k) ! Q1, the normalized saturation
!Add condition for falling/settling into low-RH layers, so at least
- !some cloud fraction is applied for all qc and qi.
- rh_hack = rh(k)
- !ensure adequate RH & q1 when qi is at least 1e-9
- if (qi(k)>1.e-9) then
- rh_hack =min(1.0, rhcrit + 0.06*(9.0 + log10(qi(k))))
+ !some cloud fraction is applied for all qc, qs, and qi.
+ rh_hack= rh(k)
+ !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH)
+ if (qi(k)>1.e-9 .and. zagl .gt. pblh2) then
+ rh_hack =min(rhmax, rhcrit + 0.07*(9.0 + log10(qi(k))))
rh(k) =max(rh(k), rh_hack)
!add rh-based q1
- q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit)
+ q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)
q1(k) =max(q1_rh, q1(k) )
endif
!ensure adequate RH & q1 when qc is at least 1e-6
if (qc(k)>1.e-6) then
- rh_hack =min(1.0, rhcrit + 0.09*(6.0 + log10(qc(k))))
+ rh_hack =min(rhmax, rhcrit + 0.09*(6.0 + log10(qc(k))))
+ rh(k) =max(rh(k), rh_hack)
+ !add rh-based q1
+ q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)
+ q1(k) =max(q1_rh, q1(k) )
+ endif
+ !ensure adequate RH & q1 when qs is at least 1e-8 (above the PBLH)
+ if (qs(k)>1.e-8 .and. zagl .gt. pblh2) then
+ rh_hack =min(rhmax, rhcrit + 0.07*(8.0 + log10(qs(k))))
rh(k) =max(rh(k), rh_hack)
!add rh-based q1
- q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit)
+ q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)
q1(k) =max(q1_rh, q1(k) )
endif
@@ -3864,20 +3902,17 @@ SUBROUTINE mym_condensation (kts,kte, &
! Specify hydrometeors
! JAYMES- this option added 8 May 2015
! The cloud water formulations are taken from CB02, Eq. 8.
- IF (q1k < 0.) THEN !unsaturated
-#ifdef SINGLE_PREC
- ql_water = sgm(k)*EXP(1.2*q1k-1.)
-#else
- ql_water = sgm(k)*EXP(1.2*q1k-1.)
-#endif
- ql_ice = sgm(k)*EXP(1.2*q1k-1.)
- ELSE IF (q1k > 2.) THEN !supersaturated
- ql_water = sgm(k)*q1k
- ql_ice = sgm(k)*q1k
- ELSE !slightly saturated (0 > q1 < 2)
- ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2)
- ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2)
- ENDIF
+ maxqc = max(qw(k) - qsat_tk, 0.0)
+ if (q1k < 0.) then !unsaturated
+ ql_water = sgm(k)*exp(1.2*q1k-1.)
+ ql_ice = sgm(k)*exp(1.2*q1k-1.)
+ elseif (q1k > 2.) then !supersaturated
+ ql_water = min(sgm(k)*q1k, maxqc)
+ ql_ice = sgm(k)*q1k
+ else !slightly saturated (0 > q1 < 2)
+ ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc)
+ ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2)
+ endif
!In saturated grid cells, use average of SGS and resolved values
!if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) )
@@ -3922,17 +3957,22 @@ SUBROUTINE mym_condensation (kts,kte, &
! Fng = 1.-1.5*q1k
!ENDIF
! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS)
- IF (q1k .GE. 1.0) THEN
+ if (q1k .ge. 1.0) then
Fng = 1.0
- ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN
- Fng = EXP(-0.4*(q1k-1.0))
- ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN
- Fng = 3.0 + EXP(-3.8*(q1k+1.7))
- ELSE
- Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.)
- ENDIF
+ elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then
+ Fng = exp(-0.4*(q1k-1.0))
+ elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then
+ Fng = 3.0 + exp(-3.8*(q1k+1.7))
+ else
+ Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys)
+ endif
+
+ cfmax = min(cldfra_bl1D(k), 0.6_kind_phys)
+ !Further limit the cf going into vt & vq near the surface
+ zsl = min(max(25., 0.1*pblh2), 100.)
+ wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer
+ cfmax = cfmax*wt
- cfmax= min(cldfra_bl1D(k), 0.6)
bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from
! "b" in CB02 (i.e., b(k) above) by a factor
! of T/theta. Strictly, b(k) above is formulated in
@@ -4023,17 +4063,17 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
&bl_mynn_mixscalars )
!-------------------------------------------------------------------
- INTEGER, INTENT(in) :: kts,kte,i
+ integer, intent(in) :: kts,kte,i
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, &
+ integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, &
bl_mynn_edmf,bl_mynn_edmf_mom, &
bl_mynn_mixscalars
- LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, &
+ logical, intent(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, &
&FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA
! thl - liquid water potential temperature
@@ -4043,47 +4083,47 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
! flq - surface flux of qw
! mass-flux plumes
- real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: s_aw, &
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw, &
&s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, &
&s_awqnwfa,s_awqnifa,s_awqnbca, &
&sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv
! tendencies from mass-flux environmental subsidence and detrainment
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, &
+ real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, &
&sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v
- real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,&
+ real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,&
&qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, &
&cldfra_bl1d,diss_heat
- real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,&
+ real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,&
&sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh
- real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv, &
+ real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, &
&dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone
- real(kind_phys), INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce
- real(kind_phys), INTENT(IN) :: ust,delt,psfc,wspd
+ real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce
+ real(kind_phys), intent(in) :: ust,delt,psfc,wspd
!debugging
real(kind_phys):: wsp,wsp2,tk2,th2
- LOGICAL :: problem
+ logical :: problem
integer :: kproblem
-! real(kind_phys), INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top
+! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top
!local vars
- real(kind_phys), DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp
- real(kind_phys), DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, &
+ real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp
+ real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, &
&qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2
- real(kind_phys), DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv
- real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x
- real(kind_phys), DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface
+ real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv
+ real(kind_phys), dimension(kts:kte) :: a,b,c,d,x
+ real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface
&khdz,kmdz
real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw
real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc
real(kind_phys):: ustdrag,ustdiff,qvflux
real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat
- INTEGER :: k,kk
+ integer :: k,kk
!Activate nonlocal mixing from the mass-flux scheme for
!number concentrations and aerosols (0.0 = no; 1.0 = yes)
- real(kind_phys), PARAMETER :: nonloc = 1.0
+ real(kind_phys), parameter :: nonloc = 1.0
dztop=.5*(dz(kte)+dz(kte-1))
@@ -4586,7 +4626,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
!============================================
! MIX SNOW ( sqs )
!============================================
-IF (bl_mynn_cloudmix > 0 .AND. FLAG_QS) THEN
+!hard-code to not mix snow
+IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN
k=kts
!rho-weighted:
@@ -4813,8 +4854,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
d(kte)=qnbca(kte)
! CALL tridiag(kte,a,b,c,d)
-! CALL tridiag2(kte,a,b,c,d,x)
- CALL tridiag3(kte,a,b,c,d,x)
+ CALL tridiag2(kte,a,b,c,d,x)
+! CALL tridiag3(kte,a,b,c,d,x)
DO k=kts,kte
!qnbca2(k)=d(k-kts+1)
@@ -4891,9 +4932,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
sqi2(k) = 0.0 ! if sqw2 > qsat
sqc2(k) = 0.0
ENDIF
- !dqv(k) = (sqv2(k) - sqv(k))/delt
- !dqc(k) = (sqc2(k) - sqc(k))/delt
- !dqi(k) = (sqi2(k) - sqi(k))/delt
ENDDO
ENDIF
@@ -4902,7 +4940,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
! WATER VAPOR TENDENCY
!=====================
DO k=kts,kte
- Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt
+ Dqv(k)=(sqv2(k) - sqv(k))/delt
!if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k
ENDDO
@@ -4913,7 +4951,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
!print*,"FLAG_QC:",FLAG_QC
IF (FLAG_QC) THEN
DO k=kts,kte
- Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt
+ Dqc(k)=(sqc2(k) - sqc(k))/delt
!if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k
ENDDO
ELSE
@@ -4941,7 +4979,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
!===================
IF (FLAG_QI) THEN
DO k=kts,kte
- Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt
+ Dqi(k)=(sqi2(k) - sqi(k))/delt
!if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k
ENDDO
ELSE
@@ -4953,9 +4991,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
!===================
! CLOUD SNOW TENDENCY
!===================
- IF (FLAG_QS) THEN
+ IF (.false.) THEN !disabled
DO k=kts,kte
- Dqs(k)=(sqs2(k)/(1.-sqs2(k)) - qs(k))/delt
+ Dqs(k)=(sqs2(k) - sqs(k))/delt
ENDDO
ELSE
DO k=kts,kte
@@ -4979,10 +5017,11 @@ SUBROUTINE mynn_tendencies(kts,kte,i, &
ELSE !-MIX CLOUD SPECIES?
!CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0)
DO k=kts,kte
- Dqc(k)=0.
+ Dqc(k) =0.
Dqnc(k)=0.
- Dqi(k)=0.
+ Dqi(k) =0.
Dqni(k)=0.
+ Dqs(k) =0.
ENDDO
ENDIF
@@ -5207,36 +5246,36 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, &
enh_mix, smoke_dbg )
!-------------------------------------------------------------------
- INTEGER, INTENT(in) :: kts,kte,i
- real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd
- real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: rho
- real(kind_phys), INTENT(IN) :: flt
- real(kind_phys), INTENT(IN) :: delt,pblh
- INTEGER, INTENT(IN) :: nchem, kdvel, ndvel
- real(kind_phys), DIMENSION( kts:kte+1), INTENT(IN) :: s_aw
- real(kind_phys), DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1
- real(kind_phys), DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem
- real(kind_phys), DIMENSION( ndvel ), INTENT(IN) :: vd1
- real(kind_phys), INTENT(IN) :: emis_ant_no,frp
- LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg
+ integer, intent(in) :: kts,kte,i
+ real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd
+ real(kind_phys), dimension(kts:kte), intent(inout) :: rho
+ real(kind_phys), intent(in) :: flt
+ real(kind_phys), intent(in) :: delt,pblh
+ integer, intent(in) :: nchem, kdvel, ndvel
+ real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw
+ real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1
+ real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem
+ real(kind_phys), dimension( ndvel ), intent(in) :: vd1
+ real(kind_phys), intent(in) :: emis_ant_no,frp
+ logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg
!local vars
- real(kind_phys), DIMENSION(kts:kte) :: dtz
- real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x
+ real(kind_phys), dimension(kts:kte) :: dtz
+ real(kind_phys), dimension(kts:kte) :: a,b,c,d,x
real(kind_phys):: rhs,dztop
real(kind_phys):: t,dzk
real(kind_phys):: hght
real(kind_phys):: khdz_old, khdz_back
- INTEGER :: k,kk,kmaxfire ! JLS 12/21/21
- INTEGER :: ic ! Chemical array loop index
+ integer :: k,kk,kmaxfire ! JLS 12/21/21
+ integer :: ic ! Chemical array loop index
- INTEGER, SAVE :: icall
+ integer, SAVE :: icall
- real(kind_phys), DIMENSION(kts:kte) :: rhoinv
- real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,khdz
- real(kind_phys), PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources
- real(kind_phys), PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires
- real(kind_phys), PARAMETER :: pblh_threshold = 100.0
+ real(kind_phys), dimension(kts:kte) :: rhoinv
+ real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz
+ real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources
+ real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires
+ real(kind_phys), parameter :: pblh_threshold = 100.0
dztop=.5*(dz(kte)+dz(kte-1))
@@ -5335,14 +5374,14 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,&
!-------------------------------------------------------------------
- INTEGER , INTENT(in) :: kts,kte
+ integer , intent(in) :: kts,kte
- real(kind_phys), DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh
+ real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh
- real(kind_phys), DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h
+ real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h
- INTEGER :: k
+ integer :: k
real(kind_phys):: dzk
K_m(kts)=0.
@@ -5368,13 +5407,13 @@ SUBROUTINE tridiag(n,a,b,c,d)
!-------------------------------------------------------------------
- INTEGER, INTENT(in):: n
- real(kind_phys), DIMENSION(n), INTENT(in) :: a,b
- real(kind_phys), DIMENSION(n), INTENT(inout) :: c,d
+ integer, intent(in):: n
+ real(kind_phys), dimension(n), intent(in) :: a,b
+ real(kind_phys), dimension(n), intent(inout) :: c,d
- INTEGER :: i
+ integer :: i
real(kind_phys):: p
- real(kind_phys), DIMENSION(n) :: q
+ real(kind_phys), dimension(n) :: q
c(n)=0.
q(1)=-c(1)/b(1)
@@ -5508,23 +5547,23 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
!value could be found to work best in all conditions.
!---------------------------------------------------------------
- INTEGER,INTENT(IN) :: KTS,KTE
+ integer,intent(in) :: KTS,KTE
#ifdef HARDCODE_VERTICAL
# define kts 1
# define kte HARDCODE_VERTICAL
#endif
- real(kind_phys), INTENT(OUT) :: zi
- real(kind_phys), INTENT(IN) :: landsea
- real(kind_phys), DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D
- real(kind_phys), DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D
+ real(kind_phys), intent(out) :: zi
+ real(kind_phys), intent(in) :: landsea
+ real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D
!LOCAL VARS
real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv
real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point
- real(kind_phys), PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m).
- real(kind_phys), PARAMETER :: sbl_damp = 400. !transition length for blending (m).
- INTEGER :: I,J,K,kthv,ktke,kzi
+ real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m).
+ real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m).
+ integer :: I,J,K,kthv,ktke,kzi
!Initialize KPBL (kzi)
kzi = 2
@@ -5689,12 +5728,12 @@ SUBROUTINE DMP_mf( &
& F_QNWFA,F_QNIFA,F_QNBCA, &
& Psig_shcu, &
! output info
- & nup2,ktop,maxmf,ztop, &
+ & maxwidth,ktop,maxmf,ztop, &
! inputs for stochastic perturbations
& spp_pbl,rstoch_col )
! inputs:
- INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt
+ integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt
#ifdef HARDCODE_VERTICAL
# define kts 1
@@ -5702,133 +5741,137 @@ SUBROUTINE DMP_mf( &
#endif
! Stochastic
- INTEGER, INTENT(IN) :: spp_pbl
- real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col
+ integer, intent(in) :: spp_pbl
+ real(kind_phys), dimension(kts:kte) :: rstoch_col
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: &
+ real(kind_phys),dimension(kts:kte), intent(in) :: &
&U,V,W,TH,THL,TK,QT,QV,QC, &
&exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca
- real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma
- real(kind_phys), INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu, &
+ real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma
+ real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, &
&landsea,ts,dx,dt,ust,pblh
- LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA
+ logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA
! outputs - updraft properties
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, &
+ real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, &
& edmf_qt,edmf_thl,edmf_ent,edmf_qc
!add one local edmf variable:
- real(kind_phys),DIMENSION(KTS:KTE) :: edmf_th
+ real(kind_phys),dimension(kts:kte) :: edmf_th
! output
- INTEGER, INTENT(OUT) :: nup2,ktop
- real(kind_phys), INTENT(OUT) :: maxmf
- real(kind_phys), INTENT(OUT) :: ztop
+ integer, intent(out) :: ktop
+ real(kind_phys), intent(out) :: maxmf,ztop,maxwidth
! outputs - variables needed for solver
- real(kind_phys),DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi
+ real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi
&s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, &
&s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, &
&s_awqke,s_aw2
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: &
+ real(kind_phys),dimension(kts:kte), intent(inout) :: &
&qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old
- INTEGER, PARAMETER :: nup=10, debug_mf=0
+ integer, parameter :: nup=8, debug_mf=0
+ real(kind_phys) :: nup2
!------------- local variables -------------------
! updraft properties defined on interfaces (k=1 is the top of the
! first model layer
- real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP) :: &
+ real(kind_phys),dimension(kts:kte+1,1:NUP) :: &
&UPW,UPTHL,UPQT,UPQC,UPQV, &
&UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, &
&UPQNI,UPQNWFA,UPQNIFA,UPQNBCA
! entrainment variables
- real(kind_phys),DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf
- INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi
+ real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf
+ integer,dimension(kts:kte,1:NUP) :: ENTi
! internal variables
- INTEGER :: K,I,k50
+ integer :: K,I,k50
real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, &
&sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl
real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, &
- QNWFAn,QNIFAn,QNBCAn, &
- Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int
+ & QNWFAn,QNIFAn,QNBCAn, &
+ & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int
! w parameters
- real(kind_phys), PARAMETER :: &
+ real(kind_phys), parameter :: &
&Wa=2./3., &
&Wb=0.002, &
&Wc=1.5
! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from
! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2.
- real(kind_phys),PARAMETER :: &
- & L0=100., &
- & ENT0=0.1
-
- ! Implement ideas from Neggers (2016, JAMES):
- real(kind_phys), PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts
- real(kind_phys), PARAMETER :: lmax = 1000.! diameter of largest plume
- real(kind_phys), PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand
- real(kind_phys), PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km)
- real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d).
+ real(kind_phys),parameter :: &
+ & L0=100., &
+ & ENT0=0.1
+
+ ! Parameters/variables for regulating plumes:
+ real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts
+ real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller)
+ real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger)
+ real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv)
+ real(kind_phys) :: minwidth ! actual width of smallest plume
+ real(kind_phys) :: dl ! variable increment of plume size
+ real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km)
+ real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d).
! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes.
! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes.
- real(kind_phys):: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx
+ real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx
! chem/smoke
- INTEGER, INTENT(IN) :: nchem
- real(kind_phys),DIMENSION(:, :) :: chem1
- real(kind_phys),DIMENSION(kts:kte+1, nchem) :: s_awchem
- real(kind_phys),DIMENSION(nchem) :: chemn
- real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM
- INTEGER :: ic
- real(kind_phys),DIMENSION(KTS:KTE+1, nchem) :: edmf_chem
- LOGICAL, INTENT(IN) :: mix_chem
+ integer, intent(in) :: nchem
+ real(kind_phys),dimension(:, :) :: chem1
+ real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem
+ real(kind_phys),dimension(nchem) :: chemn
+ real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM
+ integer :: ic
+ real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem
+ logical, intent(in) :: mix_chem
!JOE: add declaration of ERF
real(kind_phys):: ERF
- LOGICAL :: superadiabatic
+ logical :: superadiabatic
! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm
+ real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm
real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,&
Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, &
Ac_mf,Ac_strat,qc_mf
- real(kind_phys), PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value
+ real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value
! Variables for plume interpolation/saturation check
- real(kind_phys),DIMENSION(KTS:KTE) :: exneri,dzi
+ real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz
real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl
- real(kind_phys):: csigma,acfac,ac_wsp,ac_cld
+ real(kind_phys):: csigma,acfac,ac_wsp
!plume overshoot
- INTEGER :: overshoot
+ integer :: overshoot
real(kind_phys):: bvf, Frz, dzp
!Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux).
!This limiter makes adjustments to the entire column.
real(kind_phys):: adjustment, flx1
- real(kind_phys), PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact
+ real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that
+ ! 0.5 starts to have a noticeable impact
! over land (decrease maxMF by 10-20%), but no impact over water.
!Subsidence
- real(kind_phys),DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence
+ real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence
det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment
envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, &
envm_u,envm_v !environmental variables defined at middle of layer
- real(kind_phys),DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface
+ real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface
real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, &
detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, &
- qc_plume,exc_heat,exc_moist,tk_int
- real(kind_phys), PARAMETER :: Cdet = 1./45.
- real(kind_phys), PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers
+ qc_plume,exc_heat,exc_moist,tk_int,tvs
+ real(kind_phys), parameter :: Cdet = 1./45.
+ real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers
!parameter "Csub" determines the propotion of upward vertical velocity that contributes to
!environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of
!gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme
!is compensated by "gentle" environmental subsidence.
- real(kind_phys), PARAMETER :: Csub=0.25
+ real(kind_phys), parameter :: Csub=0.25
!Factor for the pressure gradient effects on momentum transport
- real(kind_phys), PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere
+ real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere
real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa
! check the inputs
@@ -5859,9 +5902,9 @@ SUBROUTINE DMP_mf( &
UPQNWFA=0.
UPQNIFA=0.
UPQNBCA=0.
- IF ( mix_chem ) THEN
- UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0
- ENDIF
+ if ( mix_chem ) then
+ UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0
+ endif
ENT=0.001
! Initialize mean updraft properties
@@ -5871,9 +5914,9 @@ SUBROUTINE DMP_mf( &
edmf_thl=0.
edmf_ent=0.
edmf_qc =0.
- IF ( mix_chem ) THEN
+ if ( mix_chem ) then
edmf_chem(kts:kte+1,1:nchem) = 0.0
- ENDIF
+ endif
! Initialize the variables needed for implicit solver
s_aw=0.
@@ -5889,153 +5932,163 @@ SUBROUTINE DMP_mf( &
s_awqnwfa=0.
s_awqnifa=0.
s_awqnbca=0.
- IF ( mix_chem ) THEN
+ if ( mix_chem ) then
s_awchem(kts:kte+1,1:nchem) = 0.0
- ENDIF
+ endif
! Initialize explicit tendencies for subsidence & detrainment
sub_thl = 0.
sub_sqv = 0.
- sub_u = 0.
- sub_v = 0.
+ sub_u = 0.
+ sub_v = 0.
det_thl = 0.
det_sqv = 0.
det_sqc = 0.
- det_u = 0.
- det_v = 0.
+ det_u = 0.
+ det_v = 0.
+ nup2 = nup !start with nup, but set to zero if activation criteria fails
! Taper off MF scheme when significant resolved-scale motions
! are present This function needs to be asymetric...
- k = 1
- maxw = 0.0
+ maxw = 0.0
cloud_base = 9000.0
-! DO WHILE (ZW(k) < pblh + 500.)
- DO k=1,kte-1
- IF(zw(k) > pblh + 500.) exit
+ do k=1,kte-1
+ if (zw(k) > pblh + 500.) exit
wpbl = w(k)
- IF(w(k) < 0.)wpbl = 2.*w(k)
- maxw = MAX(maxw,ABS(wpbl))
+ if (w(k) < 0.)wpbl = 2.*w(k)
+ maxw = max(maxw,abs(wpbl))
!Find highest k-level below 50m AGL
- IF(ZW(k)<=50.)k50=k
+ if (ZW(k)<=50.)k50=k
!Search for cloud base
- qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k))
- IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN
+ qc_sgs = max(qc(k), qc_bl1d(k))
+ if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then
cloud_base = 0.5*(ZW(k)+ZW(k+1))
- ENDIF
+ endif
+ enddo
- !k = k + 1
- ENDDO
- !print*," maxw before manipulation=", maxw
- maxw = MAX(0.,maxw - 1.0) ! do nothing for small w (< 1 m/s), but
- Psig_w = MAX(0.0, 1.0 - maxw) ! linearly taper off for w > 1.0 m/s
- Psig_w = MIN(Psig_w, Psig_shcu)
- !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu
+ !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s
+ maxw = max(0.,maxw - 1.0)
+ Psig_w = max(0.0, 1.0 - maxw)
+ Psig_w = min(Psig_w, Psig_shcu)
!Completely shut off MF scheme for strong resolved-scale vertical velocities.
fltv2 = fltv
- IF(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv
+ if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv
! If surface buoyancy is positive we do integration, otherwise no.
! Also, ensure that it is at least slightly superadiabatic up through 50 m
superadiabatic = .false.
- IF((landsea-1.5).GE.0)THEN
+ if ((landsea-1.5).ge.0) then
hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m.
- ELSE
+ else
hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m.
- ENDIF
- DO k=1,MAX(1,k50-1) !use "-1" because k50 used interface heights (zw).
- IF (k == 1) then
- IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN
+ endif
+ tvs = ts*(1.0+p608*qv(kts))
+ do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw).
+ if (k == 1) then
+ if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then
superadiabatic = .true.
- ELSE
+ else
superadiabatic = .false.
exit
- ENDIF
- ELSE
- IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN
+ endif
+ else
+ if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then
superadiabatic = .true.
- ELSE
+ else
superadiabatic = .false.
exit
- ENDIF
- ENDIF
- ENDDO
+ endif
+ endif
+ enddo
! Determine the numer of updrafts/plumes in the grid column:
! Some of these criteria may be a little redundant but useful for bullet-proofing.
- ! (1) largest plume = 1.0 * dx.
- ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist.
+ ! (1) largest plume = 1.2 * dx.
+ ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist.
! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base.
! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes)
! (5) limit to reduce max plume sizes in weakly forced conditions. This is only
! meant to "soften" the activation of the mass-flux scheme.
! Criteria (1)
- NUP2 = max(1,min(NUP,INT(dx*dcut/dl)))
+ maxwidth = min(dx*dcut, lmax)
!Criteria (2)
- maxwidth = 1.1*PBLH
+ maxwidth = min(maxwidth, 1.1_kind_phys*PBLH)
! Criteria (3)
- maxwidth = MIN(maxwidth,0.5*cloud_base)
+ if ((landsea-1.5) .lt. 0) then !land
+ maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base)
+ else !water
+ maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base)
+ endif
! Criteria (4)
- wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01))
+ wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys))
!Note: area fraction (acfac) is modified below
! Criteria (5) - only a function of flt (not fltv)
if ((landsea-1.5).LT.0) then !land
- !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.)
- width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.)
+ width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys)
else !water
- width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.)
+ width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys)
+ endif
+ maxwidth = MIN(maxwidth, width_flx)
+ minwidth = lmin
+ !allow min plume size to increase in large flux conditions (eddy diffusivity should be
+ !large enough to handle the representation of small plumes).
+ if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys)
+
+ if (maxwidth .le. minwidth) then ! deactivate MF component
+ nup2 = 0
+ maxwidth = 0.0
endif
- maxwidth = MIN(maxwidth,width_flx)
- ! Convert maxwidth to number of plumes
- NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2)
- !Initialize values for 2d output fields:
- ktop = 0
- ztop = 0.0
- maxmf= 0.0
+ ! Initialize values for 2d output fields:
+ ktop = 0
+ ztop = 0.0
+ maxmf= 0.0
- IF ( fltv2 > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then
- !PRINT*," Conditions met to run mass-flux scheme",fltv2,pblh
+!Begin plume processing if passes criteria
+if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then
! Find coef C for number size density N
cn = 0.
- d=-1.9 !set d to value suggested by Neggers 2015 (JAMES).
- !d=-1.9 + .2*tanh((fltv2 - 0.05)/0.15)
- do I=1,NUP !NUP2
- IF(I > NUP2) exit
- l = dl*I ! diameter of plume
+ d =-1.9 !set d to value suggested by Neggers 2015 (JAMES).
+ dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys)
+ do i=1,NUP
+ ! diameter of plume
+ l = minwidth + dl*real(i-1)
cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume
enddo
C = Atot/cn !Normalize C according to the defined total fraction (Atot)
! Make updraft area (UPA) a function of the buoyancy flux
if ((landsea-1.5).LT.0) then !land
- !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5
- !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5
acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5
else !water
acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5
endif
!add a windspeed-dependent adjustment to acfac that tapers off
- !the mass-flux scheme linearly above sfc wind speeds of 20 m/s:
- ac_wsp = 1.0 - min(max(wspd_pbl - 20.0, 0.0), 10.0)/10.0
- !reduce area fraction beneath cloud bases < 1200 m AGL
- ac_cld = min(cloud_base/1200., 1.0)
- acfac = acfac * min(ac_wsp, ac_cld)
+ !the mass-flux scheme linearly above sfc wind speeds of 10 m/s.
+ !Note: this effect may be better represented by an increase in
+ !entrainment rate for high wind consitions (more ambient turbulence).
+ if (wspd_pbl .le. 10.) then
+ ac_wsp = 1.0
+ else
+ ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0)
+ endif
+ acfac = acfac * ac_wsp
! Find the portion of the total fraction (Atot) of each plume size:
An2 = 0.
- do I=1,NUP !NUP2
- IF(I > NUP2) exit
- l = dl*I ! diameter of plume
+ do i=1,NUP
+ ! diameter of plume
+ l = minwidth + dl*real(i-1)
N = C*l**d ! number density of plume n
- UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n
+ UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n
- UPA(1,I) = UPA(1,I)*acfac
- An2 = An2 + UPA(1,I) ! total fractional area of all plumes
+ UPA(1,i) = UPA(1,i)*acfac
+ An2 = An2 + UPA(1,i) ! total fractional area of all plumes
!print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2
end do
@@ -6048,23 +6101,25 @@ SUBROUTINE DMP_mf( &
qstar=max(flq,1.0E-5)/wstar
thstar=flt/wstar
- IF((landsea-1.5).GE.0)THEN
+ if ((landsea-1.5) .ge. 0) then
csigma = 1.34 ! WATER
- ELSE
+ else
csigma = 1.34 ! LAND
- ENDIF
+ endif
if (env_subs) then
exc_fac = 0.0
else
if ((landsea-1.5).GE.0) then
!water: increase factor to compensate for decreased pwmin/pwmax
- exc_fac = 0.58*4.0*min(cloud_base/1000., 1.0)
+ exc_fac = 0.58*4.0
else
!land: no need to increase factor - already sufficiently large superadiabatic layers
exc_fac = 0.58
endif
endif
+ !decrease excess for large wind speeds
+ exc_fac = exc_fac * ac_wsp
!Note: sigmaW is typically about 0.5*wstar
sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh)
@@ -6077,14 +6132,11 @@ SUBROUTINE DMP_mf( &
wmax=MIN(sigmaW*pwmax,0.5)
!SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2
- DO I=1,NUP !NUP2
- IF(I > NUP2) exit
+ do i=1,NUP
wlv=wmin+(wmax-wmin)/NUP2*(i-1)
!SURFACE UPDRAFT VERTICAL VELOCITY
UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin)
- !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt
-
UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
UPQC(1,I)=0.0
@@ -6093,21 +6145,11 @@ SUBROUTINE DMP_mf( &
exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW
UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) &
& + exc_heat
-!was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface
UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) &
& + exc_heat
!calculate exc_moist by use of surface fluxes
exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW
- !calculate exc_moist by conserving rh:
-! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
-! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
-! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))
-! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p
-! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001)
-! tk_int = tk_int + exc_heat
-! qsat_tk = qsat_blend(tk_int, pk)
-! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0)
UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))&
& +exc_moist
@@ -6117,36 +6159,36 @@ SUBROUTINE DMP_mf( &
UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
- ENDDO
+ enddo
- IF ( mix_chem ) THEN
- DO I=1,NUP !NUP2
- IF(I > NUP2) exit
+ if ( mix_chem ) then
+ do i=1,NUP
do ic = 1,nchem
- UPCHEM(1,I,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
+ UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
enddo
- ENDDO
- ENDIF
+ enddo
+ endif
!Initialize environmental variables which can be modified by detrainment
- DO k=kts,kte
- envm_thl(k)=THL(k)
- envm_sqv(k)=QV(k)
- envm_sqc(k)=QC(k)
- envm_u(k)=U(k)
- envm_v(k)=V(k)
- ENDDO
+ envm_thl(kts:kte)=THL(kts:kte)
+ envm_sqv(kts:kte)=QV(kts:kte)
+ envm_sqc(kts:kte)=QC(kts:kte)
+ envm_u(kts:kte)=U(kts:kte)
+ envm_v(kts:kte)=V(kts:kte)
+ do k=kts,kte-1
+ rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
+ enddo
+ rhoz(kte) = rho(kte)
!dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport
dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.)
! do integration updraft
- DO I=1,NUP !NUP2
- IF(I > NUP2) exit
+ do i=1,NUP
QCn = 0.
overshoot = 0
- l = dl*I ! diameter of plume
- DO k=KTS+1,KTE-1
+ l = minwidth + dl*real(i-1) ! diameter of plume
+ do k=kts+1,kte-1
!Entrainment from Tian and Kuang (2016)
!ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l)
wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh
@@ -6161,7 +6203,7 @@ SUBROUTINE DMP_mf( &
ENT(k,i) = max(ENT(k,i),0.0003)
!ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang
- !JOE - increase entrainment for plumes extending very high.
+ !increase entrainment for plumes extending very high.
IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN
ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6
ENDIF
@@ -6339,6 +6381,7 @@ SUBROUTINE DMP_mf( &
exit !exit k-loop
END IF
ENDDO
+
IF (debug_mf == 1) THEN
IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. &
MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN
@@ -6358,30 +6401,26 @@ SUBROUTINE DMP_mf( &
ENDIF
ENDIF
ENDDO
- ELSE
+ELSE
!At least one of the conditions was not met for activating the MF scheme.
NUP2=0.
- END IF !end criteria for mass-flux scheme
+END IF !end criteria check for mass-flux scheme
- ktop=MIN(ktop,KTE-1) ! Just to be safe...
- IF (ktop == 0) THEN
- ztop = 0.0
- ELSE
- ztop=zw(ktop)
- ENDIF
-
- IF(nup2 > 0) THEN
+ktop=MIN(ktop,KTE-1)
+IF (ktop == 0) THEN
+ ztop = 0.0
+ELSE
+ ztop=zw(ktop)
+ENDIF
- !Calculate the fluxes for each variable
- !All s_aw* variable are == 0 at k=1
- DO i=1,NUP !NUP2
- IF(I > NUP2) exit
+IF (nup2 > 0) THEN
+ !Calculate the fluxes for each variable
+ !All s_aw* variable are == 0 at k=1
+ DO i=1,NUP
DO k=KTS,KTE-1
- IF(k > ktop) exit
- rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
- s_aw(k+1) = s_aw(k+1) + rho_int*UPA(K,i)*UPW(K,i)*Psig_w
- s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w
- s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w
+ s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w
+ s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w
+ s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w
!to conform to grid mean properties, move qc to qv in grid mean
!saturated layers, so total water fluxes are preserved but
!negative qc fluxes in unsaturated layers is reduced.
@@ -6390,72 +6429,76 @@ SUBROUTINE DMP_mf( &
! else
! qc_plume = 0.0
! endif
- s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w
- IF (momentum_opt > 0) THEN
- s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w
- s_awv(k+1) = s_awv(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w
- ENDIF
- IF (tke_opt > 0) THEN
- s_awqke(k+1)= s_awqke(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w
- ENDIF
+ s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w
s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1)
ENDDO
- ENDDO
-
- IF ( mix_chem ) THEN
- DO k=KTS,KTE
- IF(k > KTOP) exit
- rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
- DO i=1,NUP !NUP2
- IF(I > NUP2) exit
- do ic = 1,nchem
- s_awchem(k+1,ic) = s_awchem(k+1,ic) + rho_int*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w
- enddo
- ENDDO
- ENDDO
- ENDIF
-
- IF (scalar_opt > 0) THEN
- DO k=KTS,KTE
- IF(k > KTOP) exit
- rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
- DO I=1,NUP !NUP2
- IF (I > NUP2) exit
- s_awqnc(k+1)= s_awqnc(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w
- s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w
- s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w
- s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w
- s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w
- ENDDO
- ENDDO
- ENDIF
+ ENDDO
+ !momentum
+ if (momentum_opt > 0) then
+ do i=1,nup
+ do k=kts,kte-1
+ s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w
+ s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w
+ enddo
+ enddo
+ endif
+ !tke
+ if (tke_opt > 0) then
+ do i=1,nup
+ do k=kts,kte-1
+ s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w
+ enddo
+ enddo
+ endif
+ !chem
+ if ( mix_chem ) then
+ do k=kts,kte
+ do i=1,nup
+ do ic = 1,nchem
+ s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w
+ enddo
+ enddo
+ enddo
+ endif
+
+ if (scalar_opt > 0) then
+ do k=kts,kte
+ do I=1,nup
+ s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w
+ s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w
+ s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w
+ s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w
+ s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w
+ enddo
+ enddo
+ endif
- !Flux limiter: Check ratio of heat flux at top of first model layer
- !and at the surface. Make sure estimated flux out of the top of the
- !layer is < fluxportion*surface_heat_flux
- IF (s_aw(kts+1) /= 0.) THEN
+ !Flux limiter: Check ratio of heat flux at top of first model layer
+ !and at the surface. Make sure estimated flux out of the top of the
+ !layer is < fluxportion*surface_heat_flux
+ IF (s_aw(kts+1) /= 0.) THEN
dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface
flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5)
- ELSE
+ ELSE
flx1 = 0.0
!print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,&
! " superadiabatic=",superadiabatic," KTOP=",KTOP
- ENDIF
- adjustment=1.0
- !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1
- !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1)
- IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN
+ ENDIF
+ adjustment=1.0
+ !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1
+ !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1)
+ IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN
adjustment= fluxportion*flt/dz(kts)/flx1
- s_aw = s_aw*adjustment
- s_awthl= s_awthl*adjustment
- s_awqt = s_awqt*adjustment
- s_awqc = s_awqc*adjustment
- s_awqv = s_awqv*adjustment
- s_awqnc= s_awqnc*adjustment
- s_awqni= s_awqni*adjustment
- s_awqnwfa= s_awqnwfa*adjustment
- s_awqnifa= s_awqnifa*adjustment
- s_awqnbca= s_awqnbca*adjustment
+ s_aw = s_aw*adjustment
+ s_awthl = s_awthl*adjustment
+ s_awqt = s_awqt*adjustment
+ s_awqc = s_awqc*adjustment
+ s_awqv = s_awqv*adjustment
+ s_awqnc = s_awqnc*adjustment
+ s_awqni = s_awqni*adjustment
+ s_awqnwfa = s_awqnwfa*adjustment
+ s_awqnifa = s_awqnifa*adjustment
+ s_awqnbca = s_awqnbca*adjustment
IF (momentum_opt > 0) THEN
s_awu = s_awu*adjustment
s_awv = s_awv*adjustment
@@ -6467,62 +6510,57 @@ SUBROUTINE DMP_mf( &
s_awchem = s_awchem*adjustment
ENDIF
UPA = UPA*adjustment
- ENDIF
- !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt
-
- !Calculate mean updraft properties for output:
- !all edmf_* variables at k=1 correspond to the interface at top of first model layer
- DO k=KTS,KTE-1
- IF(k > KTOP) exit
- rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
- DO I=1,NUP !NUP2
- IF(I > NUP2) exit
- edmf_a(K) =edmf_a(K) +UPA(K,i)
- edmf_w(K) =edmf_w(K) +rho_int*UPA(K,i)*UPW(K,i)
- edmf_qt(K) =edmf_qt(K) +rho_int*UPA(K,i)*UPQT(K,i)
- edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i)
- edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i)
- edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i)
- ENDDO
-
+ ENDIF
+ !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt
+
+ !Calculate mean updraft properties for output:
+ !all edmf_* variables at k=1 correspond to the interface at top of first model layer
+ do k=kts,kte-1
+ do I=1,nup
+ edmf_a(K) =edmf_a(K) +UPA(K,i)
+ edmf_w(K) =edmf_w(K) +rhoz(k)*UPA(K,i)*UPW(K,i)
+ edmf_qt(K) =edmf_qt(K) +rhoz(k)*UPA(K,i)*UPQT(K,i)
+ edmf_thl(K)=edmf_thl(K)+rhoz(k)*UPA(K,i)*UPTHL(K,i)
+ edmf_ent(K)=edmf_ent(K)+rhoz(k)*UPA(K,i)*ENT(K,i)
+ edmf_qc(K) =edmf_qc(K) +rhoz(k)*UPA(K,i)*UPQC(K,i)
+ enddo
+ enddo
+ do k=kts,kte-1
!Note that only edmf_a is multiplied by Psig_w. This takes care of the
!scale-awareness of the subsidence below:
- IF (edmf_a(k)>0.) THEN
- edmf_w(k)=edmf_w(k)/edmf_a(k)
- edmf_qt(k)=edmf_qt(k)/edmf_a(k)
- edmf_thl(k)=edmf_thl(k)/edmf_a(k)
- edmf_ent(k)=edmf_ent(k)/edmf_a(k)
- edmf_qc(k)=edmf_qc(k)/edmf_a(k)
- edmf_a(k)=edmf_a(k)*Psig_w
-
- !FIND MAXIMUM MASS-FLUX IN THE COLUMN:
- IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k)
- ENDIF
- ENDDO ! end k
-
- !smoke/chem
- IF ( mix_chem ) THEN
- DO k=kts,kte-1
- IF(k > KTOP) exit
- rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
- DO I=1,NUP !NUP2
- IF(I > NUP2) exit
+ if (edmf_a(k)>0.) then
+ edmf_w(k)=edmf_w(k)/edmf_a(k)
+ edmf_qt(k)=edmf_qt(k)/edmf_a(k)
+ edmf_thl(k)=edmf_thl(k)/edmf_a(k)
+ edmf_ent(k)=edmf_ent(k)/edmf_a(k)
+ edmf_qc(k)=edmf_qc(k)/edmf_a(k)
+ edmf_a(k)=edmf_a(k)*Psig_w
+ !FIND MAXIMUM MASS-FLUX IN THE COLUMN:
+ if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k)
+ endif
+ enddo ! end k
+
+ !smoke/chem
+ if ( mix_chem ) then
+ do k=kts,kte-1
+ do I=1,nup
do ic = 1,nchem
- edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic)
+ edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic)
enddo
- ENDDO
-
- IF (edmf_a(k)>0.) THEN
+ enddo
+ enddo
+ do k=kts,kte-1
+ if (edmf_a(k)>0.) then
do ic = 1,nchem
edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k)
enddo
- ENDIF
- ENDDO ! end k
- ENDIF
+ endif
+ enddo ! end k
+ endif
- !Calculate the effects environmental subsidence.
- !All envi_*variables are valid at the interfaces, like the edmf_* variables
- IF (env_subs) THEN
+ !Calculate the effects environmental subsidence.
+ !All envi_*variables are valid at the interfaces, like the edmf_* variables
+ IF (env_subs) THEN
DO k=kts+1,kte-1
!First, smooth the profiles of w & a, since sharp vertical gradients
!in plume variables are not likely extended to env variables
@@ -6557,18 +6595,16 @@ SUBROUTINE DMP_mf( &
!calculate tendencies from subsidence and detrainment valid at the middle of
!each model layer. The lowest model layer uses an assumes w=0 at the surface.
dzi(kts) = 0.5*(dz(kts)+dz(kts+1))
- rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* &
- (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int
+ (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k)
sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* &
- (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int
+ (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k)
DO k=kts+1,kte-1
dzi(k) = 0.5*(dz(k)+dz(k+1))
- rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
- (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int
+ (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k)
sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
- (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int
+ (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k)
ENDDO
DO k=KTS,KTE-1
@@ -6578,17 +6614,15 @@ SUBROUTINE DMP_mf( &
ENDDO
IF (momentum_opt > 0) THEN
- rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* &
- (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int
+ (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k)
sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* &
- (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int
+ (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k)
DO k=kts+1,kte-1
- rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
- (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int
+ (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k)
sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
- (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int
+ (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k)
ENDDO
DO k=KTS,KTE-1
@@ -6596,23 +6630,23 @@ SUBROUTINE DMP_mf( &
det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w
ENDDO
ENDIF
- ENDIF !end subsidence/env detranment
+ ENDIF !end subsidence/env detranment
- !First, compute exner, plume theta, and dz centered at interface
- !Here, k=1 is the top of the first model layer. These values do not
- !need to be defined at k=kte (unused level).
- DO K=KTS,KTE-1
- exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
+ !First, compute exner, plume theta, and dz centered at interface
+ !Here, k=1 is the top of the first model layer. These values do not
+ !need to be defined at k=kte (unused level).
+ DO K=KTS,KTE-1
+ exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k))
edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K)
- dzi(k) = 0.5*(DZ(k)+DZ(k+1))
- ENDDO
+ dzi(k) = 0.5*(dz(k)+dz(k+1))
+ ENDDO
!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in
! mym_condensation. Here, a shallow-cu component is added, but no cumulus
! clouds can be added at k=1 (start loop at k=2).
- do k=kts+1,kte-2
- IF(k > KTOP) exit
- IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN
+ do k=kts+1,kte-2
+ if (k > KTOP) exit
+ if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN
!interpolate plume quantities to mass levels
Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
@@ -6686,8 +6720,8 @@ SUBROUTINE DMP_mf( &
!mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6)
!Original CB
mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6)
- mf_cf = max(mf_cf, 1.75 * Aup)
- mf_cf = min(mf_cf, 5.0 * Aup)
+ mf_cf = max(mf_cf, 1.8 * Aup)
+ mf_cf = min(mf_cf, 5.0 * Aup)
endif
!IF ( debug_code ) THEN
@@ -6705,10 +6739,7 @@ SUBROUTINE DMP_mf( &
if (QCp * Aup > 5e-5) then
qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5
else
- qc_bl1d(k) = 1.18 * (QCp * Aup)
- endif
- if (mf_cf .ge. Aup) then
- qc_bl1d(k) = qc_bl1d(k) / mf_cf
+ qc_bl1d(k) = 1.18 * (QCp * Aup)
endif
cldfra_bl1d(k) = mf_cf
Ac_mf = mf_cf
@@ -6718,9 +6749,6 @@ SUBROUTINE DMP_mf( &
else
qc_bl1d(k) = 1.18 * (QCp * Aup)
endif
- if (mf_cf .ge. Aup) then
- qc_bl1d(k) = qc_bl1d(k) / mf_cf
- endif
cldfra_bl1d(k) = mf_cf
Ac_mf = mf_cf
endif
@@ -6752,13 +6780,13 @@ SUBROUTINE DMP_mf( &
endif !check for (qc in plume) .and. (cldfra_bl < threshold)
enddo !k-loop
- ENDIF !end nup2 > 0
+ENDIF !end nup2 > 0
- !modify output (negative: dry plume, positive: moist plume)
- if (ktop > 0) then
- maxqc = maxval(edmf_qc(1:ktop))
- if ( maxqc < 1.E-8) maxmf = -1.0*maxmf
- endif
+!modify output (negative: dry plume, positive: moist plume)
+if (ktop > 0) then
+ maxqc = maxval(edmf_qc(1:ktop))
+ if ( maxqc < 1.E-8) maxmf = -1.0*maxmf
+endif
!
! debugging
@@ -6927,62 +6955,68 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
&qc_bl1d,cldfra_bl1d, &
&rthraten )
- INTEGER, INTENT(IN) :: KTS,KTE,KPBL
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,&
- THV,P,rho,exner,dz
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten
+ integer, intent(in) :: KTS,KTE,KPBL
+ real(kind_phys), dimension(kts:kte), intent(in) :: &
+ U,V,TH,THL,TK,QT,QV,QC,THV,P,rho,exner,dz
+ real(kind_phys), dimension(kts:kte), intent(in) :: rthraten
! zw .. heights of the downdraft levels (edges of boxes)
- real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW
- real(kind_phys), INTENT(IN) :: WTHL,WQT
- real(kind_phys), INTENT(IN) :: dt,ust,pblh
+ real(kind_phys), dimension(kts:kte+1), intent(in) :: ZW
+ real(kind_phys), intent(in) :: WTHL,WQT
+ real(kind_phys), intent(in) :: dt,ust,pblh
! outputs - downdraft properties
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, &
- & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd
+ real(kind_phys), dimension(kts:kte), intent(out) :: &
+ edmf_a_dd,edmf_w_dd, &
+ edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd
! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii)
- real(kind_phys),DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, &
- sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2
+ real(kind_phys), dimension(kts:kte+1) :: &
+ sd_aw, sd_awthl, sd_awqt, sd_awu, &
+ sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2
- real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d
+ real(kind_phys), dimension(kts:kte), intent(in) :: &
+ qc_bl1d, cldfra_bl1d
- INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5
+ integer, parameter:: ndown = 5
! draw downdraft starting height randomly between cloud base and cloud top
- INTEGER, DIMENSION(1:NDOWN) :: DD_initK
- real(kind_phys) , DIMENSION(1:NDOWN) :: randNum
+ integer, dimension(1:NDOWN) :: DD_initK
+ real(kind_phys), dimension(1:NDOWN) :: randNum
! downdraft properties
- real(kind_phys),DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,&
- DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV
+ real(kind_phys), dimension(kts:kte+1,1:NDOWN) :: &
+ DOWNW,DOWNTHL,DOWNQT,DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV
! entrainment variables
- Real(Kind_phys),DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf
- INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi
+ real(kind_phys), dimension(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf
+ integer, dimension(KTS+1:KTE+1,1:NDOWN) :: ENTi
! internal variables
- INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase
- real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, &
- pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw
- real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, &
- EntEXP,EntW, Beta_dm, EntExp_M, rho_int
- real(kind_phys):: jump_thetav, jump_qt, jump_thetal, &
+ integer :: K,I,ki, kminrad, qlTop, p700_ind, qlBase
+ real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT, &
+ sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw
+ real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn, &
+ THVk,Pk,EntEXP,EntW,beta_dm,EntExp_M,rho_int
+ real(kind_phys):: jump_thetav, jump_qt, jump_thetal, &
refTHL, refTHV, refQT
! DD specific internal variables
real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd
logical :: cloudflg
-
- real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt,&
+ real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt, &
Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid
! w parameters
- real(kind_phys),PARAMETER :: &
- &Wa=1., &
- &Wb=1.5,&
- &Z00=100.,&
- &BCOEFF=0.2
+ real(kind_phys),parameter :: &
+ &Wa=1., Wb=1.5, Z00=100., BCOEFF=0.2
! entrainment parameters
- real(kind_phys),PARAMETER :: &
- & L0=80,&
- & ENT0=0.2
-
+ real(kind_phys),parameter :: &
+ &L0=80, ENT0=0.2
+ !downdraft properties
+ real(kind_phys):: &
+ & dp, & !diameter of plume
+ & dl, & !diameter increment
+ & Adn !total area of downdrafts
+ !additional printouts for debugging
+ integer, parameter :: debug_mf=0
+
+ dl = (1000.-500.)/real(ndown)
pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma
pwmax=-1.
@@ -7052,6 +7086,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
if ( radflux < 0.0 ) F0 = abs(radflux) + F0
enddo
F0 = max(F0, 1.0)
+
+ !Allow the total fractional area of the downdrafts to be proportional
+ !to the radiative forcing:
+ !for 50 W/m2, Adn = 0.10
+ !for 100 W/m2, Adn = 0.15
+ !for 150 W/m2, Adn = 0.20
+ Adn = min( 0.05 + F0*0.001, 0.3)
+
!found Sc cloud and cloud not at surface, trigger downdraft
if (cloudflg) then
@@ -7066,14 +7108,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi)
- ! entrainent: Ent=Ent0/dz*P(dz/L0)
- do i=1,NDOWN
- do k=kts+1,kte
-! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k))
- ENT(k,i) = 0.002
- ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))
- enddo
- enddo
+! ! entrainent: Ent=Ent0/dz*P(dz/L0)
+! do i=1,NDOWN
+! do k=kts+1,kte
+!! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k))
+! ENT(k,i) = 0.002
+! ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))
+! enddo
+! enddo
!!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!!
p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000
@@ -7116,8 +7158,10 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
!DOWNW(ki,I)=0.5*(wlv+wtv)
DOWNW(ki,I)=wlv
+ !multiply downa by cloud fraction, so it's impact will diminish if
+ !clouds are mixed away over the course of the longer radiation time step
!DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))
- DOWNA(ki,I)=.1/real(NDOWN)
+ DOWNA(ki,I)=Adn/real(NDOWN)
DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
@@ -7144,16 +7188,21 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
enddo
-
!print*, " Begin integration of downdrafts:"
DO I=1,NDOWN
+ dp = 500. + dl*real(I) ! diameter of plume (meters)
!print *, "Plume # =", I,"======================="
DO k=DD_initK(I)-1,KTS+1,-1
+
+ !Entrainment from Tian and Kuang (2016), with constraints
+ wmin = 0.3 + dp*0.0005
+ ENT(k,i) = 0.33/(MIN(MAX(-1.0*DOWNW(k+1,I),wmin),0.9)*dp)
+
!starting at the first interface level below cloud top
!EntExp=exp(-ENT(K,I)*dz(k))
!EntExp_M=exp(-ENT(K,I)/3.*dz(k))
- EntExp =ENT(K,I)*dz(k)
- EntExp_M=ENT(K,I)*0.333*dz(k)
+ EntExp =ENT(K,I)*dz(k) !for all scalars
+ EntExp_M=ENT(K,I)*0.333*dz(k) !test for momentum
QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp
THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp
@@ -7187,11 +7236,11 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
BCOEFF*B/mindownw)*MIN(dz(k), 250.)
!Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.
- !Add max increase of 2.0 m/s for coarse vertical resolution.
- IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0))THEN
- Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0)
+ !Add max acceleration of -2.0 m/s for coarse vertical resolution.
+ IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN
+ Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0)
ENDIF
- !Add symmetrical max decrease in w
+ !Add symmetrical max decrease in velocity (less negative)
IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN
Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0)
ENDIF
@@ -7237,7 +7286,6 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
! Even though downdraft starts at different height, average all up to qlTop
DO k=qlTop,KTS,-1
DO I=1,NDOWN
- IF (I > NDOWN) exit
edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I)
edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I)
edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I)
@@ -7287,8 +7335,8 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu)
! Psig_bl tapers local mixing
! Psig_shcu tapers nonlocal mixing
- real(kind_phys), INTENT(IN) :: dx,pbl1
- real(kind_phys), INTENT(OUT) :: Psig_bl,Psig_shcu
+ real(kind_phys), intent(in) :: dx,pbl1
+ real(kind_phys), intent(out) :: Psig_bl,Psig_shcu
real(kind_phys) :: dxdh
Psig_bl=1.0
@@ -7361,28 +7409,28 @@ FUNCTION esat_blend(t)
IMPLICIT NONE
- real(kind_phys), INTENT(IN):: t
+ real(kind_phys), intent(in):: t
real(kind_phys):: esat_blend,XC,ESL,ESI,chi
!liquid
- real(kind_phys), PARAMETER:: J0= .611583699E03
- real(kind_phys), PARAMETER:: J1= .444606896E02
- real(kind_phys), PARAMETER:: J2= .143177157E01
- real(kind_phys), PARAMETER:: J3= .264224321E-1
- real(kind_phys), PARAMETER:: J4= .299291081E-3
- real(kind_phys), PARAMETER:: J5= .203154182E-5
- real(kind_phys), PARAMETER:: J6= .702620698E-8
- real(kind_phys), PARAMETER:: J7= .379534310E-11
- real(kind_phys), PARAMETER:: J8=-.321582393E-13
+ real(kind_phys), parameter:: J0= .611583699E03
+ real(kind_phys), parameter:: J1= .444606896E02
+ real(kind_phys), parameter:: J2= .143177157E01
+ real(kind_phys), parameter:: J3= .264224321E-1
+ real(kind_phys), parameter:: J4= .299291081E-3
+ real(kind_phys), parameter:: J5= .203154182E-5
+ real(kind_phys), parameter:: J6= .702620698E-8
+ real(kind_phys), parameter:: J7= .379534310E-11
+ real(kind_phys), parameter:: J8=-.321582393E-13
!ice
- real(kind_phys), PARAMETER:: K0= .609868993E03
- real(kind_phys), PARAMETER:: K1= .499320233E02
- real(kind_phys), PARAMETER:: K2= .184672631E01
- real(kind_phys), PARAMETER:: K3= .402737184E-1
- real(kind_phys), PARAMETER:: K4= .565392987E-3
- real(kind_phys), PARAMETER:: K5= .521693933E-5
- real(kind_phys), PARAMETER:: K6= .307839583E-7
- real(kind_phys), PARAMETER:: K7= .105785160E-9
- real(kind_phys), PARAMETER:: K8= .161444444E-12
+ real(kind_phys), parameter:: K0= .609868993E03
+ real(kind_phys), parameter:: K1= .499320233E02
+ real(kind_phys), parameter:: K2= .184672631E01
+ real(kind_phys), parameter:: K3= .402737184E-1
+ real(kind_phys), parameter:: K4= .565392987E-3
+ real(kind_phys), parameter:: K5= .521693933E-5
+ real(kind_phys), parameter:: K6= .307839583E-7
+ real(kind_phys), parameter:: K7= .105785160E-9
+ real(kind_phys), parameter:: K8= .161444444E-12
XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240
@@ -7412,28 +7460,28 @@ FUNCTION qsat_blend(t, P)
IMPLICIT NONE
- real(kind_phys), INTENT(IN):: t, P
+ real(kind_phys), intent(in):: t, P
real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi
!liquid
- real(kind_phys), PARAMETER:: J0= .611583699E03
- real(kind_phys), PARAMETER:: J1= .444606896E02
- real(kind_phys), PARAMETER:: J2= .143177157E01
- real(kind_phys), PARAMETER:: J3= .264224321E-1
- real(kind_phys), PARAMETER:: J4= .299291081E-3
- real(kind_phys), PARAMETER:: J5= .203154182E-5
- real(kind_phys), PARAMETER:: J6= .702620698E-8
- real(kind_phys), PARAMETER:: J7= .379534310E-11
- real(kind_phys), PARAMETER:: J8=-.321582393E-13
+ real(kind_phys), parameter:: J0= .611583699E03
+ real(kind_phys), parameter:: J1= .444606896E02
+ real(kind_phys), parameter:: J2= .143177157E01
+ real(kind_phys), parameter:: J3= .264224321E-1
+ real(kind_phys), parameter:: J4= .299291081E-3
+ real(kind_phys), parameter:: J5= .203154182E-5
+ real(kind_phys), parameter:: J6= .702620698E-8
+ real(kind_phys), parameter:: J7= .379534310E-11
+ real(kind_phys), parameter:: J8=-.321582393E-13
!ice
- real(kind_phys), PARAMETER:: K0= .609868993E03
- real(kind_phys), PARAMETER:: K1= .499320233E02
- real(kind_phys), PARAMETER:: K2= .184672631E01
- real(kind_phys), PARAMETER:: K3= .402737184E-1
- real(kind_phys), PARAMETER:: K4= .565392987E-3
- real(kind_phys), PARAMETER:: K5= .521693933E-5
- real(kind_phys), PARAMETER:: K6= .307839583E-7
- real(kind_phys), PARAMETER:: K7= .105785160E-9
- real(kind_phys), PARAMETER:: K8= .161444444E-12
+ real(kind_phys), parameter:: K0= .609868993E03
+ real(kind_phys), parameter:: K1= .499320233E02
+ real(kind_phys), parameter:: K2= .184672631E01
+ real(kind_phys), parameter:: K3= .402737184E-1
+ real(kind_phys), parameter:: K4= .565392987E-3
+ real(kind_phys), parameter:: K5= .521693933E-5
+ real(kind_phys), parameter:: K6= .307839583E-7
+ real(kind_phys), parameter:: K7= .105785160E-9
+ real(kind_phys), parameter:: K8= .161444444E-12
XC=MAX(-80.,t - t0c)
@@ -7470,7 +7518,7 @@ FUNCTION xl_blend(t)
IMPLICIT NONE
- real(kind_phys), INTENT(IN):: t
+ real(kind_phys), intent(in):: t
real(kind_phys):: xl_blend,xlvt,xlst,chi
!note: t0c = 273.15, tice is set in mynn_common
@@ -7499,11 +7547,11 @@ FUNCTION phim(zet)
! stable conditions [z/L ~ O(10)].
IMPLICIT NONE
- real(kind_phys), INTENT(IN):: zet
+ real(kind_phys), intent(in):: zet
real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi
- real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
- real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
- real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34.
+ real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
+ real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
+ real(kind_phys), parameter :: am_unst=10., ah_unst=34.
real(kind_phys):: phi_m,phim
if ( zet >= 0.0 ) then
@@ -7551,11 +7599,11 @@ FUNCTION phih(zet)
! stable conditions [z/L ~ O(10)].
IMPLICIT NONE
- real(kind_phys), INTENT(IN):: zet
+ real(kind_phys), intent(in):: zet
real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi
- real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
- real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
- real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34.
+ real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
+ real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
+ real(kind_phys), parameter :: am_unst=10., ah_unst=34.
real(kind_phys):: phh,phih
if ( zet >= 0.0 ) then
diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90
index 409bf4019..ad90ec81f 100644
--- a/physics/module_mp_nssl_2mom.F90
+++ b/physics/module_mp_nssl_2mom.F90
@@ -1,7 +1,14 @@
!> \file module_mp_nssl_2mom.F90
+
+
+
+
+
+
+
!---------------------------------------------------------------------
-! code snapshot: "Feb 24 2022" at "14:27:57"
+! code snapshot: "Sep 22 2023" at "22:01:53"
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars:
@@ -19,37 +26,32 @@
! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
!
!>\ingroup mod_mp_nssl2m
-!! This module provides a 2-moment bulk microphysics scheme described by
-!! Mansell, Zeigler, and Bruning (2010, JAS)
-!!
-!! This module provides a 2-moment bulk microphysics scheme based on a combination of
-!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in
-!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation
+!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of
+!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in
+!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation
!! follows Mansell (2010, JAS), using parameter infall = 4.
!!
!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS)
!!
-!! Average graupel particle density is predicted, which affects fall speed as well.
-!! Hail density prediction is by default disabled in this version, but may be enabled
-!! at some point if there is interest.
+!! Average graupel and hail particle densities are predicted, which affects fall speed as well.
!!
!! Maintainer: Ted Mansell, National Severe Storms Laboratory <ted.mansell@noaa.gov>
!!
!! Microphysics References:
!!
-!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small
+!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small
!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1.
!!
-!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and
-!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050,
+!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and
+!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050,
!! doi:10.1175/JAS-D-12-0264.1.
!!
-!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms.
+!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms.
!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509.
!!
!! Sedimentation reference:
!!
-!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics.
+!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics.
!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1.
!
! Possible parameters to adjust:
@@ -63,18 +65,25 @@
! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The
! implementation of an explicit charging and discharge lightning scheme
! within the WRF-ARW model: Benchmark simulations of a continental squall line, a
-! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415
+! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415
!
-! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated
+! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated
! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287
!
! Note: Some parameters below apply to unreleased features.
!
!
!---------------------------------------------------------------------
+! Apr. 2023
+! - Update to 3-moment for rain, graupel, and hail
+! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013)
+! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds.
+! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom,
+! using wet growth diameter to convert large graupel
+!---------------------------------------------------------------------
! Sept. 2021:
! Fixes:
-! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed
+! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed
! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics)
! Other:
! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect)
@@ -221,7 +230,7 @@ MODULE module_mp_nssl_2mom
real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params
real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params
real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params
- real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params
+ real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params
real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel)
real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail)
@@ -234,8 +243,9 @@ MODULE module_mp_nssl_2mom
real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5)
real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion)
real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime)
- real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value
- real , public :: qccn ! ccn "mixing ratio"
+ real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value
+ real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value
+ real , public :: qccn, qccnuf ! ccn "mixing ratio"
real , private :: old_qccn = -1.0
integer, private :: iauttim = 1 ! 10-ice rain delay flag
real , private :: auttim = 300. ! 10-ice rain delay time
@@ -245,12 +255,17 @@ MODULE module_mp_nssl_2mom
! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true
logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#else
- logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
+ logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#endif
logical :: switchccn = .false.
real :: old_cccn = -1.0
logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted)
real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true)
+ real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN
+ real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018)
+ real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.)
+ logical :: decayufccn = .false.
+ integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn)
! sedimentation flags
! itfall -> 0 = 1st order fallout (other options removed)
@@ -259,6 +274,7 @@ MODULE module_mp_nssl_2mom
integer, private :: itfall = 0
integer, private :: iscfall = 1
integer, private :: irfall = -1
+ integer, private :: isfall = 2 ! default limit with method II (more restrictive)
logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive)
! if false, reuse fall speeds on multiple steps (can have a noticeable speedup)
! Mainly is an issue for small dz near the surface.
@@ -269,14 +285,20 @@ MODULE module_mp_nssl_2mom
! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS)
! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS)
! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max.
+ integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates)
real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only)
real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed
real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed
real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed
real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed
integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt)
- integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
- integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ ! 6= Milbrandt and Morrison (2013) density-based fall speed
+ integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ ! 6= Milbrandt and Morrison (2013) density-based fall speed
+ real :: axh = 75.7149, bxh = 0.5
+ real :: axf = 75.7149, bxf = 0.5
+ real :: axhl = 206.984, bxhl = 0.6384
real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4)
real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4)
real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4)
@@ -310,7 +332,7 @@ MODULE module_mp_nssl_2mom
integer, private :: irimtim = 0 ! future use
! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds
- integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993)
+ integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin
real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985)
real , private :: rimc3 = 170.0 ! minimum rime density
real :: rimc4 = 900.0 ! maximum rime density
@@ -325,7 +347,7 @@ MODULE module_mp_nssl_2mom
! (first nucleation is done with a KW sat. adj. step)
integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field
integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016)
- integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud
+ integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete)
! =2 renucleation following Twomey/Cohard&Pinty
! =7 New renucleation that requires prediction of the number of activated nuclei
! i.e., not only at cloud base
@@ -347,6 +369,7 @@ MODULE module_mp_nssl_2mom
! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr
integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process
+ integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets)
integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010)
real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott
integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version
@@ -357,7 +380,9 @@ MODULE module_mp_nssl_2mom
integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation
integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals
! (0=off; 1=drops > 500micron diameter; 2 = > 300micron)
+ integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero
integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off)
+ integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm
integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel
! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation)
integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however)
@@ -413,11 +438,15 @@ MODULE module_mp_nssl_2mom
! set eii1 = 0 to get a constant value of eii0
real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
! set eii1hl = 0 to get a constant value of eii0hl
+ real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi
+ real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi
real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals
real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain
real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency
real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0))
! set ehs1 = 0 to get a constant value of ehs0
+ integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI
+ ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI
real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0))
! set ess1 = 0 to get a constant value of ess0
real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on
@@ -452,11 +481,13 @@ MODULE module_mp_nssl_2mom
! 0 = no condensation on rain; 1 = bulk condensation on rain
integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation
! icond = 2 does not work (intended to calc. dep in loop with droplet cond.)
+ integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C
real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1
! and for ciacrf for iacr=4
real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail
real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail
+ integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam
integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets
integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail
@@ -480,6 +511,7 @@ MODULE module_mp_nssl_2mom
real, private :: qhdpvdn = -1.
real, private :: qhacidn = -1.
+ integer, private :: iraintypes = 0
logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel
integer, private :: imixedphase = 0
logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density
@@ -511,17 +543,23 @@ MODULE module_mp_nssl_2mom
real, parameter :: alpharmax = 8. ! limited for rwvent calculation
- integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use
+ integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use
! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter
! 2 = Straka and Mansell (2005) conversion using size threshold
+ ! 3 = Conversion using wet growth diameter
real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option.
real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1)
- real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
+ real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
+ integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet
integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on)
- real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth
real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail
real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller)
real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother
+ integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL
+ real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel
integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed
integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain.
@@ -538,6 +576,8 @@ MODULE module_mp_nssl_2mom
! = 1 use mean diameter for breakup
! = 2 use maximum mass diameter for breakup
! = 3 use mass-weighted diameter for breakup
+ integer :: iraintailbreak = 0 ! 1 = on
+ real :: draintail = 8.e-3 ! starting size for rain breakup
integer, private :: dmrauto = 0
! = -1 no limiter on crcnw
! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002)
@@ -545,7 +585,7 @@ MODULE module_mp_nssl_2mom
! = 2 DTD mass-weighted version based on MY code
! = 3 Milbrandt version (from Cohard and Pinty code
integer :: dmropt = 0 ! extra option for crcnw
- integer :: dmhlopt = 1 ! options for graupel -> conversion
+ integer :: dmhlopt = 0 ! options for graupel -> hail conversion
integer :: irescalerainopt = 3 ! 0 = default option
! 1 = qx(mgs,lc) > qxmin(lc)
! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0
@@ -562,7 +602,7 @@ MODULE module_mp_nssl_2mom
integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting
! when liquid fraction is not predicted
- logical :: iwetsoak = .true. ! soak and freeze during wet growth or not
+ logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not
integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories
integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters
! 1 = original Zrnic et al. (Mansell et al. 2010)
@@ -595,9 +635,12 @@ MODULE module_mp_nssl_2mom
integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1)
integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr
integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr
+ integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0
+ integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0
real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr
real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting
real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow.
+ real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow
real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter
integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau)
@@ -739,6 +782,7 @@ MODULE module_mp_nssl_2mom
real da1 (lc:lqmx) ! collection coefficients from Seifert 2005
real bb (lc:lqmx)
+
! put ipelec here for now....
integer :: ipelec = 0
integer :: isaund = 0
@@ -764,8 +808,8 @@ MODULE module_mp_nssl_2mom
double precision, parameter :: dgam = 0.01, dgami = 100.
double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2)
- integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15
- integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25
+ integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15
+ integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25
! real, parameter :: maxratiolu = 25.
real, parameter :: maxratiolu = 100. ! 25.
real, parameter :: maxalphalu = 15.
@@ -782,6 +826,10 @@ MODULE module_mp_nssl_2mom
! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha)
! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)
+! for 3-moment collection coefficients
+ real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
+ real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
+
integer, parameter :: ngdnmm = 9
real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail
@@ -860,7 +908,7 @@ MODULE module_mp_nssl_2mom
! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius
real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius
- real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius
+ real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius
real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6
real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6
real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13
@@ -903,18 +951,20 @@ MODULE module_mp_nssl_2mom
real, parameter :: cawbolton = 17.67
real, parameter :: tfrh = 233.15
+! --------------------------
+ ! For CCPP, the following variables should be set by the host model, but initial values are set just in case
real :: tfr = 273.15
-
real :: cp = 1004.0, rd = 287.04
real :: rw = 461.5 ! gas const. for water vapor
- REAL, PRIVATE :: cpl = 4190.0
- REAL, PRIVATE :: cpigb = 2106.0
- real :: cpi
- real :: cap
- real :: tfrcbw
- real :: tfrcbi
- real :: rovcp
-
+ real :: cpl = 4190.0
+ real :: cpigb = 2106.0
+ real :: cpi = 1.0/1004.0
+ real :: cap = 287.04/1004.0
+ real :: tfrcbw = 273.15 - cbw
+ real :: tfrcbi = 273.15 - cbi
+ real :: rovcp = 287.04/1004.0
+ real :: rdorv = 0.622
+! --------------------------
real, parameter :: poo = 1.0e+05
real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71)
real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc
@@ -922,8 +972,8 @@ MODULE module_mp_nssl_2mom
! GHB: Needed for eqtset=2 in cm1
! REAL, PRIVATE :: cv = cp - rd
- real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air
- REAL, PRIVATE, parameter :: cvv = 1408.5
+ real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air
+ REAL, PRIVATE, parameter :: cvv = 1408.5
! GHB
real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0)
@@ -952,10 +1002,12 @@ MODULE module_mp_nssl_2mom
logical, parameter :: do_satadj_for_wrfchem = .true.
+ integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only)
+ logical, private :: nuaccoinp = .false.
! Note to users: Many of these options are for development and not guaranteed to perform well.
! Some may not be functional depending on the version of the code.
-! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions
+! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions
! in that regard.
NAMELIST /nssl_mp_params/ &
ndebug, ncdebug,&
@@ -965,7 +1017,7 @@ MODULE module_mp_nssl_2mom
idbzci, &
vtmaxsed, &
itfall,iscfall, &
- infall, &
+ infall,irfall,isfall, &
rssflg, &
sssflg, &
hssflg, &
@@ -976,13 +1028,15 @@ MODULE module_mp_nssl_2mom
icnuclimit, &
irenuc, &
restoreccn, ccntimeconst, cck, &
+ decayufccn, ufccntimeconst, &
switchccn, old_cccn, &
ciintmx, &
itype1, itype2, &
- icenucopt, &
+ icenucopt, in_freeze_rain_first, &
naer, &
icfn, &
ibfc, iacr, icracr, &
+ icracrthresh, &
cwfrz2snowfrac, cwfrz2snowratio, &
ibfr, &
ibiggopt, &
@@ -998,7 +1052,7 @@ MODULE module_mp_nssl_2mom
eri_cimin, &
eii0hl, eii1hl, &
ehs0, ehs1, &
- ess0, ess1, &
+ ess0, ess1, iessopt, &
esstem1,esstem2, &
ircnw, qminrncw,& ! single-moment only
iglcnvi, &
@@ -1024,6 +1078,7 @@ MODULE module_mp_nssl_2mom
hailfallfac, &
icefallopt, &
icdx,icdxhl, &
+ axh,bxh,axf,bxf,axhl,bxhl, &
cdhmin, cdhmax, &
cdhdnmin, cdhdnmax, &
cdhlmin, cdhlmax, &
@@ -1058,7 +1113,7 @@ MODULE module_mp_nssl_2mom
rescale_low_alphah, &
rescale_low_alphahl, &
rescale_high_alpha, &
- ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, &
+ ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, &
icvhl2h, hldnmn,hdnmn, &
hlcnhdia, hlcnhqmin, &
isedonly, &
@@ -1133,12 +1188,12 @@ SUBROUTINE nssl_2mom_init_const( &
real, intent(in) :: con_g, con_rd, con_cp, con_rv, &
con_t0c, con_cliq, con_csol, con_eps
- cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv
gr = con_g
tfr = con_t0c
cp = con_cp
rd = con_rd
rw = con_rv
+ rdorv = con_eps
cpl = con_cliq ! 4190.0
cpigb = con_csol ! 2106.0
cpi = 1./cp
@@ -1151,6 +1206,8 @@ SUBROUTINE nssl_2mom_init_const( &
RETURN
END SUBROUTINE nssl_2mom_init_const
+
+
! #####################################################################
! #####################################################################
!>\ingroup mod_nsslmp
@@ -1165,7 +1222,14 @@ SUBROUTINE nssl_2mom_init( &
& nssl_icdxhl, &
& nssl_icefallfac, &
& nssl_snowfallfac, &
+ & nssl_cccn, &
+ & nssl_ufccn, &
+ & nssl_alphah, &
+ & nssl_alphahl, &
+ & nssl_alphar, &
+ & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, &
& errmsg, errflg, &
+ & infileunit, &
& myrank, mpiroot &
)
@@ -1177,24 +1241,38 @@ SUBROUTINE nssl_2mom_init( &
& nssl_ehw0, &
& nssl_ehlw0, &
& nssl_icefallfac, &
- & nssl_snowfallfac
+ & nssl_snowfallfac, &
+ & nssl_cccn, &
+ & nssl_alphah, &
+ & nssl_alphahl, &
+ & nssl_alphar
integer, intent(in), optional :: &
& nssl_icdx, &
- & nssl_icdxhl, myrank, mpiroot
+ & nssl_icdxhl, myrank, mpiroot, &
+ & nssl_ufccn
+ logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on
+ integer, intent(inout), optional :: ccn_is_ccna
+
+ integer, intent(in),optional :: infileunit
! CCPP error handling
character(len=*), intent( out) :: errmsg
integer, intent( out) :: errflg
- integer, intent(in) :: ims,ime, jms,jme, kms,kme
- real, intent(in), dimension(20) :: nssl_params
+ integer, intent(in), optional :: ims,ime, jms,jme, kms,kme
+
+ real, intent(in), dimension(20), optional :: nssl_params
- integer, intent(in) :: ipctmp,mixphase,ihvol
+ integer, intent(in) :: ipctmp,mixphase
+ integer, optional, intent(in) :: ihvol
logical, optional, intent(in) :: idoniconlytmp
+ integer :: igvol_local = 1
logical :: wrote_namelist = .false.
logical :: wrf_dm_on_monitor
+ integer :: hail_on = -1, density_on = -1, icecrystals_on = 1
+ integer :: ccn_on = -1
double precision :: arg
real :: temq
@@ -1202,22 +1280,59 @@ SUBROUTINE nssl_2mom_init( &
integer :: i,il,j,l
integer :: ltmp
integer :: isub
- real :: bxh,bxhl
+ real :: bxh1,bxhl1
real :: alp,ratio
double precision :: x,y,y2,y7
logical :: turn_on_ccna, turn_on_cina
+ integer :: iufccn = 0
integer :: istat
+
+ real :: alpjj, alpii, xnuii, xnujj
+ integer :: ii, jj
errmsg = ''
errflg = 0
turn_on_ccna = .false.
turn_on_cina = .false.
+
+! IF ( present( igvol ) ) THEN
+! igvol_local = igvol
+! ENDIF
+
+ IF ( present( nssl_hail_on ) ) THEN
+ IF ( nssl_hail_on ) THEN
+ hail_on = 1
+ ELSE
+ hail_on = 0
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_density_on ) ) THEN
+ IF ( nssl_density_on ) THEN
+ density_on = 1
+ ELSE
+ density_on = 0
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_icecrystals_on ) ) THEN
+ IF ( nssl_icecrystals_on ) THEN
+ icecrystals_on = 1
+ ELSE
+ icecrystals_on = 0
+ ! renucfrac = 1.0 ! why was this set to 1?
+ ffrzs = 1.0
+ ENDIF
+ ENDIF
+
+
!
! set some global values from namelist input
!
+ IF ( present( nssl_params ) ) THEN
ccn = Abs( nssl_params(1) )
alphah = nssl_params(2)
alphahl = nssl_params(3)
@@ -1228,26 +1343,60 @@ SUBROUTINE nssl_2mom_init( &
rho_qh = nssl_params(8)
rho_qhl = nssl_params(9)
rho_qs = nssl_params(10)
- alphar = nssl_params(15)
-
+ IF ( Nint(nssl_params(13)) == 1 ) THEN
+ ! hack to switch CCN field to CCNA (activated ccn)
+! invertccn = .true.
+ turn_on_ccna = .true.
+ irenuc = 7
+ ENDIF
+ ccnuf = Abs( nssl_params(14) )
+ IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn
+
+ ENDIF
+ alphar = nssl_params(15)
! ipelec = Nint(nssl_params(11))
! isaund = Nint(nssl_params(12))
+
+
IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac
IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac
- IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0
- IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0
+ IF ( present(nssl_ehw0) ) THEN
+ IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0
+ ENDIF
+ IF ( present(nssl_ehlw0) ) THEN
+ IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0
+ ENDIF
IF ( present(nssl_icdx) ) icdx = nssl_icdx
IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl
IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac
IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac
+ IF ( present(nssl_cccn) ) THEN
+ IF (nssl_cccn > 1 ) ccn = nssl_cccn
+ ENDIF
+ IF ( present(nssl_alphah) ) THEN
+ IF ( nssl_alphah > -1. ) alphah = nssl_alphah
+ ENDIF
+ IF ( present(nssl_alphahl) ) THEN
+ IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl
+ ENDIF
+ IF ( present(nssl_alphar) ) THEN
+ IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar
+ ENDIF
- IF ( Nint(nssl_params(13)) == 1 ) THEN
- ! hack to switch CCN field to CCNA (activated ccn)
-! invertccn = .true.
- turn_on_ccna = .true.
- irenuc = 7
+ ipconc = ipctmp
+
+ IF ( ipconc < 5 ) THEN
+ ihlcnh = 0
+ ENDIF
+
+ IF ( ihlcnh <= 0 ) THEN
+ IF ( ipconc == 5 ) THEN
+ ihlcnh = 3
+ ELSEIF ( ipconc >= 6 ) THEN
+ ihlcnh = 3
ENDIF
+ ENDIF
@@ -1275,8 +1424,43 @@ SUBROUTINE nssl_2mom_init( &
+ IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn
+ irenuc = 7
+ IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay
+ IF ( i_uf_or_ccn > 0 ) THEN
+ ufbackground = 0.0
+ ccntimeconst = ufccntimeconst
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_ccn_on ) ) THEN
+ IF ( nssl_ccn_on ) THEN
+ ccn_on = 1
+ ELSE
+ ccn_on = 0
+ irenuc = 2
+ ENDIF
+ ENDIF
+
IF ( irenuc >= 5 ) THEN
turn_on_ccna = .true.
+ IF ( present( nssl_ccn_on ) ) THEN
+ IF ( .not. nssl_ccn_on ) THEN
+ errmsg = 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!'
+ errflg = 1
+ return
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN
+ IF ( ccn_is_ccna > 0 ) THEN
+ turn_on_ccna = .true.
+ ELSE
+ IF ( irenuc >= 5 ) THEN
+ ccn_is_ccna = 1
+ ENDIF
+ ENDIF
ENDIF
cwccn = ccn
@@ -1290,25 +1474,42 @@ SUBROUTINE nssl_2mom_init( &
lh = lh + 1
lhl = lhl + 1
ENDIF
- IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
- IF ( ihvol == -1 .or. ihvol == -2 ) THEN
- lhab = lhab - 1 ! turns off hail
- lhl = 0
- ! past me thought it would be a good idea to change graupel factors when hail is off....
- ! ehw0 = 0.75
- ! iehw = 2
- ! dfrz = Max( dfrz, 0.5e-3 )
- ENDIF
- IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off
- ! a value of -3 means to turn off ice crystals but turn on hail
- renucfrac = 1.0
- ffrzs = 1.0
- ! idoci = 0 ! try this later
+ IF ( hail_on == -1 ) THEN ! hail_on is not set
+ hail_on = 1
+ IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
+ IF ( ihvol == -1 .or. ihvol == -2 ) THEN
+ lhab = lhab - 1 ! turns off hail
+ lhl = 0
+ hail_on = 0
+ ! past me thought it would be a good idea to change graupel factors when hail is off....
+ ! ehw0 = 0.75
+ ! iehw = 2
+ ! dfrz = Max( dfrz, 0.5e-3 )
+ ENDIF
+ IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off
+ ! a value of 2? means to turn off ice crystals but turn on hail
+ ! renucfrac = 1.0 ! why?
+ ffrzs = 1.0
+ ! idoci = 0 ! try this later
+ ENDIF
+ ENDIF
+
+ ELSE ! hail_on is set
+ IF ( hail_on == 0 ) THEN
+ lhab = lhab - 1 ! turns off hail
+ lhl = 0
+ ELSE
+ ! assume default that hail is on
ENDIF
ENDIF
+
+ IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it
+ density_on = 1
+ ENDIF
+
IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl
-! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl
+! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on
! IF ( ipelec > 0 ) idonic = .true.
@@ -1335,29 +1536,42 @@ SUBROUTINE nssl_2mom_init( &
bx(lr) = 0.85
ax(lr) = 1647.81
fx(lr) = 135.477
+
IF ( icdx == 6 ) THEN
bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550.
ax(lh) = 157.71
- ELSEIF ( icdx > 0 ) THEN
+! ELSEIF ( icdx == 1 ) THEN
+! bx(lh) = bxh
+! ax(lh) = axh
+ ELSEIF ( icdx > 1 ) THEN
bx(lh) = 0.5
ax(lh) = 75.7149
- ELSE
- bx(lh) = 0.37 ! 0.6 ! Ferrier 1994
+ ELSEIF ( icdx == 0 ) THEN
+ bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel
ax(lh) = 19.3
+ ELSE ! icdx < 0
+! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops
+! bx(lh) = 0.6384
+ bx(lh) = bxh
+ ax(lh) = axh
ENDIF
+
! bx(lh) = 0.6
IF ( lhl .gt. 1 ) THEN
IF ( icdxhl == 6 ) THEN
bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750.
ax(lhl) = 179.36
+ ELSEIF (icdxhl == 0 ) THEN
+ ax(lhl) = 206.984 ! Ferrier 1994
+ bx(lhl) = 0.6384
ELSEIF (icdxhl > 0 ) THEN
- bx(lhl) = 0.5
- ax(lhl) = 75.7149
+ bx(lhl) = 0.5
+ ax(lhl) = 75.7149
ELSE
- ax(lhl) = 206.984 ! Ferrier 1994
- bx(lhl) = 0.6384
+ bx(lhl) = bxhl
+ ax(lhl) = axhl
ENDIF
ENDIF
@@ -1373,8 +1587,8 @@ SUBROUTINE nssl_2mom_init( &
! Uses incomplete gamma functions
! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option)
- bxh = bx(lh)
- bxhl = bx(Max(lh,lhl))
+ bxh1 = bx(lh)
+ bxhl1 = bx(Max(lh,lhl))
! DO j = 0,nqiacralpha
DO j = ialpstart,nqiacralpha
@@ -1390,9 +1604,9 @@ SUBROUTINE nssl_2mom_init( &
! graupel (.,.,.,1)
gamxinflu(i,j,1,1) = x/y
gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y
- gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y
+ gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y
gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y
- gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y
+ gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y
gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y
gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y
@@ -1401,9 +1615,9 @@ SUBROUTINE nssl_2mom_init( &
! hail (.,.,.,2)
gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1)
gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1)
- gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y
+ gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y
gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1)
- gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y
+ gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y
gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1)
gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1)
@@ -1411,16 +1625,16 @@ SUBROUTINE nssl_2mom_init( &
! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y
gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y
! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y
- gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y
-! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y
- gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y
+ gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y
+! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y
+ gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y
ELSE
! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y
gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y
-! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y
-! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y
- gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y
- gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y
+! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y
+! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y
+ gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y
+ gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y
ENDIF
gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1)
@@ -1454,9 +1668,8 @@ SUBROUTINE nssl_2mom_init( &
qiacrratio(0,:) = 1.0
- isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0
-
lccn = 0
+ lccnuf = 0
lccna = 0
lnc = 0
lnr = 0
@@ -1478,34 +1691,41 @@ SUBROUTINE nssl_2mom_init( &
! lccn = 9
- ipconc = ipctmp
IF ( ipconc == 0 ) THEN
- IF ( ihvol >= 0 ) THEN
+ IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme
lvh = 9
ltmp = 9
denscale(lvh) = 1
- ELSE ! no hail
+ ELSE ! no hail, 'LFO' scheme
ltmp = lhab
lhl = 0
ENDIF
ELSEIF ( ipconc == 5 ) THEN
- lccn = lhab+1 ! 9
- lnc = lhab+2 ! 10
- lnr = lhab+3 ! 11
- lni = lhab+4 !12
- lns = lhab+5 !13
- lnh = lhab+6 !14
+ ltmp = lhab
+ IF ( iufccn > 0 ) THEN
+ ltmp = ltmp+1
+ lccnuf = ltmp
+ denscale(lccnuf) = 1
+ ENDIF
+ lccn= ltmp+1 ! 9
+ lnc = ltmp+2 ! 10
+ lnr = ltmp+3 ! 11
+ lni = ltmp+4 !12
+ lns = ltmp+5 !13
+ lnh = ltmp+6 !14
ltmp = lnh
- IF ( ihvol >= 0 ) THEN
+ IF ( hail_on == 1 ) THEN
ltmp = ltmp + 1
lnhl = ltmp ! lhab+7 ! 15
ENDIF
+ IF ( density_on >= 1 ) THEN
ltmp = ltmp + 1
lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
! ltmp = lvh
- denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
+ ENDIF
+ denscale(lccn:ltmp) = 1
+ IF ( density_on == 1 .and. hail_on == 1 ) THEN
ltmp = ltmp + 1
lvhl = ltmp
! ltmp = lvhl
@@ -1523,25 +1743,31 @@ SUBROUTINE nssl_2mom_init( &
! ltmp = lhlw
ENDIF
ELSEIF ( ipconc >= 6 ) THEN
- errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.'
- errflg = 1
- return
- lccn = lhab+1 ! 9
- lnc = lhab+2 ! 10
- lnr = lhab+3 ! 11
- lni = lhab+4 !12
- lns = lhab+5 !13
- lnh = lhab+6 !14
+ ltmp = lhab
+ IF ( iufccn > 0 ) THEN
+ ltmp = ltmp+1
+ lccnuf = ltmp
+ denscale(lccnuf) = 1
+ ENDIF
+
+ lccn= ltmp+1 ! 9
+ lnc = ltmp+2 ! 10
+ lnr = ltmp+3 ! 11
+ lni = ltmp+4 !12
+ lns = ltmp+5 !13
+ lnh = ltmp+6 !14
ltmp = lnh
IF ( lhl > 0 ) THEN
ltmp = ltmp + 1
lnhl = ltmp ! lhab+7 ! 15
ENDIF
+ IF ( density_on == 1 ) THEN
ltmp = ltmp + 1
lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
+ ENDIF
! ltmp = lvh
- denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
+ denscale(lccn:ltmp) = 1
+ IF ( density_on == 1 .and. hail_on == 1 ) THEN
ltmp = ltmp + 1
lvhl = ltmp
! ltmp = lvhl
@@ -1561,19 +1787,14 @@ SUBROUTINE nssl_2mom_init( &
lzh = ltmp
ltmp = ltmp + 1
lzr = ltmp
- ltmp = ltmp + 1
IF ( lhl > 1 ) THEN
ltmp = ltmp + 1
lzhl = ltmp
ENDIF
+ ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl
ENDIF
! ltmp = lvh
! denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
- lvhl = ltmp+1
- ltmp = lvhl
- denscale(lvhl) = 1
- ENDIF
IF ( mixedphase ) THEN
ltmp = ltmp + 1
lsw = ltmp
@@ -1593,7 +1814,8 @@ SUBROUTINE nssl_2mom_init( &
-
+ ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl
+ ! write(0,*) 'wrf_init: ipconc = ',ipconc
! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna
IF ( turn_on_ccna ) THEN
ltmp = ltmp + 1
@@ -1825,9 +2047,11 @@ SUBROUTINE nssl_2mom_init( &
IF ( lhl .gt. 1 ) ido(lhl) = idohl
IF ( irfall .lt. 0 ) irfall = infall
+ IF ( isfall .lt. 0 ) isfall = infall
IF ( lzr > 0 ) irfall = 0
qccn = ccn/rho00
+ qccnuf = ccnuf/rho00
IF ( old_cccn > 0.0 ) THEN
old_qccn = old_cccn/rho00
ELSE
@@ -1981,6 +2205,33 @@ SUBROUTINE nssl_2mom_init( &
ENDDO
ENDDO
+ dab0lu(:,:,:,:) = 0.0
+ dab1lu(:,:,:,:) = 0.0
+
+ IF ( ipconc >= 6 ) THEN
+ DO il = lc,lhab ! collector
+ DO j = lc,lhab ! collected
+ IF ( il .ne. j ) THEN
+
+ DO jj = ialpstart,nqiacralpha
+ alpjj = float(jj)*dqiacralpha
+ xnujj = (alpjj - 2.)/3.
+ DO ii = ialpstart,nqiacralpha
+ alpii = float(ii)*dqiacralpha
+ xnuii = (alpii - 2.)/3.
+
+ dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0)
+ dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1)
+
+ ENDDO
+ ENDDO
+! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
gf4br = gamma_sp(4.0+br)
gf4ds = gamma_sp(4.0+ds)
gf4p5 = gamma_sp(4.0+0.5)
@@ -2029,18 +2280,25 @@ END SUBROUTINE nssl_2mom_init
!>\ingroup mod_nsslmp
!! Driver subroutine that copies state data to local 2D arrays for microphysics calls
SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, &
- cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, &
- zrw, zhw, zhl, &
+ cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, &
+ f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, &
+ cnuf, f_cnuf, &
+ zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, &
qsw, qhw, qhlw, &
tt, th, pii, p, w, dn, dz, dtp, itimestep, &
+ is_theta_or_temp, &
+ ntmul, ntcnt, lastloop, &
RAINNC,RAINNCV, &
dx, dy, &
axtra, &
SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, &
SR,HAILNC, HAILNCV, &
+ hail_maxk1, hail_max2d, nwp_diagnostics, &
tkediss, &
re_cloud, re_ice, re_snow, re_rain, &
+ re_graup, re_hail, &
has_reqc, has_reqi, has_reqs, has_reqr, &
+ has_reqg, has_reqh, &
rainncw2, rainnci2, &
dbz, vzf,compdbz, &
rscghis_2d,rscghis_2dp,rscghis_2dn, &
@@ -2074,6 +2332,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
+
+
implicit none
@@ -2091,7 +2351,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
zrw, zhw, zhl, &
qsw, qhw, qhlw, &
qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni
+ integer, optional, intent(in) :: is_theta_or_temp
+ logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet
+ real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf
real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz
real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate
rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only)
@@ -2102,8 +2364,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge
real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel)
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez
- real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion
+ real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez
+ real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion
real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn
real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii
@@ -2124,22 +2386,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra
! WRF variables
- real, dimension(ims:ime, jms:jme), intent(inout):: &
+ real, dimension(ims:ime, jms:jme) :: &
RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV)
real, dimension(ims:ime, jms:jme), optional, intent(inout):: &
SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV)
real, dimension(ims:ime, jms:jme), optional, intent(inout):: &
HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV)
+ real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d
+ integer, optional, intent(in) :: nwp_diagnostics
+! for cm1, set nproctot=44 (or as needed) to get domain total rates
integer, parameter :: nproc = 1
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain
+ double precision :: proctot(nproc),proctotmpi(nproc)
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, &
+ re_rain, re_graup, re_hail
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss
- INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr
+ INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh
real, dimension(ims:ime, jms:jme), intent(out), optional :: &
rainncw2, rainnci2 ! liquid rain, ice, accumulation rates
real, optional, intent(in) :: dx,dy
real, intent(in):: dtp
integer, intent(in):: itimestep !, ccntype
- logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina
+ integer, intent(in), optional :: ntmul, ntcnt
+ logical, optional, intent(in) :: lastloop
+ logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf
+ logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl
integer, optional, intent(in) :: ipelectmp, ke_diag
! CCPP error handling
@@ -2151,7 +2421,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop
LOGICAL :: flag_qndrop ! wrf-chem
LOGICAL :: flag_qnifa , flag_qnwfa
+ logical :: flag_cnuf = .false.
+ logical :: flag_ccn = .false.
+ logical :: flag_qi = .true.
+ logical :: has_reqg_local = .false., has_reqh_local = .false.
logical :: flag
+ logical :: nwp_diagflag = .false.
real :: cinchange, t7max,testmax,wmax
! 20130903 acd_ck_washout start
@@ -2176,12 +2451,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d
real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten
real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d
+ real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d
real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9
real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d
real, dimension(its:ite, 1, na) :: xfall
+ real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1
real, dimension(kts:kte, nproc) :: thproclocal
integer, parameter :: nor = 0, ng = 0
- integer :: nx,ny,nz
+ integer :: nx,ny,nz,ngs
integer ix,jy,kz,i,j,k,il,n
integer :: infdo
real :: ssival, ssifac, t8s, t9s, qvapor
@@ -2223,15 +2500,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real :: fach(kts:kte)
logical, parameter :: debugdriver = .false.
-
-#ifdef MPI
-
-#if defined(MPI)
- integer, parameter :: ntot = 50
- double precision mpitotindp(ntot), mpitotoutdp(ntot)
- INTEGER :: mpi_error_code = 1
-#endif
-#endif
+
+ integer :: loopcnt, loopmax, outerloopcnt
+ logical :: lastlooptmp
! -------------------------------------------------------------------
@@ -2246,13 +2517,52 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
flag_qndrop = .false.
flag_qnifa = .false.
flag_qnwfa = .false.
+ flag_cnuf = .false.
+ flag_ccn = .false.
+ nwp_diagflag = .false.
IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn
+ IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf
+ IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 )
+ IF ( present ( f_cn ) .and. present( cn ) ) THEN
+ flag_ccn = f_cn
+ ELSEIF ( present( cn ) ) THEN
+ flag_ccn = .true.
+ ENDIF
+
+ IF ( present( f_qi ) ) THEN
+ flag_qi = f_qi
+ ELSE
+ IF ( ffrzs < 1.0 ) THEN
+ flag_qi = .true.
+ ELSE
+ flag_qi = .false.
+ ENDIF
+ ENDIF
+ IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0
+
+ IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0
+ IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0
- ! ---
+ loopmax = 1
+ outerloopcnt = 1
+ lastlooptmp = .true.
+ IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN
+ loopmax = ntmul
+ outerloopcnt = ntcnt
+ lastlooptmp = lastloop
+ ENDIF
+
+
+ has_wetscav = .false.
+ IF ( wrfchem_flag > 0 ) THEN
+ IF ( PRESENT( wetscav_on ) ) THEN
+ has_wetscav = wetscav_on
+ ENDIF
+ ENDIF
IF ( present( f_cna ) ) THEN
f_cnatmp = f_cna
@@ -2303,8 +2613,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
nx = ite-its+1
ny = 1 ! set up as 2D slabs
nz = kte-kts+1
+ ngs = 64
- IF ( .not. present( cn ) ) THEN
+ IF ( .not. flag_ccn ) THEN
renucfrac = 1.0
ENDIF
@@ -2365,32 +2676,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ancuten(its:ite,1,kts:kte,:) = 0.0
thproclocal(:,:) = 0.0
+
DO jy = jts,jye
- xfall(:,:,:) = 0.0
-
! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn
IF ( present( pcc2 ) .and. makediag ) THEN
axtra2d(its:ite,1,kts:kte,:) = 0.0
ENDIF
+ IF ( nwp_diagflag ) THEN
+ alpha2d(its:ite,1,kts:kte,1) = alphar
+ alpha2d(its:ite,1,kts:kte,2) = alphah
+ alpha2d(its:ite,1,kts:kte,3) = alphahl
+ ENDIF
+
+
! copy from 3D array to 2D slab
DO kz = kts,kte
DO ix = its,ite
-
IF ( present( tt ) ) THEN
an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy)
ELSE
an(ix,1,kz,lt) = th(ix,kz,jy)
ENDIF
-
-
an(ix,1,kz,lv) = qv(ix,kz,jy)
an(ix,1,kz,lc) = qc(ix,kz,jy)
an(ix,1,kz,lr) = qr(ix,kz,jy)
- IF ( present( qi ) ) THEN
+ IF ( flag_qi ) THEN
an(ix,1,kz,li) = qi(ix,kz,jy)
ELSE
an(ix,1,kz,li) = 0.0
@@ -2401,13 +2715,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lccn > 1 ) THEN
IF ( is_aerosol_aware .and. flag_qnwfa ) THEN
!
- ELSEIF ( present( cn ) ) THEN
+ ELSEIF ( flag_ccn ) THEN
IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
an(ix,1,kz,lccna) = cn(ix,kz,jy)
an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy)
ELSE
an(ix,1,kz,lccn) = cn(ix,kz,jy)
ENDIF
+ IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn
+ an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy)
+ ENDIF
ELSE
IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN
an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy)
@@ -2418,6 +2735,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDIF
+ IF ( lccnuf > 0 .and. flag_cnuf ) THEN
+ IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF
+ an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) )
+ ELSE ! UF were added to lccn
+ an(ix,1,kz,lccnuf) = 0.0
+ ENDIF
+ ENDIF
+
IF ( lccna > 1 ) THEN
IF ( present( cna ) .and. f_cnatmp ) THEN
an(ix,1,kz,lccna) = cna(ix,kz,jy)
@@ -2448,9 +2773,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy)
IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy)
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale
+ IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale
+ IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale
+ ENDIF
+ ENDDO
+ ENDDO
+
+ DO kz = kts,kte
+ DO ix = its,ite
IF ( present( tt ) ) THEN
@@ -2458,6 +2793,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ELSE
t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin)
ENDIF
+ t00(ix,1,kz) = 380.0/p(ix,kz,jy)
+ t77(ix,1,kz) = pii(ix,kz,jy)
+ dbz2d(ix,1,kz) = 0.0
+ vzf2d(ix,1,kz) = 0.0
+ ENDDO
+ ENDDO
+
+ DO ix = its,ite
+ RAINNCV(ix,jy) = 0.0
+ IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0
+ IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0
+ IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0
+ ENDDO
+
+ DO loopcnt = 1,loopmax
+
+ DO kz = kts,kte
+ DO ix = its,ite
+
+
t1(ix,1,kz) = 0.0
t2(ix,1,kz) = 0.0
t3(ix,1,kz) = 0.0
@@ -2467,14 +2822,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
t7(ix,1,kz) = 0.0
t8(ix,1,kz) = 0.0
t9(ix,1,kz) = 0.0
- t00(ix,1,kz) = 380.0/p(ix,kz,jy)
- t77(ix,1,kz) = pii(ix,kz,jy)
- dbz2d(ix,1,kz) = 0.0
- vzf2d(ix,1,kz) = 0.0
- dn1(ix,1,kz) = dn(ix,kz,jy)
pn(ix,1,kz) = p(ix,kz,jy)
wn(ix,1,kz) = w(ix,kz,jy)
+! calculate dn1 in case we are substepping: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
! wmax = Max(wmax,wn(ix,1,kz))
dz2d(ix,1,kz) = dz(ix,kz,jy)
dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy)
@@ -2492,6 +2844,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
!
ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi
+
if ( ssival .gt. 1.0 ) then
!
IF ( icenucopt == 1 ) THEN
@@ -2544,19 +2897,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010
- IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN !
+ IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN !
! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033,
! nint = a*(-Tc)**b * naer**(c*(-Tc) + d)
! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00
! naer needs units of cm**-3, so mult by 1.e-6
- ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033)
- dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033)
- t7(ix,jy,kz) = Min(dp1, 1.0d30)
+ ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033)
+ tmp = 1.e-6*naer
+ dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033)
+ t7(ix,1,kz) = Min(dp1, 1.0d30)
ELSE
- t7(ix,jy,kz) = 0.0
+ ! t7(ix,1,kz) = 0.0
ENDIF
ENDIF ! icenucopt
@@ -2569,39 +2923,39 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO ! ix
ENDDO ! kz
- has_wetscav = .false.
- IF ( wrfchem_flag > 0 ) THEN
- IF ( PRESENT( wetscav_on ) ) THEN
- has_wetscav = wetscav_on
- IF ( has_wetscav ) THEN
- IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
- IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
- ENDIF
- ENDIF
- ENDIF
+ IF ( wrfchem_flag > 0 ) THEN
+ IF ( has_wetscav ) THEN
+ IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
+ IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
+ ENDIF
+ ENDIF
! transform from number mixing ratios to number conc.
+ IF ( loopcnt == 1 ) THEN
DO il = lnb,na
IF ( denscale(il) == 1 ) THEN
DO kz = kts,kte
DO ix = its,ite
- an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy)
+ an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy)
ENDDO
ENDDO
ENDIF
ENDDO ! il
+ ENDIF
+
! sedimentation
xfall(:,:,:) = 0.0
- IF ( .true. ) THEN
+
+! IF ( .true. ) THEN
! #ifndef CM1
! for real cases when hydrometeor mixing ratios have been initialized without concentrations
- IF ( itimestep == 1 .and. ipconc > 0 ) THEN
+ IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN
call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
ENDIF
! IF ( itimestep == 3 .and. ipconc > 0 ) THEN
@@ -2611,9 +2965,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( present(cu_used) .and. &
( present( qrcuten ) .or. present( qscuten ) .or. &
- present( qicuten ) .or. present( qccuten ) ) ) THEN
+ present( qicuten ) .or. present( qccuten ) ) ) THEN !{
- IF ( cu_used == 1 ) THEN
+ IF ( cu_used == 1 ) THEN !{
DO kz = kts,kte
DO ix = its,ite
@@ -2627,10 +2981,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1)
+ DO kz = kts,kte
+ DO ix = its,ite
+
+
+ IF ( ipconc >= 6 ) THEN
+! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr)
+ ENDIF
+
+ ENDDO
+ ENDDO
- ENDIF
+ ENDIF !}
- ENDIF
+ ENDIF !}
+
+
call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
@@ -2644,10 +3010,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
DO ix = its,ite
IF ( lhl > 1 ) THEN
- RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
+ RAINNCV(ix,jy) = RAINNCV(ix,jy) + &
+ dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
& xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) )
ELSE
- RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
+ RAINNCV(ix,jy) = RAINNCV(ix,jy) + &
+ dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
& xfall(ix,1,lh)*1000./xdn0(lr) )
ENDIF
IF ( present ( rainncw2 ) ) THEN ! rain only
@@ -2662,17 +3030,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
& xfall(ix,1,lh)*1000./xdn0(lr) )
ENDIF
ENDIF
- IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
+ IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
IF ( present( GRPLNCV ) ) THEN
IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel
- GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
+ GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
ELSE
- GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
+ GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
ENDIF
ENDIF
- RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy)
+ IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy)
- IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
+ IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN
+ SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
+ ENDIF
IF ( lhl > 1 ) THEN
!#ifdef CM1
! IF ( .true. ) THEN
@@ -2680,13 +3050,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( present( HAILNC ) ) THEN
!#endif
HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
- HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy)
+ IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy)
! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel
! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
ENDIF
ENDIF
- IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy)
- IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN
+ IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN
+ GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy)
+ ENDIF
+ IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN
IF ( present( HAILNC ) ) THEN
SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12)
ELSE
@@ -2695,7 +3067,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDDO
- ENDIF ! .false.
+! ENDIF ! .false.
IF ( isedonly /= 1 ) THEN
! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics
@@ -2717,15 +3089,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! & ln,ipc,lvol,lz,lliq, &
& cdx, &
& xdn0,dbz2d,tke2d, &
- & thproclocal,nproc,dx1,dy1, &
+ & thproclocal,nproc,dx1,dy1,ngs, &
& timevtcalc,axtra2d, makediag &
- & ,has_wetscav, rainprod2d, evapprod2d &
+ & ,has_wetscav, rainprod2d, evapprod2d, alpha2d &
& ,errmsg,errflg &
& ,elec2,its,ids,ide,jds,jde &
& )
+! recalculate dn1 after temperature changes: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
+ DO kz = kts,kte
+ DO ix = its,ite
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
+ ENDDO
+ ENDDO
+
ENDIF ! isedonly /= 1
@@ -2737,29 +3116,38 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
& ,dz2d &
& ,t0,t9 &
& ,an,dn1,t77 &
- & ,pn,wn &
+ & ,pn,wn &
+ & ,ngs &
& ,axtra2d, makediag &
& ,ssat,t00,t77,flag_qndrop)
+! recalculate dn1 after temperature changes
+ DO kz = kts,kte
+ DO ix = its,ite
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
+ ENDDO
+ ENDDO
+
ENDIF
+
+ ENDDO ! loopcnt=1,loopmax
IF ( present( pcc2 ) .and. makediag ) THEN
DO kz = kts,kte
DO ix = its,ite
! example of using the 'axtra2d' array to get rates out of the microphysics routine for output.
! Search for 'axtra' to find example code below
! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1)
-
ENDDO
ENDDO
ENDIF
! compute diagnostic S-band reflectivity if needed
- IF ( present( dbz ) .and. makediag ) THEN
+ IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN
! calc dbz
IF ( .true. ) THEN
@@ -2797,7 +3185,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F
IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. &
- present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN
+ present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. &
+ lastlooptmp) THEN
IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN
DO kz = kts,kte
DO ix = its,ite
@@ -2815,16 +3204,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
call calc_eff_radius &
& (nx,ny,nz,na,jy &
& ,nor,nor &
- & ,t1=t1,t2=t2,t3=t3,t4=t4 &
+ & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,f_t5=has_reqg_local, f_t6=has_reqh_local &
& ,an=an,dn=dn1 )
DO kz = kts,kte
DO ix = its,ite
re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6))
- re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6))
+ re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6))
re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6))
! check for case where snow needs to be treated as cloud ice (for rrtmg radiation)
- IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6))
+ IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6))
ENDDO
ENDDO
@@ -2837,19 +3226,53 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO
ENDIF
ENDIF
+
+ IF ( present(has_reqg) .and. present( re_graup ) ) THEN
+ IF ( has_reqg /= 0 ) THEN
+ DO kz = kts,kte
+ DO ix = its,ite
+ re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF ( present(has_reqh) .and. present( re_hail ) ) THEN
+ IF ( has_reqh /= 0 ) THEN
+ DO kz = kts,kte
+ DO ix = its,ite
+ re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
ENDIF
ENDIF
+ IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN
+ DO ix = its,ite
+ hailmax1d(ix,1) = hail_max2d(ix,jy)
+ hailmaxk1(ix,1) = hail_maxk1(ix,jy)
+ ENDDO
+
+ call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, &
+ hailmax1d,hailmaxk1,1 )
+ DO ix = its,ite
+ hail_max2d(ix,jy) = hailmax1d(ix,1)
+ hail_maxk1(ix,jy) = hailmaxk1(ix,1)
+ ENDDO
+! ENDIF
+ ENDIF
! transform concentrations back to mixing ratios
DO il = lnb,na
IF ( denscale(il) == 1 ) THEN
DO kz = kts,kte
DO ix = its,ite
- an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy)
+ an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy)
ENDDO
ENDDO
ENDIF
@@ -2870,14 +3293,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
qv(ix,kz,jy) = an(ix,1,kz,lv)
qc(ix,kz,jy) = an(ix,1,kz,lc)
qr(ix,kz,jy) = an(ix,1,kz,lr)
- IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li)
+ IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li)
qs(ix,kz,jy) = an(ix,1,kz,ls)
qh(ix,kz,jy) = an(ix,1,kz,lh)
IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl)
IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN
! not used here
- ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN
+ ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN
IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) )
ELSE
@@ -2896,6 +3319,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDIF
+ IF ( lccnuf > 0 .and. flag_cnuf ) THEN
+ IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay
+ an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) )
+ ENDIF
+ IF ( decayufccn ) THEN
+ IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN
+ an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - &
+ ufbackground)*(1.0 - exp(-dtp/ufccntimeconst))
+ ENDIF
+ ENDIF
+ cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf)
+ ENDIF
+
+
+
IF ( ipconc >= 5 ) THEN
ccw(ix,kz,jy) = an(ix,1,kz,lnc)
@@ -2906,6 +3344,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl)
ENDIF
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv
+ IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv
+ IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv
+ ENDIF
@@ -2914,6 +3357,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
#if ( WRF_CHEM == 1 )
IF ( has_wetscav ) THEN
+ IF ( loopmax > 1 ) THEN
+ ! wrferror not supported
+ ENDIF
IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz)
IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz)
ENDIF
@@ -2921,8 +3367,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO
ENDDO
-
+
+
ENDDO ! jy
+
+
@@ -3217,7 +3666,7 @@ END FUNCTION GAML02
! **********************************************************
!>\ingroup mod_nsslmp
!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 )
- real FUNCTION GAML02d300(x)
+ real FUNCTION GAML02d300(x)
implicit none
integer ig, i, ii, n, np
real x
@@ -3558,11 +4007,245 @@ Function delabk(ba,bb,nua,nub,mua,mub,k)
RETURN
END Function delabk
-
+
+
+! #######################################################################
+! HAILMAXD - calculated maximum expected hail size
+! #######################################################################
!>\ingroup mod_nsslmp
-!! Sedimentation driver subroutine. Calls fallout column by column
- subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
+!! Hail max size subroutine.
+ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, &
+ & hailmax1d,hailmaxk1,jslab )
+!
+! Calculate maximum hail size from the tail of of the distribution. The value
+! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf).
+! This uses the lookup tables for incomplete gamma functions and simply search for
+! the expected value (and linearly interpolate) on D.
+!
+! Written by ERM 7/2023
+!
+!
+!
+ implicit none
+
+ integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
+ integer id ! =1 use density, =0 no density
+! integer :: its,ite ! x-range to calculate
+
+ integer ng1
+ parameter(ng1 = 1)
+
+ real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
+ real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+
+! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
+ real dtp
+ real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters
+ real :: hailmax1d(nx,ny),hailmaxk1(nx,ny)
+ integer infdo
+ integer jslab ! which line of xfall to use
+
+ integer ix,jy,kz,ndfall,n,k,il,in
+ double precision :: tmp, ratio, del, g1palp
+ real, parameter :: dz = 200.
+
+ real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+
+ real :: rhovtzx(nz,nx)
+
+ real :: alp, diam, diam1, hwdn
+
+! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp)
+ DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter
+ real :: cwchtmp,cwchltmp, maxdia
+
+!-----------------------------------------------------------------------------
+
+ integer :: ixb, jyb, kzb
+ integer :: ixe, jye, kze
+ integer :: plo, phi
+ integer :: ialp, i, j
+
+ logical :: debug_mpi = .TRUE.
+
+! ###################################################################
+
+
+ IF ( lh > 1 ) THEN
+ cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
+ ENDIF
+ IF ( lhl > 1 ) THEN
+ cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
+ ENDIF
+
+
+ kzb = 1
+ kze = nz
+
+ ixb = 1 ! aliased its
+ ixe = nx ! aliased ite
+
+
+ jy = jslab
+ jgs = jy
+
+
+! hailmax1d(:,jy) = 0.0
+! hailmaxk1(:,jy) = 0.0
+
+ if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'
+
+
+! first graupel, even if hail is also predicted, since graupel can sometime be large on its own
+ IF ( lh > 1 .and. lnh > 1 ) THEN
+ DO kz = kzb,kze
+ DO ix = ixb,ixe
+ IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN
+ IF ( lvh .gt. 1 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
+ ELSE
+ hwdn = rho_qh
+ ENDIF
+
+ tmp = 1. + alpha2d(ix,1,kz,2)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh))
+ diam = (6.0*tmp/pi)**(1./3.)
+ IF ( lzh > 1 ) THEN ! 3moment
+ cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.)
+ ENDIF
+ diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda
+ ! want cxd1 = thresh_conc
+ ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
+ ! tmp = thresh_conc*g1palp/cx
+ !
+ tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh)
+ alp = alpha2d(ix,1,kz,2)
+ ! gamxinflu(i,j,luindex,ilh)
+ j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
+ ratio = 0.0
+ maxdia = 0.0
+ ! eventually could replace with bisection search, but final value of i is usually small
+ ! compared to nqiacrratio
+ DO i = 0,nqiacrratio-1
+ IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
+ ! interpolate here for FWIW
+ ratio = i*dqiacrratio
+ del = tmp - gamxinflu(i,j,1,1)
+ ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
+ exit
+ ENDIF
+ ENDDO
+
+ IF ( ratio > 0.0 ) THEN
+ maxdia = ratio*diam1 ! units of m
+ ENDIF
+
+ IF ( kz == kzb ) THEN
+ hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) )
+! IF ( maxdia > 0.1 ) THEN
+! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN
+! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
+! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
+! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
+! gamxinflu(4,j,1,1)
+! ENDIF
+ ENDIF
+
+ hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) )
+
+ !
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF ! lh
+
+! And diam for hail if present
+ IF ( lhl > 1 .and. lnhl > 1 ) THEN
+ DO kz = kzb,kze
+ DO ix = ixb,ixe
+ IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN
+ IF ( lvhl .gt. 1 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
+ ELSE
+ hwdn = rho_qhl
+ ENDIF
+
+ tmp = 1. + alpha2d(ix,1,kz,3)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl))
+ diam = (6.0*tmp/pi)**(1./3.)
+ IF ( lzhl > 1 ) THEN ! 3moment
+ cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.)
+ ENDIF
+ diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda
+ ! want cxd1 = thresh_conc
+ ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
+ ! tmp = thresh_conc*g1palp/cx
+ !
+ tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl)
+ alp = alpha2d(ix,1,kz,3)
+ ! gamxinflu(i,j,luindex,ilh)
+ j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
+ ratio = 0.0
+ maxdia = 0.0
+ ! eventually could replace with bisection search, but final value of i is usually small
+ ! compared to nqiacrratio
+ DO i = 0,nqiacrratio-1
+ IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
+ ! interpolate here for FWIW
+ ratio = i*dqiacrratio
+ del = tmp - gamxinflu(i,j,1,1)
+ ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
+ exit
+ ENDIF
+ ENDDO
+
+ IF ( ratio > 0.0 ) THEN
+ maxdia = ratio*diam1 ! units of m
+ ENDIF
+
+ IF ( kz == kzb ) THEN
+ hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) )
+! IF ( maxdia > 0.1 ) THEN
+! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN
+! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
+! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
+! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
+! gamxinflu(4,j,1,1)
+! ENDIF
+ ENDIF
+
+ hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) )
+
+ !
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+
+ END SUBROUTINE HAILMAXD
+! #######################################################################
+! #######################################################################
+!>\ingroup mod_nsslmp
+!! Sedimentation driver subroutine. Calls fallout column by column
+ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
& t0,t7,infdo,jslab,its,jts, &
& timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing
!
@@ -3591,7 +4274,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
real dtp
real xfall(nx,ny,na) ! array for stuff landing on the ground
- real xfall0(nx,ny) ! dummy array
+! real xfall0(nx,ny) ! dummy array
integer infdo
integer jslab ! which line of xfall to use
@@ -3599,47 +4282,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
real tmp, vtmax, dtptmp, dtfrac
real, parameter :: dz = 200.
- real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted
- real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
- real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
- real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)
- real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted
+! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
+! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
+! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)
+! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
- real :: rhovtzx(nz,nx)
+! real :: rhovtzx(nz,nx)
+
+ real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+ real, allocatable :: rhovtzx(:,:)
+ real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:)
double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy
double precision :: dt1,dt2,dt3,dt4
- integer,parameter :: ngs = 128
+ integer :: ngs ! = 512
integer :: ngscnt,mgs,ipconc0
- real :: qx(ngs,lv:lhab)
- real :: qxw(ngs,ls:lhab)
- real :: cx(ngs,lc:lhab)
- real :: xv(ngs,lc:lhab)
- real :: vtxbar(ngs,lc:lhab,3)
- real :: xmas(ngs,lc:lhab)
- real :: xdn(ngs,lc:lhab)
- real :: xdia(ngs,lc:lhab,3)
- real :: vx(ngs,li:lhab)
- real :: alpha(ngs,lc:lhab)
- real :: zx(ngs,lr:lhab)
- logical :: hasmass(nx,lc+1:lhab)
-
- integer igs(ngs),kgs(ngs)
-
- real rho0(ngs),temcg(ngs)
-
- real temg(ngs)
-
- real rhovt(ngs)
-
- real cwnc(ngs),cinc(ngs)
- real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
-
- real cimasn,cimasx,cnina(ngs),cimas(ngs)
-
- real cnostmp(ngs)
+! real :: qx(ngs,lv:lhab)
+! real :: qxw(ngs,ls:lhab)
+! real :: cx(ngs,lc:lhab)
+! real :: xv(ngs,lc:lhab)
+! real :: vtxbar(ngs,lc:lhab,3)
+! real :: xmas(ngs,lc:lhab)
+! real :: xdn(ngs,lc:lhab)
+! real :: xdia(ngs,lc:lhab,3)
+! real :: vx(ngs,li:lhab)
+! real :: alpha(ngs,lc:lhab)
+! real :: zx(ngs,lr:lhab)
+! logical :: hasmass(nx,lc+1:lhab)
+!
+! integer igs(ngs),kgs(ngs)
+!
+! real rho0(ngs),temcg(ngs)
+!
+! real temg(ngs)
+!
+! real rhovt(ngs)
+!
+! real cwnc(ngs),cinc(ngs)
+! real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
+!
+! real cimasn,cimasx,cnina(ngs),cimas(ngs)
+!
+! real cnostmp(ngs)
+
+ real, allocatable :: qx(:,:)
+ real, allocatable :: qxw(:,:)
+ real, allocatable :: cx(:,:)
+ real, allocatable :: xv(:,:)
+ real, allocatable :: vtxbar(:,:,:)
+ real, allocatable :: xmas(:,:)
+ real, allocatable :: xdn(:,:)
+ real, allocatable :: xdia(:,:,:)
+ real, allocatable :: vx(:,:)
+ real, allocatable :: alpha(:,:)
+ real, allocatable :: zx(:,:)
+ logical, allocatable :: hasmass(:,:)
+
+ integer, allocatable :: igs(:),kgs(:)
+
+ real, allocatable :: rho0(:),temcg(:)
+
+ real, allocatable :: temg(:)
+
+ real, allocatable :: rhovt(:)
+
+ real, allocatable :: cwnc(:),cinc(:)
+ real, allocatable :: fadvisc(:),cwdia(:),cipmas(:)
+
+ real, allocatable :: cnina(:),cimas(:)
+
+ real, allocatable :: cnostmp(:)
+
+ real :: cimasn,cimasx
!-----------------------------------------------------------------------------
@@ -3653,7 +4370,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! ###################################################################
-
+ allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) )
+ allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) )
+ allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab))
+
+ ngs = nz+3
+
+ allocate( qx(ngs,lv:lhab), &
+ qxw(ngs,ls:lhab), &
+ cx(ngs,lc:lhab), &
+ xv(ngs,lc:lhab), &
+ vtxbar(ngs,lc:lhab,3), &
+ xmas(ngs,lc:lhab), &
+ xdn(ngs,lc:lhab), &
+ xdia(ngs,lc:lhab,3), &
+ vx(ngs,li:lhab), &
+ alpha(ngs,lc:lhab), &
+ zx(ngs,lr:lhab), &
+ hasmass(nx,lc+1:lhab), &
+ igs(ngs),kgs(ngs), &
+ rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), &
+ cwnc(ngs),cinc(ngs), &
+ fadvisc(ngs),cwdia(ngs),cipmas(ngs), &
+ cnina(ngs),cimas(ngs), &
+ cnostmp(ngs) )
kzb = 1
kze = nz
@@ -3825,7 +4565,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN
- IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN
+ IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. &
+ (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN
call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, &
& z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix )
ENDIF
@@ -3850,6 +4591,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDIF
ENDIF
+! reflectivity
+
+ IF ( ipconc .ge. 6 ) THEN
+ IF ( lz(il) .gt. 1 ) THEN
+ call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
+ & an,db1,lz(il),0,xfall,dtz1,ix)
+ ENDIF
+ ENDIF
if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d'
@@ -3863,9 +4612,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! to put a lower bound on number conc.
!
- IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. &
+ IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) &
+ & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. &
& ( il .eq. lr .and. irfall .eq. infall) ) ) THEN
+ ! set up for method I+II
DO kz = kzb,kze
! DO ix = ixb,ixe
tmpn2(ix,jy,kz) = z(ix,kz,il)
@@ -3878,7 +4629,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDDO
ELSE
-
+ ! set up for method II only
DO kz = kzb,kze
! DO ix = ixb,ixe
tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
@@ -3907,7 +4658,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
xfall0(:,jgs) = 0.0
IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. &
- & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN
+ & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) &
+ .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN
call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
& tmpn2,db1,1,0,xfall0,dtz1,ix)
call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), &
@@ -3918,12 +4670,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDIF
IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) &
- & .or. il .ge. lh ) ) THEN
+ & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN
! "Method I" - dbz correction
call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, &
& z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, &
- & lvol(il), rho_qh, infall, ix)
+ & lvol(il), xdn0(il), infall, ix)
ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN
@@ -3934,7 +4686,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! ENDDO
ENDDO
- ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN
+ ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN
! "Method II" M-wgt N-fallout correction
DO kz = kzb,kze
@@ -3961,8 +4713,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDDO ! ix
+ deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx )
+ deallocate( xfall0, xvt, tmpn )
+ deallocate( tmpn2, z)
+
+ deallocate( qx, &
+ qxw, &
+ cx, &
+ xv, &
+ vtxbar, &
+ xmas, &
+ xdn, &
+ xdia, &
+ vx, &
+ alpha, &
+ zx, &
+ hasmass, &
+ igs,kgs, &
+ rho0,temcg,temg, rhovt, &
+ cwnc,cinc, &
+ fadvisc,cwdia,cipmas, &
+ cnina,cimas, &
+ cnostmp )
-
RETURN
END SUBROUTINE SEDIMENT1D
@@ -4120,13 +4893,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
integer ix,jy,kz
- real vr,qr,nrx,rd,xv,g1,zx,chw,xdn
+ real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu
jy = jgs
ix = ixcol
- IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN
+ IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) &
+ .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN
DO kz = 1,kze
@@ -4176,16 +4950,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
ENDDO
- ELSEIF ( l .eq. lr .and. imurain == 3) THEN
+ ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN
- xdn = 1000.
+ xdn = rho_qx ! 1000.
+ IF ( l == ls ) ynu = snu
+ IF ( l == lr ) ynu = rnu
DO kz = 1,kze
+
IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN
vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
-! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
- z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
+! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
+ z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
! qr = a(ix,jy,kz,lr)
! nrx = a(ix,jy,kz,lnr)
@@ -4598,6 +5375,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+ IF ( lzr > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. &
+ an(ix,jy,kz,lnr) > cxmin ) THEN
+ q = an(ix,jy,kz,lr)
+ nrx = an(ix,jy,kz,lnr)
+ an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
+
! snow
IF ( lns > 1 ) THEN
IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN
@@ -4660,6 +5446,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+ IF ( lzh > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. &
+ an(ix,jy,kz,lnh) > cxmin ) THEN
+ q = an(ix,jy,kz,lh)
+ nrx = an(ix,jy,kz,lnh)
+ an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
+
! hail
IF ( lnhl > 1 .and. lhl > 1 ) THEN
@@ -4680,7 +5475,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
-
ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. &
( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN
@@ -4689,6 +5483,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+
+ IF ( lzhl > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. &
+ an(ix,jy,kz,lnhl) > cxmin ) THEN
+ q = an(ix,jy,kz,lhl)
+ nrx = an(ix,jy,kz,lnhl)
+ an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
! ENDIF
@@ -4859,6 +5662,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass
ENDIF
+ IF ( lzr > 1 ) THEN ! set reflectivity moment
+ an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
+ ENDIF
ENDIF
ENDIF
@@ -4909,6 +5715,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
!
! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
!
+! IF ( lzh > 1 ) THEN ! set reflectivity moment
+! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
+! ENDIF
! ENDIF
! ENDIF
!
@@ -4932,6 +5741,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
!
! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
!
+! IF ( lzhl > 1 ) THEN ! set reflectivity moment
+! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
+! ENDIF
! ENDIF
! ENDIF
@@ -4950,7 +5762,7 @@ END subroutine calcnfromcuten
SUBROUTINE calc_eff_radius &
& (nx,ny,nz,na,jyslab &
& ,nor,norz &
- & ,t1,t2,t3,t4 &
+ & ,t1,t2,t3,t4,t5,t6, f_t5,f_t6 &
& ,qcw,qci,qsw,qrw &
& ,ccw,cci,csw,crw &
& ,an,dn )
@@ -4972,6 +5784,9 @@ SUBROUTINE calc_eff_radius &
real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ logical, optional :: f_t5, f_t6 ! flags to fill t5/t6 for graupel/hail
real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
@@ -6490,6 +7305,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
aax = axx(mgs,lhl)
bbx = bxx(mgs,lhl)
+ ELSEIF ( icdxhl <= 0 ) THEN !
+ aax = ax(lhl)
+ bbx = bx(lhl)
ENDIF
ENDIF ! }
@@ -6798,7 +7616,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
real vtmax
real xvbarmax
-
+
+ real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
+ real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
+ real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
+
integer l1, l2
double precision :: dpt1, dpt2
@@ -7074,68 +7896,549 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
ELSEIF ( imurain == 3 ) THEN
alpha(:,lr) = xnu(lr)
ENDIF
-
-
-
+ IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN
+ DO mgs = 1,ngscnt
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
+ xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
+ alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
+ ENDIF
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
+ xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
+ xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
+ alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
+ ENDIF
+! alpha(:,lr) = 0. ! 10.
+! alpha(:,lh) = 0. ! 10.
+ IF ( lhl > 0 ) THEN
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
+ xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
+ xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
+ IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
+ alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
+ ELSE
+ alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
!
-! Set density
-!
- if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz'
+! Set 6th moments
!
+ IF ( ipconc .ge. 6 .or. lzr > 1) THEN
- call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
- & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, &
- & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
- & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, &
- & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx)
-! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)
+ zx(:,:) = 0.0
+
+! DO il = lr,lhab
+ DO il = l1,l2
+
+ IF ( lz(il) .ge. 1 ) THEN
+
+ DO mgs = 1,ngscnt
+ zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0)
+ ENDDO
+
+
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
-!
-! put fall speeds into the x-z arrays
-!
- DO il = l1,l2
- do mgs = 1,ngscnt
- vtmax = 150.0
+! Find shape parameter rain
-
- IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. &
- & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN
-
-
-
- vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) )
- vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) )
+
+ IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
+ il = lr
+ DO mgs = 1,ngscnt
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
+! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN
+ IF ( zx(mgs,lr) <= zxmin ) THEN
+ qx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN
+! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il)
+ ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
- ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
-
- IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. &
- & vtxbar(mgs,il,3) .gt. vtmax ) THEN
-
- vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) )
- vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) )
- vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) )
-
-! call commasmpi_abort()
- ENDIF
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! tmp = cx(mgs,lr)
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+! IF ( tmp < cx(mgs,il) ) THEN ! breakup
+! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+! ENDIF
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+
+! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
+! vr = xv(mgs,lr)
+
+! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! write(91,*) 'alpha = ',alpha(mgs,il)
+ IF ( qx(mgs,il) < 1.e-8 ) THEN
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ ELSE
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
+ vr = xv(mgs,lr)
+! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+! alpha(mgs,lr) = 3.
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx
+
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) ) THEN
+ tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
- xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1)
- xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2)
- IF ( infdo .ge. 2 ) THEN
- xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3)
- ELSE
- xvt(kgs(mgs),igs(mgs),3,il) = 0.0
- ENDIF
+
+ ENDIF
+ ENDIF
-! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ zx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ENDIF
+
+ ENDDO
+ ENDIF ! }
+
+
+ IF ( ipconc .ge. 6 ) THEN
+
+! Find shape parameters for graupel,hail
+
+ DO il = lr,lhab
+
+ IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
+
+ DO mgs = 1,ngscnt
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+! tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+! IF ( tmp < cx(mgs,il) ) THEN ! breakup
+! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+!
+! ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+! write(91,*) 'ziegfall: something screwy with moments: il = ',il
+! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il)
+! write(91,*) 'alpha = ',alpha(mgs,il)
+
+ IF ( qx(mgs,il) < 1.e-8 ) THEN
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ ELSE
+! write(0,*) 'alpha = ',alpha(mgs,il)
+ ! set values according to dBZ of -10
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN
+
+! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2)
+ rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2)
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+
+ IF ( imaxdiaopt == 1 ) THEN
+ xvbarmax = xvmx(il)
+ ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
+ xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
+ xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ENDIF
+
+ IF ( xv(mgs,il) .gt. xvbarmax ) THEN
+ tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN
+
+!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+ ENDIF
+ ELSE
+ ENDIF
+ ENDIF
+ ENDDO ! mgs
+
+ ENDIF ! lz(il) .gt. 1
+
+ ENDDO ! il
+
+! CALL cld_cpu('Z-MOMENT-ZFAll')
+
+ ENDIF
+
+ IF ( lzhl > 1 ) THEN
+ IF ( lhl .gt. 1 ) THEN
+
+ ENDIF
+ ENDIF
+
+
+
+!
+! Set density
+!
+ if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz'
+!
+
+ call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
+ & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, &
+ & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
+ & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, &
+ & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx)
+! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)
+
+
+
+!
+! put fall speeds into the x-z arrays
+!
+ DO il = l1,l2
+ do mgs = 1,ngscnt
+
+ vtmax = 150.0
+
+
+ IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. &
+ & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN
+
+
+! IF ( qx(mgs,il) > 1.e-4 .and. &
+! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN
+! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs
+! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
+! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
+! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
+! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
+! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
+! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
+! IF ( il .ge. lg .or. il == lr ) THEN
+! write(0,*) 'alpha = ',alpha(mgs,il)
+! ENDIF
+! ENDIF
+
+ vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) )
+ vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) )
+
+ ENDIF
+
+
+ IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. &
+ & vtxbar(mgs,il,3) .gt. vtmax ) THEN
+
+! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN
+! write(0,*) 'infdo = ',infdo
+! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
+! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
+! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
+! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
+! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
+! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
+! IF ( il .ge. lg ) THEN
+! write(0,*) 'alpha = ',alpha(mgs,il)
+! ENDIF
+! ENDIF
+ vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) )
+ vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) )
+ vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) )
+
+! call commasmpi_abort()
+ ENDIF
+
+
+ xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1)
+ xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2)
+ IF ( infdo .ge. 2 ) THEN
+ xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3)
+ ELSE
+ xvt(kgs(mgs),igs(mgs),3,il) = 0.0
+ ENDIF
+
+! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)
enddo
ENDDO
@@ -7630,6 +8933,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( ipconc .le. 2 ) THEN
gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25)
dtmp(ix,kz) = zrc*gtmp(ix,kz)**7
+ ELSEIF ( lzr .gt. 1 ) THEN
+ dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr)
ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN
IF ( imurain == 3 ) THEN
vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
@@ -7822,7 +9127,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size
! p = 0.106214 for m = p v^(2/3)
- dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
+ dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
IF ( .true. .or. dnsnow < 900. ) THEN
gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + &
& (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ &
@@ -7898,6 +9203,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN
ltest = .false.
+ IF ( lzh > 1 ) THEN
+ IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. &
+ an(ix,jy,kz,lnh) >= cxmin ) ltest = .true.
+ ENDIF
IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN
@@ -7943,6 +9252,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ENDIF
IF ( lzh .gt. 1 ) THEN
+ x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const
+ dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ dtmp(ix,kz) = dtmp(ix,kz) + dtmph
ELSE
g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw
@@ -8015,6 +9327,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( ipconc .ge. 5 ) THEN
ltest = .false.
+ IF ( lzhl > 1 ) THEN
+ IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. &
+ an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true.
+ ENDIF
IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{
chl = an(ix,jy,kz,lnhl)
@@ -8038,6 +9354,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ENDIF
IF ( lzhl .gt. 1 ) THEN !{
+ x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const
+ dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2
+ dtmp(ix,kz) = dtmp(ix,kz) + dtmphl
ELSE !}
g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
@@ -8118,8 +9437,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph
! ENDIF
-
- IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
+ IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN
! write(0,*) 'my_rank = ',my_rank
write(0,*) 'ix,jy,kz = ',ix,jy,kz
@@ -8190,6 +9508,8 @@ END subroutine radardd02
! #####################################################################
!
! Subroutine for explicit cloud condensation and droplet nucleation
+!
+! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1)
!
SUBROUTINE NUCOND &
& (nx,ny,nz,na,jyslab &
@@ -8198,6 +9518,7 @@ SUBROUTINE NUCOND &
& ,t0,t9 &
& ,an,dn,p2 &
& ,pn,w &
+ & ,ngs &
& ,axtra,io_flag &
& ,ssfilt,t00,t77,flag_qndrop &
& )
@@ -8256,6 +9577,7 @@ SUBROUTINE NUCOND &
logical :: io_flag
real :: dv
+ real :: ccnefactwo, sstmp, cn1, cnuctmp
!
! declarations microphysics and for gather/scatter
@@ -8264,7 +9586,6 @@ SUBROUTINE NUCOND &
real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj.
integer nxmpb,nzmpb,nxz
integer mgs,ngs,numgs,inumgs
- parameter (ngs=500)
integer ngscnt,igs(ngs),kgs(ngs)
integer kgsp(ngs),kgsm(ngs)
integer nsvcnt
@@ -8283,6 +9604,7 @@ SUBROUTINE NUCOND &
real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs)
+ real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs)
real ccncuf(ngs)
real sscb ! 'cloud base' SS threshold
parameter ( sscb = 2.0 )
@@ -8295,7 +9617,7 @@ SUBROUTINE NUCOND &
integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat
parameter ( ifilt = 0 )
real temp1,temp2 ! ,ssold
- real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel
+ real :: ssmax(ngs) ! maximum SS experienced by a parcel
real ssmx
real dnnet,dqnet
! real cnu,rnu,snu,cinu
@@ -8419,7 +9741,6 @@ SUBROUTINE NUCOND &
integer :: count
-
! -------------------------------------------------------------------------------
itile = nxi
jtile = ny
@@ -8433,6 +9754,7 @@ SUBROUTINE NUCOND &
kzbeg = 1
nzbeg = 1
+ IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0))
f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73)
jy = 1
@@ -8543,6 +9865,7 @@ SUBROUTINE NUCOND &
qx(:,:) = 0.0
cx(:,:) = 0.0
+ zx(:,:) = 0.0
xv(:,:) = 0.0
xmas(:,:) = 0.0
@@ -8602,6 +9925,7 @@ SUBROUTINE NUCOND &
ELSE ! equation set 2 in cm1
tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+ IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
+cpigb*(tmp)
cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
@@ -8656,12 +9980,16 @@ SUBROUTINE NUCOND &
ELSE
ssmax(mgs) = 0.0
ENDIF
- IF ( lccn .gt. 1 ) THEN
- ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+ IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN
+ IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN
+ ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf)
+ ELSE
+ ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+ ENDIF
ELSE
ccnc(mgs) = cwnccn(mgs)
ENDIF
- IF ( lccnuf .gt. 1 ) THEN
+ IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN
ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf)
ELSE
ccncuf(mgs) = 0.0
@@ -8716,6 +10044,237 @@ SUBROUTINE NUCOND &
ventrxn(:) = ventrn
+! Find shape parameter rain
+
+ IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM
+ DO mgs = 1,ngscnt
+ zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0)
+ ENDDO
+
+! CALL cld_cpu('Z-MOMENT-1r2')
+ il = lr
+ DO mgs = 1,ngscnt
+
+ IF ( zx(mgs,il) <= zxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( cx(mgs,il) <= 0.0 ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+ xv(mgs,lr) = xvmx(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+
+ ENDIF
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
+
+ ENDIF
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( imurain == 1 ) THEN
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z1 = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z1*(pi/6.*1000.)**2/xv
+
+
+! determine shape parameter alpha by iteration
+ IF ( z1 .gt. 0.0 ) THEN
+
+ IF ( imurain == 3 ) THEN
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
+! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+ ELSE ! imurain == 1
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+
+ rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
+
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
+
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+! ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ IF ( imurain == 3 ) THEN
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+
+ z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z1
+ ENDIF
+ ENDIF
+
+ ELSEIF ( imurain == 1 ) THEN
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+ z1 = g1*rho0(mgs)**2*(qr)*qr/nrx
+ z2 = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z2
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z2
+ ENDIF
+ ENDIF ! imurain
+
+ ENDIF ! z > 0
+
+ tmp = alpha(mgs,lr) + 4./3.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
+ IF ( imurain == 3 .and. izwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 1.5 + br/6.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
+
+ ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 2.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/y
+
+
+ ENDIF
+
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r2')
+ ENDIF ! }
+
! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit
ssmx = 0.0
@@ -8735,6 +10294,8 @@ SUBROUTINE NUCOND &
ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1))
ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1))
+! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs)
+
ENDDO
@@ -8744,7 +10305,7 @@ SUBROUTINE NUCOND &
! cloud water variables
!
- if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables'
+ if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables'
do mgs = 1,ngscnt
xv(mgs,lc) = 0.0
@@ -8868,23 +10429,22 @@ SUBROUTINE NUCOND &
QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) )
- IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63
+ IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63
qwvp(mgs) = qwvp(mgs) + qx(mgs,lc)
- thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))
+ thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs))
IF ( io_flag .and. nxtra > 1 ) THEN
axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp
ENDIF
qx(mgs,lc) = 0.
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
- IF ( .not. invertccn ) THEN
- ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
- ELSE
- ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
- ENDIF
- ENDIF
- IF ( lccna > 1 ) THEN
- ccna(mgs) = ccna(mgs) - cx(mgs,lc)
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
+ ELSEIF ( irenuc <= 2 ) THEN
+ IF ( .not. invertccn ) THEN
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
+ ELSE
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
+ ENDIF
ENDIF
ENDIF
cx(mgs,lc) = 0.
@@ -8894,39 +10454,37 @@ SUBROUTINE NUCOND &
qx(mgs,lc) = qx(mgs,lc) - QEVAP
IF ( qx(mgs,lc) .le. 0. ) THEN
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
+ ELSEIF ( irenuc <= 2 ) THEN
! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
IF ( .not. invertccn ) THEN
- ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
ELSE
- ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
ENDIF
ENDIF
- IF ( lccna > 1 ) THEN
- ccna(mgs) = ccna(mgs) - cx(mgs,lc)
- ENDIF
ENDIF
cx(mgs,lc) = 0.
ELSE
tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp
+ ELSEIF ( irenuc <= 2 ) THEN
! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
! ccnc(mgs) = ccnc(mgs) + tmp
IF ( .not. invertccn ) THEN
- ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) )
ELSE
- ccnc(mgs) = ccnc(mgs) + tmp
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp
ENDIF
ENDIF
- IF ( lccna > 1 ) THEN
- ccna(mgs) = ccna(mgs) - tmp
- ENDIF
ENDIF
cx(mgs,lc) = cx(mgs,lc) - tmp
ENDIF
- thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs))
+ thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs))
IF ( io_flag .and. nxtra > 1 ) THEN
axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp
ENDIF
@@ -9208,11 +10766,24 @@ SUBROUTINE NUCOND &
!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs))
- theta(mgs) = thetap(mgs) + theta0(mgs)
- temg(mgs) = theta(mgs)*f1
- ltemq = (temg(mgs)-163.15)/fqsat+1.5
- ltemq = Min( nqsat, Max(1,ltemq) )
- qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
+ IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) &
+ & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+
+ ENDIF
+ zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr )
+ ENDIF
+
+ theta(mgs) = thetap(mgs) + theta0(mgs)
+ temg(mgs) = theta(mgs)*f1
+ ltemq = (temg(mgs)-163.15)/fqsat+1.5
+ ltemq = Min( nqsat, Max(1,ltemq) )
+ qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
! es(mgs) = 6.1078e2*tabqvs(ltemq)
!
@@ -9249,7 +10820,8 @@ SUBROUTINE NUCOND &
! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works
! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails
! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK
- IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test
+ IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. &
+ ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test
! IF ( ssf(mgs) > ssmx ) THEN ! original condition
CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, &
& pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
@@ -9260,7 +10832,7 @@ SUBROUTINE NUCOND &
ELSE
dcloud = 0.0
ENDIF
-
+
thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
qwvp(mgs) = qwvp(mgs) - DCLOUD
qx(mgs,lc) = qx(mgs,lc) + DCLOUD
@@ -9285,11 +10857,16 @@ SUBROUTINE NUCOND &
IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem
+ IF ( ac_opt == 0 ) THEN
+ cnuctmp = cnuc(mgs)
+ ELSE
+ cnuctmp = ccnc_ac(mgs)
+ ENDIF
! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN
! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
- CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
+ CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 &
& .and. ncdebug .ge. 1 ) THEN
write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, &
@@ -9311,12 +10888,16 @@ SUBROUTINE NUCOND &
ENDIF
IF ( cn(mgs) .gt. 0.0 ) THEN
- IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
- cn(mgs) = ccnc(mgs)
-! ccnc(mgs) = 0.0
+ IF ( ac_opt == 0 ) THEN
+ IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
+ cn(mgs) = ccnc(mgs)
+! ccnc(mgs) = 0.0
+ ENDIF
+ ELSE
+ cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) )
ENDIF
! cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
ccna(mgs) = ccna(mgs) + cn(mgs)
ENDIF
@@ -9362,7 +10943,8 @@ SUBROUTINE NUCOND &
DSSDZ=0.
r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs))
- IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
+
+ IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
IF ( irenuc < 2 ) THEN !{
@@ -9439,6 +11021,7 @@ SUBROUTINE NUCOND &
! nucleation
CN(mgs) = Min(cn(mgs), ccnc(mgs))
cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+ CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) )
IF ( .false. .and. ny <= 2 ) THEN
write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn
@@ -9466,8 +11049,136 @@ SUBROUTINE NUCOND &
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ ELSEIF ( irenuc == 3 ) THEN !} {
+ ! Phillips Donner Garner 2007
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck
+
+! Need to calculate new ssf since condensation has happened:
+ temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+ ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+ ltemq = Min( nqsat, Max(1,ltemq) )
+
+ c1= pqs(mgs)*tabqvs(ltemq)
+
+ ssf(mgs) = 0.0
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values
+ ENDIF
+ CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) !
+
+ CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+ ! Philips, Donner et al. 2007, but results in too much limitation of
+ ! nucleation
+ CN(mgs) = Min(cn(mgs), ccnc(mgs))
+ cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+
+ ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
+ ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
+ ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ ELSEIF ( irenuc == 4 ) THEN !} {
+ ! modification of Phillips Donner Garner 2007
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp
+! cn(mgs) = Min( cn(mgs), cnuc(mgs) )
+! Need to calculate new ssf since condensation has happened:
+ temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+ ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+ ltemq = Min( nqsat, Max(1,ltemq) )
+
+ c1= pqs(mgs)*tabqvs(ltemq)
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
+ ELSE
+ ssf(mgs) = 0.0
+ ENDIF
+ CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs)
+
+ CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+ ! Philips, Donner et al. 2007, but results in too much limitation of
+ ! nucleation
+! CN(mgs) = Min(cn(mgs), ccnc(mgs))
+ cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+
+ IF ( cn(mgs) > 0.0 ) THEN
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ dcrit = 2.0*2.5e-7
+
+ dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
+ qx(mgs,lc) = qx(mgs,lc) + DCLOUD
+ thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
+ qwvp(mgs) = qwvp(mgs) - DCLOUD
+ ENDIF
+ ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
+ ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
+! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+
+
+ ELSEIF ( irenuc == 6 ) THEN !} {
+
+ ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+ cn(mgs) = 0.0
+! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation
+ IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation
+ CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
+! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
+ ! prevent this branch from activating more than 70% of CCN
+ CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) )
+! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
+
+ ELSE
+ ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007.
+
+ temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+! t0(ix,jy,kz) = temp1
+ ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+ ltemq = Min( nqsat, Max(1,ltemq) )
+
+! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
+ c1= pqs(mgs)*tabqvs(ltemq)
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
+ ELSE
+ ssf(mgs) = 0.0
+ ENDIF
+! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) !
+ CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) !
+! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck !
+
+
+ CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
+! cn(mgs) = 0.0
+ ENDIF
+! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
+!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+ ! Philips, Donner et al. 2007, but results in too much limitation of
+ ! nucleation
+! CN(mgs) = Min(cn(mgs), ccnc(mgs))
+! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+
+ IF ( cn(mgs) > 0.0 ) THEN
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+
+ ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
+
+ dcrit = 2.0*2.5e-7
+
+ dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
+ qx(mgs,lc) = qx(mgs,lc) + DCLOUD
+ thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
+ qwvp(mgs) = qwvp(mgs) - DCLOUD
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ ENDIF
ELSEIF ( irenuc == 5 ) THEN !} {
! modification of Phillips Donner Garner 2007
@@ -9525,17 +11236,22 @@ SUBROUTINE NUCOND &
! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
- ELSEIF ( irenuc == 7 ) THEN !} {
+ ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} {
! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
cn(mgs) = 0.0
+ IF ( irenuc == 7 ) THEN
+ frac = 0.9
+ ELSE
+ frac = 0.98
+ ENDIF
! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation
- IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
- CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
+ IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
+ CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
! prevent this branch from activating more than 70% of CCN
- CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) )
+ CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) )
! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
@@ -9573,7 +11289,7 @@ SUBROUTINE NUCOND &
! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs)
! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
- IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN
+ IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN
CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs)
ENDIF
@@ -9675,7 +11391,7 @@ SUBROUTINE NUCOND &
IF ( cn(mgs) > 0.0 ) THEN
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
! create some small droplets at minimum size (CP 2000), although it adds very little liquid
@@ -9694,8 +11410,6 @@ SUBROUTINE NUCOND &
ccna(mgs) = ccna(mgs) + cn(mgs)
-
-
ENDIF ! irenuc >= 0 .and. .not. flag_qndrop
IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0.
@@ -9748,7 +11462,11 @@ SUBROUTINE NUCOND &
ELSEIF ( imaxsupopt == 4 ) THEN
cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) )
ENDIF
- ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) )
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) + cn(mgs)
+ ELSE
+ ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) )
+ ENDIF
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
ENDIF
@@ -9853,15 +11571,21 @@ SUBROUTINE NUCOND &
! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr)
end if
+ IF ( lzr > 1 .and. rcond == 2 ) THEN
+ an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + &
+ & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 )
+ ENDIF
IF ( ipconc .ge. 2 ) THEN
an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0)
IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) )
- IF ( lccn .gt. 1 ) THEN
- an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) )
+ IF ( ac_opt == 0 ) THEN
+ IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN
+ an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) )
+ ENDIF
ENDIF
- IF ( lccnuf .gt. 1 ) THEN
+ IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN
an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) )
ENDIF
IF ( lccna .gt. 1 ) THEN
@@ -9938,6 +11662,42 @@ SUBROUTINE NUCOND &
IF ( lhl .gt. 1 ) THEN
+ IF ( lzhl .gt. 1 ) THEN
+
+ an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) )
+
+ IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment
+
+ IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN
+
+ IF ( lvhl .gt. 1 ) THEN
+ IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
+ ELSE
+ hwdn = xdn0(lhl)
+ ENDIF
+ hwdn = Max( xdnmn(lhl), hwdn )
+ ELSE
+ hwdn = xdn0(lhl)
+ ENDIF
+
+ chw = an(ix,jy,kz,lnhl)
+ g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
+ & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
+ z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw
+ z1 = z1*(6./(pi*hwdn))**2
+ ELSE
+ z1 = 0.0
+ ENDIF
+
+ an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) )
+
+ IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN
+! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl)
+ ENDIF
+ ENDIF
+
+ ENDIF !lzhl
if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then
@@ -10038,6 +11798,42 @@ SUBROUTINE NUCOND &
+ IF ( lzh .gt. 1 ) THEN
+
+ an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) )
+
+ IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN
+
+ IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
+
+ IF ( lvh .gt. 1 ) THEN
+ IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
+ ELSE
+ hwdn = xdn0(lh)
+ ENDIF
+ hwdn = Max( xdnmn(lh), hwdn )
+ ELSE
+ hwdn = xdn0(lh)
+ ENDIF
+
+ chw = an(ix,jy,kz,lnh)
+ g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
+ & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
+ z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw
+ z1 = z1*(6./(pi*hwdn))**2
+ ELSE
+ z1 = 0.0
+ ENDIF
+
+ an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) )
+
+ IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN
+! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh)
+ ENDIF
+ ENDIF
+
+ ENDIF
if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then
@@ -10198,6 +11994,9 @@ SUBROUTINE NUCOND &
end if
+ IF ( lzr > 1 ) THEN
+ an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) )
+ ENDIF
if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) &
& ) then
@@ -10208,6 +12007,10 @@ SUBROUTINE NUCOND &
an(ix,jy,kz,lnr) = 0.0
ENDIF
+ IF ( lzr > 1 ) THEN
+ an(ix,jy,kz,lzr) = 0.0
+ ENDIF
+
end if
!
@@ -10260,18 +12063,25 @@ SUBROUTINE NUCOND &
an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
an(ix,jy,kz,lc)= 0.0
IF ( ipconc .ge. 2 ) THEN
- IF ( lccn .gt. 1 ) THEN
- an(ix,jy,kz,lccn) = &
- & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
+ IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN
+ IF ( irenuc < 5 .and. lccna <= 1 ) THEN
+ IF ( ac_opt == 0 ) THEN
+ an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
+ ENDIF
+ ELSEIF ( lccna > 1 ) THEN
+ an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) )
+ ENDIF
ENDIF
an(ix,jy,kz,lnc) = 0.0
+ IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) )
- IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+ IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+ IF ( restoreccn ) THEN
tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)
IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst)
-
- ELSEIF ( lccn > 1 .and. restoreccn ) THEN
+ ENDIF
+ ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN
! in this case, we are treating the ccn field as ccna
tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)
! IF ( ny == 2 .and. ix == nx/2 ) THEN
@@ -10335,9 +12145,9 @@ subroutine nssl_2mom_gs &
! & ln,ipc,lvol,lz,lliq, &
& cdx, &
& xdn0,tmp3d,tkediss &
- & ,thproc,numproc,dx1,dy1 &
+ & ,thproc,numproc,dx1,dy1,ngs &
& ,timevtcalc,axtra,io_flag &
- & , has_wetscav,rainprod2d, evapprod2d &
+ & , has_wetscav,rainprod2d, evapprod2d, alpha2d &
& ,errmsg,errflg &
& ,elec,its,ids,ide,jds,jde &
& )
@@ -10425,6 +12235,12 @@ subroutine nssl_2mom_gs &
real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
+
+ real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3)
+
+ real, parameter :: tfrdry = 243.15
+
+ logical lrescalelow(lc:lhab)
real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz)
real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra)
@@ -10570,7 +12386,6 @@ subroutine nssl_2mom_gs &
!
integer nxmpb,nzmpb,nxz
integer jgs,mgs,ngs,numgs
- parameter (ngs=500) !500)
integer, parameter :: ngsz = 500
integer ntt
parameter (ntt=300)
@@ -10633,7 +12448,8 @@ subroutine nssl_2mom_gs &
real ex1, ft, rhoinv(ngs)
double precision ec0(ngs)
- real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super
+ real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super
+ real :: flim
real dw,dwr
double precision :: tmpz, tmpzmlt
real ratio, delx, dely
@@ -10714,7 +12530,7 @@ subroutine nssl_2mom_gs &
real temgx(ngs),temcgx(ngs)
real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
real elv(ngs),elf(ngs),els(ngs)
- real tsqr(ngs),ssi(ngs),ssw(ngs)
+ real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs)
real qcwtmp(ngs),qtmp,qtot(ngs)
real qcond(ngs)
real ctmp, sctmp
@@ -10729,6 +12545,7 @@ subroutine nssl_2mom_gs &
parameter ( rwradmn = 50.e-6 )
real dh0
real dg0(ngs),df0(ngs)
+ real dhwet(ngs),dhlwet(ngs),dfwet(ngs)
real clionpmx,clionnmx
parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84
@@ -10736,7 +12553,7 @@ subroutine nssl_2mom_gs &
! other arrays
real fwet1(ngs),fwet2(ngs)
- real fmlt1(ngs),fmlt2(ngs)
+ real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs)
real fvds(ngs),fvce(ngs),fiinit(ngs)
real fvent(ngs),fraci(ngs),fracl(ngs)
!
@@ -10760,6 +12577,7 @@ subroutine nssl_2mom_gs &
!
real :: sfm1(ngs),sfm2(ngs)
real :: gfm1(ngs),gfm2(ngs)
+ real :: ffm1(ngs),ffm2(ngs)
real :: hfm1(ngs),hfm2(ngs)
logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs)
@@ -10800,6 +12618,10 @@ subroutine nssl_2mom_gs &
real :: alpha(ngs,lc:lhab)
real :: dab0lh(ngs,lc:lhab,lc:lhab)
real :: dab1lh(ngs,lc:lhab,lc:lhab)
+ real :: zx(ngs,lr:lhab)
+ real :: zxmxd(ngs,lr:lhab)
+ real :: g1x(ngs,lr:lhab)
+
real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis
real :: qsimxsub(ngs) ! max depositionof qi+qs+qis
@@ -10815,6 +12637,7 @@ subroutine nssl_2mom_gs &
real ventrxn(ngs)
real g1shr, alphashr
real g1mlr, alphamlr
+ real g1smlr, alphasmlr
real massfacshr, massfacmlr
real :: qhgt8mm ! ice mass greater than 8mm
@@ -10827,6 +12650,8 @@ subroutine nssl_2mom_gs &
real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield
!
real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs)
+ real hxventtmp
+ real hlventinc(ngs),hwventinc(ngs)
integer, parameter :: ndiam = 10
integer :: numdiam
real hwvent0(ndiam+4),hlvent0 ! 0 to d1
@@ -10940,15 +12765,15 @@ subroutine nssl_2mom_gs &
real qrcnw(ngs), qwcnr(ngs)
real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs)
-
real qracw(ngs) ! qwacr(ngs),
real qiacw(ngs) !, qwaci(ngs)
real qsacw(ngs) ! ,qwacs(ngs),
real qhacw(ngs) ! qwach(ngs),
- real :: qhlacw(ngs) !
+ real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp !
real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs)
+ real qfcev(ngs)
real qfmul1(ngs),cfmul1(ngs)
!
real qsacws(ngs)
@@ -10957,7 +12782,7 @@ subroutine nssl_2mom_gs &
! arrays for x-ac-r and r-ac-x;
!
real qsacr(ngs),qracs(ngs)
- real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs)
+ real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs)
real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs)
real qiacr(ngs),qraci(ngs)
@@ -10965,7 +12790,7 @@ subroutine nssl_2mom_gs &
real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs)
- real :: qhlacr(ngs),qhlacrmlr(ngs)
+ real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs)
real qsacrs(ngs) !,qracss(ngs)
!
! ice - ice interactions
@@ -11011,7 +12836,8 @@ subroutine nssl_2mom_gs &
real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs)
real zhmlrtmp,zhmlr0inf,zhlmlr0inf
real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs)
- real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs)
+! real zsmlr(ngs)
+ real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs)
real zhcns(ngs), zhcni(ngs)
real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes
real zhldn(ngs) ! change in Z due to density changes
@@ -11052,9 +12878,10 @@ subroutine nssl_2mom_gs &
!
real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs),
real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs)
- real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs)
+ real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp
!
real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs)
+ real :: qffz(ngs)
!
real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs),
real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs)
@@ -11064,6 +12891,7 @@ subroutine nssl_2mom_gs &
real qhshh(ngs) !accreted water that remains on graupel
real qhmlh(ngs) !melt water that remains on graupel
real qhfzh(ngs) !water that freezes on mixed-phase graupel
+ real qffzf(ngs) !water that freezes on mixed-phase FD
real qhlfzhl(ngs) !water that freezes on mixed-phase hail
real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters
@@ -11115,6 +12943,7 @@ subroutine nssl_2mom_gs &
real qrshr(ngs)
real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions
real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions
+ real ffwmax(ngs)
real qhcnf(ngs)
real :: qhlcnh(ngs)
real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs)
@@ -11128,7 +12957,7 @@ subroutine nssl_2mom_gs &
real ehxr(ngs),ehlr(ngs),egmr(ngs)
real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs)
real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs)
- real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs)
+ real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs)
real ehscnv(ngs)
real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs)
@@ -11187,12 +13016,13 @@ subroutine nssl_2mom_gs &
real pqgli(ngs),pqghi(ngs),pqfwi(ngs)
real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs)
real pqiri(ngs),pqipi(ngs) ! pqwai(ngs),
- real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs)
+ real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs)
real pqlwlghi(ngs),pqlwlghli(ngs)
real pqlwlghd(ngs),pqlwlghld(ngs)
+
real pvhwi(ngs), pvhwd(ngs)
real pvfwi(ngs), pvfwd(ngs)
@@ -11204,7 +13034,7 @@ subroutine nssl_2mom_gs &
real pqgld(ngs),pqghd(ngs),pqfwd(ngs)
real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs)
real pqird(ngs),pqipd(ngs) ! pqwad(ngs),
- real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs)
+ real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs)
!
! real pqxii(ngs,nhab),pqxid(ngs,nhab)
!
@@ -11352,7 +13182,7 @@ subroutine nssl_2mom_gs &
real frcrglgm, frcrglgh, frcrglfw, frcrglgl1
real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1
real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1
- real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt
+ real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt
real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl
real frcrghgm, frcrghgh, frcrghfw, frcrghgh1
real a1,a2,a3,a4,a5,a6
@@ -11384,9 +13214,22 @@ subroutine nssl_2mom_gs &
real :: term1,term2,term3,term4
real :: qaacw ! combined qsacw-qhacw for WSM6 variation
+ real :: cwchtmp
+
+ real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
+ real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
+ real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
+! inline functions for Newton method
+ real :: galpha, dgalpha
+ real :: a_in
+ logical, parameter :: newton = .false.
+
+ galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in))
+ dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ &
+ & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6)
!
! ####################################################################
!
@@ -11416,6 +13259,11 @@ subroutine nssl_2mom_gs &
jstag = 0
kstag = 1
+ lrescalelow(:) = rescale_low_alpha
+ lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha
+ lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha
+ IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha
+ IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha
!
@@ -11533,11 +13381,18 @@ subroutine nssl_2mom_gs &
vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 )
vshd = Min(xvmx(lr), 0.523599*(dshd)**3 )
- snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0)
+ IF ( snowmeltdia > 0.0 ) THEN
+ snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0)
+ ENDIF
tdtol = 1.0e-05
tfrcbw = tfr - cbw
tfrcbi = tfr - cbi
+
+ IF ( mixedphase ) THEN
+ ibinhmlr = 0
+ ibinhlmlr = 0
+ ENDIF
!
!
! #ifdef COMMAS
@@ -11689,35 +13544,25 @@ subroutine nssl_2mom_gs &
do ix = nxmpb,itile
pqs(1) = t00(ix,jy,kz)
-! pqs(kz) = t00(ix,jy,kz)
theta(1) = an(ix,jy,kz,lt)
temg(1) = t0(ix,jy,kz)
temcg(1) = temg(1) - tfr
tqvcon = temg(1)-cbw
- ltemq = (temg(1)-163.15)/fqsat+1.5
+ ltemq = (temg(1)-163.15)/fqsat + 1.5
ltemq = Min( nqsat, Max(1,ltemq) )
qvs(1) = pqs(1)*tabqvs(ltemq)
- qis(1) = pqs(1)*tabqis(ltemq)
+ IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN
+ qis(1) = pqs(1)*tabqis(ltemq)
+ ELSE
+ ltemq = (tfr - 163.15)/fqsat + 1.5
+ qis(1) = pqs(1)*tabqis(ltemq)
+ ENDIF
qss(1) = qvs(1)
-! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN
-! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz)
-! ENDIF
-
if ( temg(1) .lt. tfr ) then
-! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = qis(kz)
-! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
-! > (qcw(kz) + qci(kz))
- qss(1) = qis(1)
- else
-! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN
-! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz)
-! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz))
-! ENDIF
+ qss(1) = qis(1)
end if
!
ishail = .false.
@@ -11793,7 +13638,12 @@ subroutine nssl_2mom_gs &
ltemq = (temg(mgs)-163.15)/fqsat+1.5
ltemq = Min( nqsat, Max(1,ltemq) )
qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
- qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN
+ qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ ELSE
+ ltemq = (tfr - 163.15)/fqsat + 1.5
+ qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ ENDIF
qss(mgs) = qvs(mgs)
! es(mgs) = 6.1078e2*tabqvs(ltemq)
! eis(mgs) = 6.1078e2*tabqis(ltemq)
@@ -11834,93 +13684,21 @@ subroutine nssl_2mom_gs &
- scx(:,:) = 0.0
+
!
-! set shape parameters
+! set concentrations
!
- IF ( imurain == 1 ) THEN
- alpha(:,lr) = alphar
- ELSEIF ( imurain == 3 ) THEN
- alpha(:,lr) = xnu(lr)
- ENDIF
-
- alpha(:,li) = xnu(li)
- alpha(:,lc) = xnu(lc)
-
- IF ( imusnow == 1 ) THEN
- alpha(:,ls) = alphas
- ELSEIF ( imusnow == 3 ) THEN
- alpha(:,ls) = xnu(ls)
- ENDIF
+! ssmax = 0.0
- DO il = lr,lhab
- do mgs = 1,ngscnt
- IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)
-
-
- DO ic = lc,lhab
- dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il)
- dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il)
- ENDDO
- ENDDO
- end do
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b'
-! DO mgs = 1,ngscnt
- DO il = lr,lhab
- da0lx(:,il) = da0(il)
- ENDDO
- da0lh(:) = da0(lh)
- da0lr(:) = da0(lr)
- da1lr(:) = da1(lr)
- da0lc(:) = da0(lc)
- da1lc(:) = da1(lc)
-
-
- IF ( lzh < 1 .or. lzhl < 1 ) THEN
- rzxhlh(:) = rzhl/rz
- ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
- rzxhlh(:) = 1.
- ENDIF
- IF ( lzr > 1 ) THEN
- rzxh(:) = 1.
- rzxhl(:) = 1.
- ELSE
- rzxh(:) = rz
- rzxhl(:) = rzhl
- ENDIF
-
- IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN
- rzxs(:) = rzs
- ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN
- rzxs(:) = 1.
- ENDIF
- ! ENDDO
-
- IF ( lhl .gt. 1 ) THEN
- DO mgs = 1,ngscnt
- da0lhl(mgs) = da0(lhl)
- ENDDO
- ENDIF
-
- ventrx(:) = ventr
- ventrxn(:) = ventrn
- gf1palp(:) = gamma_sp(1.0 + alphar)
-
-!
-! set concentrations
-!
-! ssmax = 0.0
-
-
- if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b'
-
- if ( ipconc .ge. 1 ) then
- do mgs = 1,ngscnt
- cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
- IF ( qx(mgs,li) .le. qxmin(li) ) THEN
- cx(mgs,li) = 0.0
- ENDIF
+ if ( ipconc .ge. 1 ) then
+ do mgs = 1,ngscnt
+ cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
+ IF ( qx(mgs,li) .le. qxmin(li) ) THEN
+ cx(mgs,li) = 0.0
+ ENDIF
IF ( lcina .gt. 1 ) THEN
cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina)
@@ -12074,6 +13852,124 @@ subroutine nssl_2mom_gs &
+!
+! 6th moments
+!
+
+ IF ( ipconc .ge. 6 ) THEN
+ zx(:,:) = 0.0
+ DO il = lr,lhab
+ IF ( lz(il) .gt. 1 ) THEN
+ DO mgs = 1,ngscnt
+ zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
+ ENDDO
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF ( ipconc .ge. 6 ) THEN
+
+ IF ( lz(lr) .lt. 1 ) THEN
+ g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ &
+ & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
+
+
+ DO mgs = 1,ngscnt
+ IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ IF ( lzr < 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0)
+ ELSE ! imurain == 1
+ zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+
+ scx(:,:) = 0.0
+!
+! set shape parameters
+!
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha'
+ IF ( imurain == 1 ) THEN
+ alpha(:,lr) = alphar
+ ELSEIF ( imurain == 3 ) THEN
+ alpha(:,lr) = xnu(lr)
+ ENDIF
+
+ alpha(:,li) = xnu(li)
+ alpha(:,lc) = xnu(lc)
+
+ IF ( imusnow == 1 ) THEN
+ alpha(:,ls) = alphas
+ ELSEIF ( imusnow == 3 ) THEN
+ alpha(:,ls) = xnu(ls)
+ ENDIF
+
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab'
+
+ DO il = lr,lhab
+ do mgs = 1,ngscnt
+ IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)
+
+
+ DO ic = lc,lhab
+ dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il)
+ dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il)
+ ENDDO
+ end do
+ ENDDO
+
+
+! DO mgs = 1,ngscnt
+ DO il = lr,lhab
+ da0lx(:,il) = da0(il)
+ ENDDO
+ da0lh(:) = da0(lh)
+ da0lr(:) = da0(lr)
+ da1lr(:) = da1(lr)
+ da0lc(:) = da0(lc)
+ da1lc(:) = da1(lc)
+
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz'
+
+ IF ( lzh < 1 .or. lzhl < 1 ) THEN
+ rzxhlh(:) = rzhl/rz
+ ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
+ rzxhlh(:) = 1.
+ ENDIF
+ IF ( lzr > 1 ) THEN
+ rzxh(:) = 1.
+ rzxhl(:) = 1.
+ ELSE
+ rzxh(:) = rz
+ rzxhl(:) = rzhl
+ ENDIF
+
+ IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN
+ rzxs(:) = rzs
+ ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN
+ rzxs(:) = 1.
+ ENDIF
+ ! ENDDO
+
+ IF ( lhl .gt. 1 ) THEN
+ DO mgs = 1,ngscnt
+ da0lhl(mgs) = da0(lhl)
+ ENDDO
+ ENDIF
+
+ ventrx(:) = ventr
+ ventrxn(:) = ventrn
+ gf1palp(:) = gamma_sp(1.0 + alphar)
!
! set factors
@@ -12112,6 +14008,7 @@ subroutine nssl_2mom_gs &
tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+ IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
+cpigb*(tmp)
@@ -12231,62 +14128,880 @@ subroutine nssl_2mom_gs &
ENDIF
- IF ( lhl .gt. 1 ) THEN
+ IF ( lhl .gt. 1 ) THEN
+
+ xdn(mgs,lhl) = xdn0(lhl)
+ xdntmp(mgs,lhl) = xdn0(lhl)
+
+ IF ( lvol(lhl) .gt. 1 ) THEN
+ IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
+
+ IF ( mixedphase .and. lhlw > 1 ) THEN
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+
+ xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
+ vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
+ xdntmp(mgs,lhl) = xdn(mgs,lhl)
+
+ ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value
+
+ vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+
+ end do
+
+ IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN
+
+ cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
+
+ DO mgs = 1,ngscnt
+ !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh)
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
+ xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
+ ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
+ ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000.
+
+ ! M&M-C 2010:
+ tmp = 4. + alphar
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 1. + alphar
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp
+
+ alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
+ ENDIF
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
+! MY 2005:
+ xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
+ xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
+! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
+
+ ! M&M-C 2010:
+ tmp = 4. + dnu(lh)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 1. + dnu(lh)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp
+
+ alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
+ ! alphan(mgs,lh) = alpha(mgs,lh)
+
+ ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000.
+ il = lh
+ DO ic = lc,lh-1 ! lhab
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+ ENDDO
+ ENDIF
+! alpha(:,lr) = 0. ! 10.
+! alpha(:,lh) = 0. ! 10.
+ IF ( lhl > 0 ) THEN
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
+ xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
+ xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
+ IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
+ alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
+ ELSE
+ alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
+ ENDIF
+
+ il = lhl
+ DO ic = lc,lh-1 ! lhab
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+
+
+ ENDDO
+ ENDIF
+
+
+ IF ( imurain == 3 ) THEN
+ IF ( lzr > 1 ) THEN
+ alphashr = 0.0
+ alphamlr = -2.0/3.0
+ alphasmlr = -2.0/3.0
+ ELSE
+ alphashr = xnu(lr)
+ alphamlr = xnu(lr)
+ alphasmlr = xnu(lr)
+ ENDIF
+! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor
+! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.)
+ massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor
+ massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) )
+ ELSEIF ( imurain == 1 ) THEN
+ IF ( lzr > 1 ) THEN
+ alphashr = 4.0
+ alphamlr = 4.0
+ alphasmlr = alphasmlr0
+ ELSE
+ alphashr = alphar
+ alphamlr = alphar
+ alphasmlr = alphar
+ ENDIF
+! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor
+! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.)
+ massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor
+ massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )
+ ENDIF
+
+! Find shape parameter rain
+
+ g1shr = 1.0
+ g1mlr = 1.0
+ g1smlr = 1.0
+
+! CALL cld_cpu('Z-MOMENT-1')
+
+ IF ( ipconc >= 6 ) THEN
+
+ ! set base g1x in case rain is not 3-moment
+ IF ( ipconc >= 6 .and. imurain == 3 ) THEN
+ il = lr
+ DO mgs = 1,ngscnt
+! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0))
+ ENDDO
+ ENDIF
+
+ IF (lzr > 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ g1shr = (alphashr+2.0)/((alphashr+1.0))
+ g1mlr = (alphamlr+2.0)/((alphamlr+1.0))
+ g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0))
+ ELSEIF ( imurain == 1 ) THEN
+! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
+! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
+ g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
+ & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
+! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
+! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
+ g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
+ & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
+ g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ &
+ & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr))
+ ENDIF
+ ENDIF
+
+ IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
+
+
+! CALL cld_cpu('Z-MOMENT-1r')
+ il = lr
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
+
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
+ IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+! alpha(mgs,lr) = 3.
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN
+ tmp = cx(mgs,il)
+ IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE ! simple cutoff
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+ ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
+ ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
+ ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
+ ! stay consistent with dN/dt and dq/dt.
+ IF ( alp >= rnumax - 0.01 ) THEN
+! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
+! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2)
+ g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
+ ELSE
+ g1x(mgs,il) = g1
+ ENDIF
+
+ tmp = alpha(mgs,lr) + 4./3.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ gf1palp(mgs) = y
+
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
+ ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
+ IF ( imurain == 3 .and. izwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 1.5 + br/6.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
+
+! This whole section is imurain == 3, so this branch never runs
+! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
+!
+! tmp = alpha(mgs,lr) + 2.5 + br/2.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
+! ventrxn(mgs) = x/y
+
+
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r')
+ ENDIF ! }
+
+ ENDIF ! ipconc >= 6
+
+! Find shape parameters for graupel and hail
+ IF ( ipconc .ge. 6 ) THEN
+
+ DO il = lr,lhab
+
+ ! set base values of g1x
+ IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN
+ DO mgs = 1,ngscnt
+ g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ ENDDO
+ ENDIF
+
+ IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
+
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ zx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
+ & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
+ zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSE
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN
+
+! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
+ alp = Max( alphamin, Min( alphamax, alp ) )
+
+ IF ( newton ) THEN
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = alp + ( galpha(alp) - rdi )/dgalpha(alp)
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+ ELSE
+ DO i = 1,10
+! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+ ENDIF
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+ IF ( imaxdiaopt == 1 ) THEN
+ xvbarmax = xvmx(il)
+ ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
+ xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
+ xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ELSE
+ xvbarmax = xvmx(il)
+ ENDIF
+
+ IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN
+ tmp = cx(mgs,il)
+ IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE
+ xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
+ .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+ wtest = .false.
+ IF ( irescalerainopt == 0 ) THEN
+ wtest = .false.
+ ELSEIF ( irescalerainopt == 1 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc)
+ ELSEIF ( irescalerainopt == 2 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ELSEIF ( irescalerainopt == 3 ) THEN
+ wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ENDIF
+
+ IF ( il == lr .and. ( wtest ) ) THEN
+! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN
+ ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
+ ! drops (i.e., favor preserving Z when alpha tries to go negative)
+ chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1
+ cx(mgs,il) = chw
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
+ ELSE
+
+ ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+ ENDIF
+ ENDIF
+
+
+ ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
+ ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
+ ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
+ ! stay consistent with dN/dt and dq/dt.
+! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2
+! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2
+ IF ( alp >= alphamax - 0.5 ) THEN
+! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
+! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2)
+ g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
+ ELSE
+ g1x(mgs,il) = g1
+ ENDIF
+
+ ENDIF
+
+! IF ( ny .eq. 2 ) THEN
+! IF ( qr .gt. 1.e-3 ) THEN
+! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000.
+! ENDIF
+! ENDIF
+
+
+ ENDIF ! .true.
+
+ IF ( il == lr ) THEN
+
+! tmp = alpha(mgs,lr) + 4./3.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+! tmp = alpha(mgs,lr) + 1.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
+! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
- xdn(mgs,lhl) = xdn0(lhl)
- xdntmp(mgs,lhl) = xdn0(lhl)
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
- IF ( lvol(lhl) .gt. 1 ) THEN
- IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
+ gf1palp(mgs) = y
- IF ( mixedphase .and. lhlw > 1 ) THEN
- ELSE
- dnmx = xdnmx(lhl)
- ENDIF
+ IF ( iferwisventr == 2 ) THEN
+ tmp = alpha(mgs,lr) + 2.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
- xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
- vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
- xdntmp(mgs,lhl) = xdn(mgs,lhl)
-
- ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
- vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
-
+ ventrxn(mgs) = x/y
+
ENDIF
- ENDIF
-
- ENDIF
+
+ ENDIF ! il==lr
+
+
+ ELSE ! below mass threshold
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+! z1 = g1*rho0(mgs)**2*(qr)*qr/chw
+! z = 1.e18*z1*(6./(pi*1000.))**2
+! z = z1*(6./(pi*1000.))**2
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF ! ( qx(mgs,il) .gt. qxmin(il) )
+
+
+
+! ENDIF
+ ENDDO ! mgs
+! CALL cld_cpu('Z-DELABK')
+
+! IF ( il == lr ) THEN
+! xnutmp = (alpha(mgs,il) - 2.)/3.
+! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+! ENDIF
+
+ IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN
+! CALL cld_cpu('Z-DELABK')
+ DO mgs = 1,ngscnt
+ IF ( qx(mgs,il) > qxmin(il) ) THEN
+ xnutmp = (alpha(mgs,il) - 2.)/3.
+
+! IF ( .true. ) THEN
+ DO ic = lc,lh-1 ! lhab
+ IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN
+ xnuc = xnu(ic)
+ IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu
+ IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ xnuc = alpha(mgs,lr) ! alpha is nu already
+ ELSE
+ xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu
+ ENDIF
+ ENDIF
+ ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected
+ IF ( .false. ) THEN
+ dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic)
+ dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic)
+ dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
+ dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
+ ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+
+! tmp1 = dab0lu(j,i,ic,il)
+! tmp2 = dab1lu(j,i,ic,il)
+! tmp3 = dab0lu(i,j,il,ic)
+! tmp4 = dab1lu(i,j,il,ic)
+! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic)
+! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic)
+! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
+! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
+
+ IF ( .false. .and. ny <= 2 ) THEN
+ write(0,*)
+ write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic)
+ write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j
+ write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1
+ write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2
+ write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5
+ write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+ ENDDO
- end do
+! ENDIF
+
+ da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( il .eq. lh ) THEN
+ da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( lzr > 1 ) THEN
+ rzxh(mgs) = 1.
+ ELSE
+ rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
+ ENDIF
+
+ IF ( lzhl < 1 ) THEN
+ rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))))
+ ENDIF
+ ELSEIF ( il .eq. lhl ) THEN
+ da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( lzr > 1 ) THEN
+ rzxhl(mgs) = 1.
+ ELSE
+ rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
+ ENDIF
+ ELSEIF ( il == lr ) THEN
+ xnutmp = (alpha(mgs,il) - 2.)/3.
+ da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1)
+ ENDIF
+
+ ENDIF ! ( qx(mgs,il) > qxmin(il) )
+ ENDDO ! mgs
+! CALL cld_cpu('Z-DELABK')
+ ENDIF ! il /= lr
+! CALL cld_cpu('Z-DELABK')
+
+ ENDIF ! lz(il) .gt. 1
+
+ ENDDO ! il
+
+ ENDIF ! ipconc .ge. 6
- IF ( imurain == 3 ) THEN
- IF ( lzr > 1 ) THEN
- alphashr = 0.0
- alphamlr = -2.0/3.0
- ELSE
- alphashr = xnu(lr)
- alphamlr = xnu(lr)
- ENDIF
-! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor
-! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.)
- massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor
- massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) )
- ELSEIF ( imurain == 1 ) THEN
- IF ( lzr > 1 ) THEN
- alphashr = 4.0
- alphamlr = 4.0
- ELSE
- alphashr = alphar
- alphamlr = alphar
- ENDIF
-! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor
-! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.)
- massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor
- massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )
- ENDIF
-
+! CALL cld_cpu('Z-MOMENT-1')
!
! set some values for ice nucleation
@@ -12318,7 +15033,7 @@ subroutine nssl_2mom_gs &
! & itype1a,itype2a,temcg,infdo,alpha)
- infdo = 0
+ infdo = 1
IF ( rimdenvwgt > 0 ) infdo = 1
call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
@@ -12332,9 +15047,9 @@ subroutine nssl_2mom_gs &
IF ( lwsm6 .and. ipconc == 0 ) THEN
tmp = Max(qxmin(lh), qxmin(ls))
DO mgs = 1,ngscnt
- sum = qx(mgs,lh) + qx(mgs,ls)
- IF ( sum > tmp ) THEN
- vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum
+ total = qx(mgs,lh) + qx(mgs,ls)
+ IF ( total > tmp ) THEN
+ vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total
ELSE
vt2ave(mgs) = 0.0
ENDIF
@@ -12480,6 +15195,17 @@ subroutine nssl_2mom_gs &
+ IF ( ipconc >= 6 ) THEN
+ frac = 0.4d0
+ zxmxd(:,:) = 0.0
+ DO il = lr,lhab
+ IF ( lz(il) > 0 .or. ( il == lr ) ) THEN
+ DO mgs = 1,ngscnt
+ zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
@@ -12517,10 +15243,10 @@ subroutine nssl_2mom_gs &
vshdgs(mgs,il) = vshd ! base value
- IF ( qx(mgs,il) > qxmin(il) ) THEN
+ IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN
! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter.
- tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015
+ tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015
IF ( tmpdiam > sheddiam0 ) THEN
vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice
@@ -12577,13 +15303,13 @@ subroutine nssl_2mom_gs &
ers(mgs) = 0.0
ess(mgs) = 0.0
ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn
+ ehsfac(mgs) = 1.0 ! factor based on ice saturation
ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn
ehscnv(mgs) = 0.0
! ehxs(mgs) = 0.0
!
eiw(mgs) = 0.0
eii(mgs) = 0.0
-
ehsclsn(mgs) = 0.0
ehiclsn(mgs) = 0.0
ehlsclsn(mgs) = 0.0
@@ -12678,7 +15404,7 @@ subroutine nssl_2mom_gs &
if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then
- if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then
+ if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then
! erm 5/10/2007 test following change:
! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then
eiw(mgs) = 0.5
@@ -12802,7 +15528,7 @@ subroutine nssl_2mom_gs &
ELSE
fac = Abs(ess0)
- IF ( .true. .and. ess0 < 0.0 ) THEN
+ IF ( iessopt == 2 ) THEN ! experimental code
! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN
IF ( wvel(mgs) > 2.0 ) THEN
! assume convective cell or downdraft
@@ -12810,9 +15536,25 @@ subroutine nssl_2mom_gs &
ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values
fac = Max(0.0, 2.0 - wvel(mgs))*fac
ENDIF
+ ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat
+ IF ( ssi(mgs) <= 1.0 ) THEN
+ fac = 0.0
+ ehsfac(mgs) = 0.0
+ ELSEIF ( ssi(mgs) <= 1.02 ) THEN
+ fac = fac*(ssi(mgs) - 1.0)/0.02
+ ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02
+ ENDIF
+ ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.)
+ IF ( ssi(mgs) <= 1.0 ) THEN
+ fac = 0.1
+ ehsfac(mgs) = 0.1
+ ELSEIF ( ssi(mgs) <= 1.005 ) THEN
+ fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005)
+ ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005)
+ ENDIF
ENDIF
- IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25
+ IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1
ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2
ELSEIF ( temcg(mgs) >= esstem2 ) THEN
ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) )
@@ -12923,7 +15665,11 @@ subroutine nssl_2mom_gs &
ELSE
ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0))
ENDIF
- if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then
+
+ IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN
+! ehsclsn(mgs) = ehs_collsn
+! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. )
+! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then
ehsclsn(mgs) = ehs_collsn
IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN
ehsclsn(mgs) = 0.0
@@ -12933,10 +15679,9 @@ subroutine nssl_2mom_gs &
ehsclsn(mgs) = ehs_collsn
ENDIF
! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density
- ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density
+ ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band
! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density
ehs(mgs) = Min(ehs(mgs),ehsmax)
- IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0
end if
ENDIF
!
@@ -12944,7 +15689,7 @@ subroutine nssl_2mom_gs &
ehiclsn(mgs) = ehi_collsn
ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) )
- if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
+! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
end if
IF ( lis > 1 ) THEN
@@ -12952,7 +15697,7 @@ subroutine nssl_2mom_gs &
ehisclsn(mgs) = ehi_collsn
ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) )
- if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
+! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
end if
ENDIF
@@ -13089,6 +15834,7 @@ subroutine nssl_2mom_gs &
end do
+
!
!
!
@@ -13162,6 +15908,7 @@ subroutine nssl_2mom_gs &
do mgs = 1,ngscnt
qraci(mgs) = 0.0
craci(mgs) = 0.0
+ qracs(mgs) = 0.0
IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN
IF ( ipconc .ge. 3 ) THEN
@@ -13207,8 +15954,9 @@ subroutine nssl_2mom_gs &
ENDIF
end do
!
+ IF ( ipconc < 3 ) THEN
do mgs = 1,ngscnt
- qracs(mgs) = 0.0
+ qracs(mgs) = 0.0
IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN
IF ( lwsm6 .and. ipconc == 0 ) THEN
vt = vt2ave(mgs)
@@ -13225,6 +15973,7 @@ subroutine nssl_2mom_gs &
& , qsmxd(mgs))
ENDIF
end do
+ ENDIF
!
!
@@ -13371,6 +16120,7 @@ subroutine nssl_2mom_gs &
!
do mgs = 1,ngscnt
qhacw(mgs) = 0.0
+ qhacwmlr(mgs) = 0.0
rarx(mgs,lh) = 0.0
vhacw(mgs) = 0.0
vhsoak(mgs) = 0.0
@@ -13437,6 +16187,11 @@ subroutine nssl_2mom_gs &
ENDIF
+ qhacwmlr(mgs) = qhacw(mgs)
+ IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN
+ qhacw(mgs) = 0.0
+ ENDIF
+
IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
IF ( temg(mgs) .lt. 273.15) THEN
@@ -13466,14 +16221,18 @@ subroutine nssl_2mom_gs &
rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2)
- ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
+ ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
& *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) &
& /(temg(mgs)-273.15))
! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
- rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ IF ( irimdenopt == 3 ) THEN
+ rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
+ rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
+ ENDIF
ENDIF
ELSE
@@ -13687,6 +16446,7 @@ subroutine nssl_2mom_gs &
do mgs = 1,ngscnt
qhlacw(mgs) = 0.0
+ qhlacwmlr(mgs) = 0.0
vhlacw(mgs) = 0.0
vhlsoak(mgs) = 0.0
IF ( lhl > 1 .and. .true.) THEN
@@ -13715,10 +16475,15 @@ subroutine nssl_2mom_gs &
qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv )
+ qhlacwmlr(mgs) = qhlacw(mgs)
+ IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN
+ qhlacw(mgs) = 0.0
+ ENDIF
+
IF ( lvol(lhl) .gt. 1 ) THEN
IF ( temg(mgs) .lt. 273.15) THEN
- IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985)
+ IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985)
rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
& *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) &
& /(temg(mgs)-273.15))**(rimc2)
@@ -13732,13 +16497,17 @@ subroutine nssl_2mom_gs &
rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2)
- ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
+ ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) &
& *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) &
& /(temg(mgs)-273.15)
! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
- rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ IF ( irimdenopt == 3 ) THEN
+ rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
+ rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
+ ENDIF
ENDIF
ELSE
@@ -14053,7 +16822,7 @@ subroutine nssl_2mom_gs &
frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow)))
qiacrs(mgs) = (1.-frach)*qiacr(mgs)
- ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs)
+ ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs)
ENDIF
ENDIF
@@ -14083,7 +16852,7 @@ subroutine nssl_2mom_gs &
tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass
IF ( tmp .lt. essfrac1 ) THEN
ec0(mgs) = 1.0
- ELSEIF ( tmp .gt. essfrac2 ) THEN
+ ELSEIF ( tmp .ge. essfrac2 ) THEN
ec0(mgs) = 0.0
ELSE
ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1)
@@ -14160,7 +16929,21 @@ subroutine nssl_2mom_gs &
ec0(mgs) = 2.e9
IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
rwrad = 0.5*xdia(mgs,lr,3)
- IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
+
+
+ ! check median volume diameter
+ IF ( icracrthresh > 1 ) THEN
+ IF ( imurain == 1 ) THEN
+ tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM)
+ ELSE ! imurain == 3,
+ tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb)
+ ENDIF
+ ELSE
+ tmp = xdia(mgs,lr,3) - 0.1e-3
+ ENDIF
+
+! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
+ IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN
ec0(mgs) = 0.0
cracr(mgs) = 0.0
ELSE
@@ -14242,6 +17025,7 @@ subroutine nssl_2mom_gs &
!
if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
chaci(:) = 0.0
+ chaci0(:) = 0.0
if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
do mgs = 1,ngscnt
IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN
@@ -14292,6 +17076,7 @@ subroutine nssl_2mom_gs &
!
if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
chacs(:) = 0.0
+ chacs0(:) = 0.0
if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
do mgs = 1,ngscnt
IF ( ehs(mgs) .gt. 0 ) THEN
@@ -14451,7 +17236,7 @@ subroutine nssl_2mom_gs &
! Ziegler (1985) autoconversion
!
!
- IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion
+ IF ( ipconc .ge. 2 ) THEN
if (ndebug .gt. 0 ) write(0,*) 'conc 26a'
DO mgs = 1,ngscnt
@@ -14534,6 +17319,47 @@ subroutine nssl_2mom_gs &
IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN
+! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs))
+! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2)
+ ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1)
+ ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2)
+ ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok.
+ IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN
+ tmp3 = qx(mgs,lr)/cx(mgs,lr)
+ tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
+ if (imurain == 3) then
+ vr = rho0(mgs)*qrcnw(mgs)/(1000.)
+ tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ else
+ tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
+ endif
+ IF ( dmrauto == 1 ) THEN ! Preserve alpha
+ zrcnw(mgs) = tmp4
+ ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average
+ zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
+ ENDIF
+ else ! original formulation
+ IF ( imurain == 3 ) THEN
+ vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
+ zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ ELSE ! rain in gamma of diameter
+ IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN
+ zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
+ ELSE
+ tmp3 = qx(mgs,lr)/cx(mgs,lr)
+ zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
+ ENDIF
+! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
+! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ ENDIF
+ endif
+! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ ENDIF
+ ENDIF ! ipconc >= 6
! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 )
! : THEN
! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
@@ -14744,6 +17570,15 @@ subroutine nssl_2mom_gs &
ELSE !{
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ ! interpolate along x, i.e., ratio;
+ tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
+ tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
+
+ ! interpolate along alpha;
+
+ zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
+ ENDIF
IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
@@ -14753,6 +17588,10 @@ subroutine nssl_2mom_gs &
crfrzs(mgs) = crfrz(mgs)
qrfrzs(mgs) = qrfrz(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ zrfrzf(mgs) = 0.
+ ENDIF
ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals
! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone!
@@ -14764,6 +17603,10 @@ subroutine nssl_2mom_gs &
crfrzf(mgs) = 0.0
qrfrzf(mgs) = 0.0
+ IF (ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ zrfrzf(mgs) = 0.
+ ENDIF
ELSE !{
! recalculate using dhmn for ratio
@@ -14803,10 +17646,23 @@ subroutine nssl_2mom_gs &
crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs)
qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ ! interpolate along x, i.e., ratio;
+ tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
+ tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
+
+ ! interpolate along alpha;
+
+ zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
+ zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs)
+ zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs)
+ ENDIF
ENDIF ! }
ELSE
crfrzs(mgs) = 0.0
qrfrzs(mgs) = 0.0
+ zrfrzs(mgs) = 0.0
ENDIF ! }
ENDIF !}
@@ -14819,6 +17675,10 @@ subroutine nssl_2mom_gs &
crfrz(mgs) = fac*crfrz(mgs)
crfrzs(mgs) = fac*crfrzs(mgs)
crfrzf(mgs) = fac*crfrzf(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrz(mgs) = fac*zrfrz(mgs)
+ zrfrzf(mgs) = fac*zrfrzf(mgs)
+ ENDIF
ENDIF
ENDIF !}
@@ -15363,8 +18223,16 @@ subroutine nssl_2mom_gs &
x = 1. + alpha(mgs,lr)
- IF ( lzr > 1 ) THEN ! 3 moment
-!
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment
+ tmp = 1. + alpr ! alpha(mgs,lr)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
ELSE
y = ventrxn(mgs)
ENDIF
@@ -15380,6 +18248,13 @@ subroutine nssl_2mom_gs &
& 0.308*fvent(mgs)*y* &
& Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+ rwventz(mgs) = 0.0
+
+! rwventz(mgs) = &
+! & 0.78*x + &
+! & 0.308*fvent(mgs)*y* &
+! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+
ELSEIF ( iferwisventr == 2 ) THEN
@@ -15392,6 +18267,23 @@ subroutine nssl_2mom_gs &
& *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
+ IF ( ipconc >= 7 ) THEN
+ alpr = Min(alpharmax,alpha(mgs,lr) )
+
+ tmp = alpr + 5.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! rwventz(mgs) = &
+! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + &
+ rwventz(mgs) = &
+ & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + &
+ & 0.308*fvent(mgs)* &
+ & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0))
+
+ ENDIF
+
ENDIF ! iferwisventr
@@ -15434,6 +18326,9 @@ subroutine nssl_2mom_gs &
hwventa = (0.78)*gmoi(igmhwa)
hwventb = (0.308)*gmoi(igmhwb)
! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25)
+ hwvent(:) = 0.0
+ hwventy(:) = 0.0
+
do mgs = 1,ngscnt
IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25)
@@ -15554,6 +18449,8 @@ subroutine nssl_2mom_gs &
& -ftka(mgs)*temcg(mgs)/rho0(mgs) ) &
& / (felf(mgs))
fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs)
+ fmlt1e(mgs) = (2.0*pi)* &
+ & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs))
end do
!
! Vapor Deposition constants
@@ -15581,6 +18478,7 @@ subroutine nssl_2mom_gs &
qhlmlrlg(:) = 0.0
ENDIF
qhfzh(:) = 0.0
+ qffzf(:) = 0.0
qhlfzhl(:) = 0.0
qhfzhlg(:) = 0.0
qhlfzhllg(:) = 0.0
@@ -15588,9 +18486,10 @@ subroutine nssl_2mom_gs &
vffzf(:) = 0.0
vhlfzhl(:) = 0.0
qsfzs(:) = 0.0
- zsmlr(:) = 0.0
+! zsmlr(:) = 0.0
zhmlr(:) = 0.0
zhmlrr(:) = 0.0
+ zsmlrr(:) = 0.0
zhshr(:) = 0.0
zhlmlr(:) = 0.0
zhlshr(:) = 0.0
@@ -15642,7 +18541,7 @@ subroutine nssl_2mom_gs &
qhmlr(mgs) = &
& meltfac*min( &
& fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) &
- & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) &
+ & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) &
& , 0.0 )
ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
@@ -15674,13 +18573,13 @@ subroutine nssl_2mom_gs &
qhlmlr(mgs) = &
& meltfac*min( &
& fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) &
- & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) &
+ & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) &
& , 0.0 )
ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
-! #ifdef Z3MOM
-! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP )
+! #ifdef 1
+! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP )
ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results
@@ -15711,7 +18610,7 @@ subroutine nssl_2mom_gs &
chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) )
ENDIF
! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion
- qhmlh(mgs) = 0.
+ qhmlh(mgs) = 0. ! not used
! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding
@@ -15788,8 +18687,15 @@ subroutine nssl_2mom_gs &
! ENDIF
-
IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0
+ IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+ alp = alpha(mgs,lh)
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
+
+ ENDIF
IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
IF ( ihmlt .eq. 1 ) THEN
@@ -15895,6 +18801,17 @@ subroutine nssl_2mom_gs &
ENDIF !}
+ IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN
+ IF ( cx(mgs,lhl) > 0.0 ) THEN
+
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ alp = alpha(mgs,lhl)
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) )
+ ENDIF
+ ENDIF
ENDIF ! }
ENDIF ! }.not. mixedphase
@@ -15932,6 +18849,7 @@ subroutine nssl_2mom_gs &
ENDDO
!
!
+ qhdsv(:) = 0.0
qhldsv(:) = 0.0
do mgs = 1,ngscnt
@@ -15941,6 +18859,7 @@ subroutine nssl_2mom_gs &
& fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac
qsdsv(mgs) = &
& fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac
+
! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN
! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1),
@@ -16177,20 +19096,41 @@ subroutine nssl_2mom_gs &
! end of qlimit
+ qhcev(:) = 0.0
+ chcev(:) = 0.0
+ qhlcev(:) = 0.0
+ chlcev(:) = 0.0
+ qfcev(:) = 0.0
+
do mgs = 1,ngscnt
qisbv(mgs) = 0.0
qssbv(mgs) = 0.0
qidpv(mgs) = 0.0
qsdpv(mgs) = 0.0
+ qhsbv(mgs) = 0.0
+ qscev(mgs) = 0.0
+ cscev(mgs) = 0.0
IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh &
- & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
+ & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr<qmin & qc<qmin) for case icond=0
! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) )
! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) )
! erm 5/10/2007:
qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) )
+ IF ( temg(mgs) < tfr .or. .not. qsmlr(mgs) < 0.0 ) THEN
qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) )
+ ENDIF
qidpv(mgs) = Max(qidsv(mgs), 0.0)
qsdpv(mgs) = Max(qsdsv(mgs), 0.0)
+
+ IF ( qsmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN ! switch snow sublimation to evaporation if there is melting
+
+ qscev(mgs) = evapfac* &
+ & 4.0*pi*(qx(mgs,lv)-qss0(mgs))*cx(mgs,ls)*swcap(mgs)*swvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+ qscev(mgs) = Max( Min(0.0,qscev(mgs)), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) )
+ ELSE
+
+ ENDIF
+
ELSE
@@ -16200,16 +19140,49 @@ subroutine nssl_2mom_gs &
qsdpv(mgs) = 0.0
ENDIF
+ qhsbv(mgs) = 0.0
+ qhdpv(mgs) = 0.0
+ IF ( qx(mgs,lh) > qxmin(lh) ) THEN
+ IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN
+ ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate
qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) )
-
qhdpv(mgs) = Max(qhdsv(mgs), 0.0)
+ ENDIF
+
+ IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
+ ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
+! qhcev(mgs) = &
+! & evapfac*min( &
+! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 )
+
+ qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
+ & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+
+ qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs))
+ IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) )
+
+ ENDIF
+ ENDIF
qhlsbv(mgs) = 0.0
qhldpv(mgs) = 0.0
IF ( lhl .gt. 1 ) THEN
+ IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN
+ IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN
qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) )
qhldpv(mgs) = Max(qhldsv(mgs), 0.0)
+ ENDIF
+ IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
+ ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
+ qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
+ & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+
+ qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs))
+ IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) )
+
+ ENDIF
+ ENDIF
ENDIF
temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs)
@@ -16345,6 +19318,10 @@ subroutine nssl_2mom_gs &
end if
end do
+
+
+
+
!
!
! compute dry growth rate of snow, graupel, and hail
@@ -16371,7 +19348,7 @@ subroutine nssl_2mom_gs &
!
do mgs = 1,ngscnt
- IF ( temg(mgs) < tfr ) THEN
+ IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN
!
! qswet(mgs) =
! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs)
@@ -16382,31 +19359,39 @@ subroutine nssl_2mom_gs &
! IF ( dnu(lh) .ne. 0. ) THEN
! qhwet(mgs) = qhdry(mgs)
! ELSE
+ IF ( incwet == 0 ) THEN
qhwet(mgs) = &
& ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) &
& + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) )
qhwet(mgs) = max( 0.0, qhwet(mgs))
+ ELSE
+ ENDIF
+
! ENDIF
qhlwet(mgs) = 0.0
IF ( lhl .gt. 1 ) THEN
- qhlwet(mgs) = &
- & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) &
- & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) )
- qhlwet(mgs) = max( 0.0, qhlwet(mgs))
+ IF ( incwet == 0 ) THEN
+ qhlwet(mgs) = &
+ & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) &
+ & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) )
+ qhlwet(mgs) = max( 0.0, qhlwet(mgs))
+
+ ELSE
+ ENDIF ! incwet
ENDIF
ELSE
qhwet(mgs) = qhdry(mgs)
qhlwet(mgs) = qhldry(mgs)
-
ENDIF
!
! qhlwet(mgs) = qhldry(mgs)
end do
+
!
! shedding rate
!
@@ -16466,7 +19451,7 @@ subroutine nssl_2mom_gs &
qhshr(mgs) = -qhdry(mgs)
qhlshr(mgs) = -qhldry(mgs)
ELSE ! new and correct
-
+ ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets
qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs)
qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs)
qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs)
@@ -16802,7 +19787,93 @@ subroutine nssl_2mom_gs &
ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter
ENDIF
- dg0(mgs) = -1.
+ IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN
+ dg0(mgs) = -1.
+ ELSE
+ IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 &
+ .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
+! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
+! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
+! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
+ x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
+ 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0
+ IF ( x > 1.e-20 ) THEN
+ arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit
+ dwr = 0.01*(exp(arg) - 1.0)
+ ELSE
+ dwr = 1.e30
+ ENDIF
+ d = dwr
+ IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN
+ sqrtrhovt = Sqrt( rhovt(mgs) )
+ fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
+ fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
+ ltemq = (tfr-163.15)/fqsat+1.5
+ qvs0 = pqs(mgs)*tabqvs(ltemq)
+ denomdp = felf(mgs) + fcw(mgs)*temcg(mgs)
+ denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs))
+
+! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs)
+ h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) )
+ h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs)
+ h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc)
+ h4 = ehr(mgs)* qx(mgs,lr)
+ ! iterate to find minimum diameter for wet growth. Start with value of dwr
+ DO n = 1,10
+ d = Max(d, 1.e-4)
+ dold = d
+ vth = axx(mgs,lh)*d**bxx(mgs,lh)
+ x2 = fventh*sqrtrhovt*Sqrt(d*vth)
+ IF ( x2 > 1.4 ) THEN
+ ah = 0.78 + 0.308*x2 ! heat ventillation
+ ELSE
+ ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
+ ENDIF
+
+ IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option
+ x1 = fventm*sqrtrhovt*Sqrt(d*vth)
+ IF ( x1 > 1.4 ) THEN
+ am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8)
+ ELSE
+ am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
+ ENDIF
+
+ d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ &
+ (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
+ Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + &
+ Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp))
+
+ ELSE
+
+ ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0
+ ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc.
+ d = 8.*ah*h1/ &
+ ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
+ Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + &
+ Max(0.001,vth - vtxbar(mgs,li,1))*h2)
+
+ ENDIF
+ IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT
+
+ ENDDO
+ ENDIF
+
+ dg0(mgs) = Min( dwmax, Max( d, dwmin ) )
+ ELSE
+ IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN
+ dg0(mgs) = dwmax
+ ELSE
+ dg0(mgs) = dg0thresh + 0.0001
+ ENDIF
+ ENDIF
+
+ IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin &
+ .and. temg(mgs) .le. tfr-2.0 ) THEN
+ ! set a secondary condition on to capture large graupel that is riming but not in wet growth
+ dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 )
+ ENDIF
+
+ ENDIF
wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh )
@@ -16837,18 +19908,6 @@ subroutine nssl_2mom_gs &
tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs)
! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
-! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN
-! hdia1 = Max(dh0, xdia(mgs,lh,3) )
-! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, &
-! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) &
-! & *exp(-hdia1/xdia(mgs,lh,1)) &
-! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) &
-! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) )
-
-! ENDIF
-
-! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) )
-! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) )
qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp )
IF ( ipconc .ge. 5 ) THEN !{
@@ -16858,8 +19917,6 @@ subroutine nssl_2mom_gs &
chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) )
r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter
-! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r )
-! chlcnh(mgs) = Min( chlcnh(mgs), r )
chlcnh(mgs) = Max( chlcnhhl(mgs), r )
ENDIF !}
@@ -16874,12 +19931,119 @@ subroutine nssl_2mom_gs &
ELSEIF ( ihlcnh == 3 ) THEN !{
+ IF ( wtest .and. &
+ ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
+ ! convert number, mass, and reflectivity for d > dw
+ IF ( ipconc == 5 ) THEN
+ ! dg0(mgs) = Min( dg0(mgs), hldia1 )
+ !dg0(mgs) = hldia1
+ ENDIF
+
+ ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) )
+
+
+ ! mass
+ tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
+ IF ( ipconc == 5 ) THEN
+ ! tmp2 = Min( 0.25, tmp2 )
+ ENDIF
+ qxd1 = qx(mgs,lh)*(tmp2)
+ qhlcnh(mgs) = dtpinv*qxd1
+ flim = 1.0
+ tmp3 = qxmxd(mgs,lh)
+ IF (qxd1 > tmp3 ) THEN
+! flim = tmp3/(qxd1)
+! qhlcnh(mgs) = flim*qhlcnh(mgs)
+ ENDIF
+
+
+
+ IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN
+
+ ! number
+ tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ IF ( ipconc == 5 ) THEN
+ ! tmp = Min( 0.2, tmp )
+ ENDIF
+ cxd1 = flim*cx(mgs,lh)*( tmp)
+ chlcnh(mgs) = dtpinv*cxd1
+ chlcnhhl(mgs) = chlcnh(mgs)
+
+ IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN
+ tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs)
+ IF ( tmp < xmas(mgs,lhl) ) THEN
+ ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average
+ dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average
+ chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 )
+ ELSE
+! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size
+ ENDIF
+ ENDIF
+
+
+ ! reflectivity
+ IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN
+ tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
+ zxd1 = flim*zx(mgs,lh)*(tmp3)
+ zhlcnh(mgs) = dtpinv*zxd1
+ ELSE
+ zxd1 = 0
+ ENDIF
+
+ ELSE
+ qhlcnh(mgs) = 0.0
+ ENDIF
+
+ vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
+ vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
+
+ ENDIF
+
+
ENDIF !}
ENDDO
ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion
+!
+! Staka and Mansell (2005) type conversion
+!
+! hldia1 is set in micro_module and namelist
+! IF ( .true. ) THEN
+
+ ! convert number, mass, and reflectivity for d > hldia1,
+ ! regardless of wet growth status, but as long as riming > 0
+ DO mgs = 1,ngscnt
+ IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN
+ ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) )
+
+ ! number
+ tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ cxd1 = cx(mgs,lh)*( tmp)
+ chlcnh(mgs) = dtpinv*cxd1
+ chlcnhhl(mgs) = chlcnh(mgs)
+
+ ! mass
+ tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
+ qxd1 = qx(mgs,lh)*(tmp2)
+ qhlcnh(mgs) = dtpinv*qxd1
+
+ ! reflectivity
+ IF ( lzh > 1 .and. lzhl > 1 ) THEN
+ tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
+ zxd1 = zx(mgs,lh)*(tmp3)
+ zhlcnh(mgs) = dtpinv*zxd1
+ ELSE
+ zxd1 = 0
+ ENDIF
+ vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
+ vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
+
+ ENDIF
+
+ ENDDO
+! ENDIF
ELSEIF ( ihlcnh == 0 ) THEN
do mgs = 1,ngscnt
@@ -17115,6 +20279,10 @@ subroutine nssl_2mom_gs &
ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs)
ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs)
+! IF ( lzh .gt. 1 ) THEN
+! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
+! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+! ENDIF
vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs)
viacrf(mgs) = qrzfac(mgs)*viacrf(mgs)
@@ -17154,7 +20322,13 @@ subroutine nssl_2mom_gs &
IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN
! qrcev(mgs) = -qrmxd(mgs)
! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs)
- crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
+ IF ( icrcev == 1 ) THEN
+ crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
+ ELSEIF ( icrcev == 2 ) THEN
+ crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1)
+ ELSE
+ crcev(mgs) = 0.0
+ ENDIF
ELSE
crcev(mgs) = 0.0
ENDIF
@@ -17166,12 +20340,6 @@ subroutine nssl_2mom_gs &
!
! evaporation/condensation of wet graupel and snow
!
- qscev(:) = 0.0
- cscev(:) = 0.0
- qhcev(:) = 0.0
- chcev(:) = 0.0
- qhlcev(:) = 0.0
- chlcev(:) = 0.0
IF ( lhwlg > 1 ) THEN
qhcevlg(:) = 0.0
chcevlg(:) = 0.0
@@ -17181,6 +20349,7 @@ subroutine nssl_2mom_gs &
chlcevlg(:) = 0.0
ENDIF
+
!
!
!
@@ -18128,6 +21297,14 @@ subroutine nssl_2mom_gs &
pqlwlghld(:) = 0.0
pqlwhli(:) = 0.0
pqlwhld(:) = 0.0
+ IF ( ipconc > 5 ) THEN
+ pzhwi(:) = 0.0
+ pzhwd(:) = 0.0
+ pzrwi(:) = 0.0
+ pzrwd(:) = 0.0
+ pzhli(:) = 0.0
+ pzhld(:) = 0.0
+ ENDIF
!
@@ -18366,7 +21543,8 @@ subroutine nssl_2mom_gs &
qrcev(mgs) = frac*qrcev(mgs)
qhlacr(mgs) = frac*qhlacr(mgs)
vhlacr(mgs) = frac*vhlacr(mgs)
-! qhcev(mgs) = frac*qhcev(mgs)
+ qhcev(mgs) = frac*qhcev(mgs)
+ qhlcev(mgs) = frac*qhlcev(mgs)
IF ( warmonly < 0.5 ) THEN
@@ -18412,6 +21590,8 @@ subroutine nssl_2mom_gs &
! STOP
ENDIF
+
+
end do
IF ( warmonly < 0.5 ) THEN
@@ -18440,7 +21620,7 @@ subroutine nssl_2mom_gs &
& -qhcns(mgs) &
& +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included
! > +il5(mgs)*(qssbv(mgs)) &
- & + (qssbv(mgs)) &
+ & + qssbv(mgs) &
& + Min(0.0, qscev(mgs)) &
& -qsmul(mgs)
@@ -18555,53 +21735,634 @@ subroutine nssl_2mom_gs &
& +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included
end do
-!
-! Hail
-!
- IF ( lhl .gt. 1 ) THEN
+!
+! Hail
+!
+ IF ( lhl .gt. 1 ) THEN
+
+ do mgs = 1,ngscnt
+ pqhli(mgs) = &
+ & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) &
+ & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) &
+ & +qhlacr(mgs)+qhlacw(mgs) &
+! & +qhlacs(mgs)+qhlaci(mgs) &
+ & + qhlcnh(mgs)
+ pqhld(mgs) = &
+ & qhlshr(mgs) &
+ & +(1-il5(mgs))*qhlmlr(mgs) &
+! > +il5(mgs)*qhlsbv(mgs) &
+ & + qhlsbv(mgs) &
+ & -qhlmul1(mgs) - qhcnhl(mgs)
+
+ end do
+
+ ENDIF ! lhl
+
+ ENDIF ! warmonly
+
+!
+! Liquid water on snow and graupel
+!
+
+ vhmlr(:) = 0.0
+ vhlmlr(:) = 0.0
+ vhfzh(:) = 0.0
+ vhlfzhl(:) = 0.0
+
+ IF ( mixedphase ) THEN
+ ELSE ! set arrays for non-mixedphase graupel
+
+! vhshdr(:) = 0.0
+ vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation
+! vhsoak(:) = 0.0
+
+! vhlshdr(:) = 0.0
+ vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation
+! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl)
+! vhlsoak(:) = 0.0
+
+ ENDIF ! mixedphase
+
+
+
+!
+! Graupel reflectivity
+!
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity'
+
+ do mgs = 1,ngscnt
+
+! zhmlr(mgs) = 0.0
+! zhshr(mgs) = 0.0
+! zhmlrr(mgs) = 0.0
+! zhshrr(mgs) = 0.0
+ zhdsv(mgs) = 0.0
+! IF ( lf < 1 ) THEN
+ IF ( ffrzh > 0.0 ) THEN
+ ziacr(mgs) = 0.0
+ ziacrf(mgs) = 0.0
+ ENDIF
+! ENDIF
+ zhcns(mgs) = 0.0
+ zhcni(mgs) = 0.0
+ zhacs(mgs) = 0.0
+ zhaci(mgs) = 0.0
+
+ ENDDO
+
+ IF ( lzh .gt. 1 ) THEN !
+ do mgs = 1,ngscnt
+
+
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+ alp = Max( alphamin, alpha(mgs,lh) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+
+ zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) )
+ zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) )
+
+ IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN
+ zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
+ ENDIF
+
+ zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+
+! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN
+ IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN
+! IF ( temg(mgs) > tfr + 2.0 ) THEN
+! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
+! IF ( zhshrr(mgs) > 0. ) THEN
+! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+! ENDIF
+! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+! zhshrr(mgs) = Max( z1, zhshrr(mgs))
+! ELSE
+! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+
+
+ IF ( temg(mgs) >= tfr ) THEN
+ ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
+ ! IF ( zhshrr(mgs) > 0.0 ) THEN
+ ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+ ! ENDIF
+ IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+ ELSE
+ z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+ ENDIF
+ zhshrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+! zhshrr(mgs) = Max( z1, zhshrr(mgs))
+ ELSE
+ zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+ ENDIF
+
+ zhshrr(mgs) = Min( 0.0, zhshrr(mgs) )
+ ENDIF
+
+ IF ( zhshr(mgs) > 0.0 ) THEN
+ write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs)
+ write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh)
+ write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs)
+ write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs)
+
+ STOP
+ ENDIF
+
+
+! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) )
+
+ qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs)
+ ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs)
+
+ zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+ alp = Max( alphahacx, alpha(mgs,lh) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .true. ) THEN ! {
+ IF ( qhacr(mgs) .gt. 0.0 ) THEN
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+
+! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+ zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+! zhacrf(mgs) = g1*zhacr
+
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh))
+
+ IF ( z > zx(mgs,lh) ) THEN
+! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv
+ ELSE
+! zhacr(mgs) = 0.0
+ ENDIF
+ ENDIF
+
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+
+! alp = Max( 1.0, alpha(mgs,lh)+1. )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
+! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( qhacw(mgs) .gt. 0.0 ) THEN
+! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+ zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
+ IF ( z > zx(mgs,lh) ) THEN
+! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
+ ENDIF
+ ENDIF
+
+ ELSE ! } { ! this is not used because of the 'true' above
+
+ IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN
+ z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
+! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+ IF ( z > zx(mgs,lh) ) THEN
+ zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
+ ENDIF
+ ENDIF
+
+ ENDIF ! }
+
+ IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN
+ zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) )
+ ENDIF
+ ENDIF
+! qsplinter(mgs)
+ IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+! alp = 3.0
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( imurain == 3 ) THEN
+ ! note that 3.6476 = (6/pi)**2
+ ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* &
+ & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
+ ELSE ! imurain == 1
+ ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* &
+ & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
+ ENDIF
+ ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) )
+! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs)
+ ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs)
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) )
+! ziacrf(mgs) = Min( ziacrf(mgs), z )
+ ENDIF
+
+
+
+ IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+! alp = 3.0
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( imurain == 3 ) THEN
+ zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
+ & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+ zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
+ ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN
+! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
+! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) )
+ zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
+ & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) )
+ zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * &
+ & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+ ENDIF
+ zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv )
+! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
+! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs)
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) )
+! zrfrzf(mgs) = Min( zrfrzf(mgs), z )
+ ! change this to be alpha=0?
+ ENDIF
+
+ IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
+
+ ENDIF
+
+ IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN
+ tmp = qx(mgs,ls)/cx(mgs,ls)
+ r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles
+ IF ( imusnow == 3 ) THEN
+ zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * &
+ & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) )
+ ELSE
+ write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow
+ STOP
+ ENDIF
+ ENDIF
+
+ IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN
+ tmp = qx(mgs,li)/cx(mgs,li)
+ r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles
+ zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * &
+ & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) )
+ ENDIF
+
+
+ pzhwi(mgs) = &
+ & +ifrzg*ffrzh*(zrfrzf(mgs) &
+ & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) &
+! : + zhcnsh(mgs) + zhcnih(mgs) &
+ & + zhacw(mgs) &
+ & + zhacr(mgs) &
+ & + zhcnhl(mgs) &
+ & + zhacs(mgs) &
+ & + zhaci(mgs) &
+ & + f2h*zhcni(mgs) + f2h*zhcns(mgs) &
+ & + Max( 0.0, zhdsv(mgs) )
+
+ pzhwd(mgs) = 0.0 &
+ & + (1-il5(mgs))*zhmlr(mgs) &
+ & + zhshr(mgs) &
+ & + Min( 0.0, zhdsv(mgs) ) &
+ & - il5(mgs)*zhlcnh(mgs)
+
+
+ IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN
+! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real
+! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh)
+! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh)
+! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh)
+ ENDIF
+
+
+! IF ( zhcnhl(mgs) < 0.0 ) THEN
+! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs)
+! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp
+! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
+!
+!! STOP
+! ENDIF
+ end do
+
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity'
+
+ ENDIF
+
+!
+! Hail reflectivity
+!
+
+ do mgs = 1,ngscnt
+
+ zhldsv(mgs) = 0.0
+ zhlacr(mgs) = 0.0
+ zhlacw(mgs) = 0.0
+
+ ENDDO
+
+ IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources
+
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity'
+
+ do mgs = 1,ngscnt
+
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ alp = Max( alphamin, alpha(mgs,lhl) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN
+ zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) )
+ ENDIF
+
+ zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
+ IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN
+ IF ( temg(mgs) >= tfr ) THEN
+ ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) )
+ ! IF ( zhlshrr(mgs) > 0.0 ) THEN
+ ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
+ ! ENDIF
+ IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
+ ELSE
+ z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
+ ENDIF
+ zhlshrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
+! zhlshrr(mgs) = Max( z1, zhlshrr(mgs))
+ ELSE
+ zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
+ ENDIF
+
+ zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) )
+ ENDIF
+
+ IF ( zhlshr(mgs) > 0.0 ) THEN
+ write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs)
+ write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl)
+ write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs)
+ write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)
+
+ STOP
+ ENDIF
+! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) )
+
+! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) )
+
+ qtmp = qhldpv(mgs) + qhlcev(mgs)
+ ctmp = chldpv(mgs) + chlcev(mgs)
+
+ zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+ alp = Max( alphahacx, alpha(mgs,lhl) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .true. ) THEN ! {
+ IF ( qhlacr(mgs) .gt. 0.0 ) THEN
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl))
+ zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) )
+! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) )
+
+! IF ( z > zx(mgs,lhl) ) THEN
+! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv
+! ELSE
+! zhlacr(mgs) = 0.0
+! ENDIF
+ ENDIF
+
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+
+ IF ( qhlacw(mgs) .gt. 0.0 ) THEN
+ alp = Max( 3.0, alpha(mgs,lhl)+1. )
+ g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
+! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
+ zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) )
+
+! IF ( z > zx(mgs,lhl) ) THEN
+! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
+! ENDIF
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ ENDIF
+
+ ELSE ! } .false. {
+
+ IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN
+ z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
+! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
+ IF ( z > zx(mgs,lhl) ) THEN
+ zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
+ ENDIF
+ ENDIF
+
+ ENDIF ! }
+
+ ENDIF
+! qsplinter(mgs)
+
+ IF ( lzhl > 1 ) THEN
+ pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) &
+ & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) &
+ & + il5(mgs)*zhlcnh(mgs) &
+ & + zhlacw(mgs) &
+ & + zhlacr(mgs) &
+! : + zhlacs(mgs) &
+ & + Max( 0.0, zhldsv(mgs) )
+
+ pzhld(mgs) = 0.0 &
+ & + (1-il5(mgs))*zhlmlr(mgs) &
+ & + zhlshr(mgs) &
+ & - zhcnhl(mgs) &
+ & + Min( 0.0, zhldsv(mgs) )
+
+
+ IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN
+ write(iunit,*) 'Problem with pzhli!'
+ write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs)
+ ENDIF
+
+ IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN
+ write(iunit,*) 'Problem with pzhld!'
+ write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs)
+ ENDIF
+
+ ENDIF ! lzhl > 1
+
+ end do
+
+ ENDIF
+
+!
+! rain reflectivity
+!
+ if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11'
+
+ IF ( lzr .gt. 1 ) THEN !
+
+ DO mgs = 1,ngscnt
+
+ zracw(mgs) = 0.0
+ zracr(mgs) = 0.0
+ zrcev(mgs) = 0.0
+ zrach(mgs) = 0.0
+ zrachl(mgs) = 0.0
+ zsshr(mgs) = 0.0
+ zsshrr(mgs) = 0.0
+! zsmlr(mgs) = 0.0
+ zsmlrr(mgs) = 0.0
+
+ IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. &
+ csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{
+ tmp = qx(mgs,ls)/cx(mgs,ls)
+ g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2)
+ IF ( .not. mixedphase ) THEN
+! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
+! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) )
+
+ IF ( csmlrr(mgs) /= 0.0 ) THEN
+ z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) )
+ zsmlrr(mgs) = z1
+ ENDIF
+ ENDIF
+
+! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
+! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) )
+
+ IF ( csshrr(mgs) /= 0.0 ) THEN
+ z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) )
+ zsshrr(mgs) = z1
+ ENDIF
+
+ ENDIF !}
+
+ IF ( .not. mixedphase ) THEN !{
+ IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * &
+! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) )
+
+! IF ( zhmlrr(mgs) >= 0. ) THEN
+! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs)
+! ENDIF
+ IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel
+ z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+ ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha)
+ z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+ ENDIF
+ zhmlrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+! zhmlrr(mgs) = Max( z1, zhmlrr(mgs))
+ ENDIF !}
+
+
+! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs)
+
+ IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * &
+! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) )
+
+! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation
+! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs)
+! ENDIF
+
+ IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+ ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha)
+ z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+ ENDIF
+ zhlmlrr(mgs) = z1
+
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs))
+! zhlmlr(mgs) =
+! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs)
+ ENDIF
+
+ ENDIF ! }
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN
+
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+ g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+
+
+ IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
+ zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) )
+ ENDIF
+
+ IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
+ zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) )
+ ENDIF
+
+ qtmp = qrcev(mgs)
+ ctmp = crcev(mgs)
+
+! IF ( .false. .or. iferwisventr == 2 ) THEN
+! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) )
+! ELSE
+ zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+
+ IF ( iferwisventr == 2 ) THEN
+ vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs))
+ zrcev(mgs) = Max( zrcev(mgs), vent1 )
+ ENDIF
+! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN
+! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr)
+! ENDIF
+
- do mgs = 1,ngscnt
- pqhli(mgs) = &
- & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) &
- & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) &
- & +qhlacr(mgs)+qhlacw(mgs) &
-! & +qhlacs(mgs)+qhlaci(mgs) &
- & + qhlcnh(mgs)
- pqhld(mgs) = &
- & qhlshr(mgs) &
- & +(1-il5(mgs))*qhlmlr(mgs) &
-! > +il5(mgs)*qhlsbv(mgs) &
- & + qhlsbv(mgs) &
- & -qhlmul1(mgs) - qhcnhl(mgs)
+! ENDIF
+ zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) )
- end do
+ IF ( qhacr(mgs) > 0.0 ) THEN
+ zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+ zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) )
+
+ ENDIF
- ENDIF ! lhl
+ IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN
+ zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) )
+ zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) )
+ ENDIF
- ENDIF ! warmonly
-!
-! Liquid water on snow and graupel
-!
+
+ ENDIF
- vhmlr(:) = 0.0
- vhlmlr(:) = 0.0
- vhfzh(:) = 0.0
- vhlfzhl(:) = 0.0
+ pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) &
+ & + Max( 0.,zrcev(mgs) ) &
+ & - (1-il5(mgs))*zsmlrr(mgs) &
+ & - zsshrr(mgs) &
+ & - (1-il5(mgs))*zhmlrr(mgs) &
+ & - zhshrr(mgs) &
+ & - (1-il5(mgs))*zhlmlrr(mgs) &
+ & - zhlshrr(mgs)
- IF ( mixedphase ) THEN
- ELSE ! set arrays for non-mixedphase graupel
-
-! vhshdr(:) = 0.0
- vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation
-! vhsoak(:) = 0.0
-! vhlshdr(:) = 0.0
- vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation
-! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl)
-! vhlsoak(:) = 0.0
+ pzrwd(mgs) = 0.0 &
+ & + Min(0.,zrcev(mgs) ) &
+ & - zrach(mgs) &
+ & - zrachl(mgs) &
+ & - zrfrz(mgs) &
+ & - il5(mgs)*(ziacr(mgs) )
- ENDIF ! mixedphase
+
+ IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 &
+ .and. qx(mgs,lr) > qxmin(lr) ) THEN
+ pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs)
+ ENDIF
+
+ ENDDO
+
+ ENDIF
@@ -18678,6 +22439,33 @@ subroutine nssl_2mom_gs &
! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr)
! ENDIF
+ IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN
+! Calculate change in reflectivity due to density changes
+
+ xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ &
+ & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) )
+
+ IF ( mixedphase ) THEN
+ IF ( qxw(mgs,lh) .gt. 0.0 ) THEN
+ dnmx = xdnmx(lr)
+ ELSE
+ dnmx = xdnmx(lh)
+ ENDIF
+ ELSE
+ dnmx = xdnmx(lh)
+ ENDIF
+
+ xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) )
+
+ drhodt = (xdn_new - xdn(mgs,lh))*dtpinv
+
+ zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt
+
+ pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs))
+ pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs))
+
+
+ ENDIF
IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN
write(iunit,*)
@@ -18760,6 +22548,32 @@ subroutine nssl_2mom_gs &
& + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) &
& + vhlshdr(mgs) - vhlsoak(mgs)
+ IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN
+! Calculate change in reflectivity due to density changes
+
+ xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ &
+ & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) )
+
+ IF ( mixedphase ) THEN
+ IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN
+ dnmx = xdnmx(lr)
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+ xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) )
+
+ drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv
+
+ zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt
+
+ pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs))
+ pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs))
+
+
+ ENDIF
ENDDO
@@ -18989,7 +22803,7 @@ subroutine nssl_2mom_gs &
write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs)
write(iunit,*) -qhcns(mgs)
write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs)
- write(iunit,*) (qssbv(mgs))
+ write(iunit,*) qssbv(mgs)
write(iunit,*) Min(0.0, qscev(mgs))
write(iunit,*) -qsmul(mgs)
!
@@ -19061,33 +22875,37 @@ subroutine nssl_2mom_gs &
IF ( warmonly < 0.5 ) THEN
pfrz(mgs) = &
& (1-il5(mgs))* &
- & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) &
- & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) &
+ & (qhmlr(mgs)+ &
+ & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) &
& +il5(mgs)*(1-imixedphase)*( &
& qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) &
& +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) &
& +qsshr(mgs) &
& +qhshr(mgs) &
- & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) &
+ & +qhlshr(mgs) &
+ & +qrfrz(mgs)+qiacr(mgs) &
& ) &
& +il5(mgs)*(qwfrz(mgs) &
& +qwctfz(mgs)+qiihr(mgs) &
& +qiacw(mgs))
pmlt(mgs) = &
& (1-il5(mgs))* &
- & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs))
+ & (qhmlr(mgs)+qsmlr(mgs)+ &
+ & qhlmlr(mgs)) !+qhmlh(mgs))
! NOTE: psub is sum of sublimation and deposition
psub(mgs) = &
& il5(mgs)*( &
& + qsdpv(mgs) + qhdpv(mgs) &
& + qhldpv(mgs) &
& + qidpv(mgs) + qisbv(mgs) ) &
- & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) &
+ & + qssbv(mgs) + qhsbv(mgs) &
+ & + qhlsbv(mgs) &
& +il5(mgs)*(qiint(mgs))
pvap(mgs) = &
- & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs)
+ & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs)
pevap(mgs) = &
- & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs))
+ & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) &
+ + Min(0.0,qfcev(mgs))
! NOTE: pdep is the deposition part only
pdep(mgs) = &
& il5(mgs)*( &
@@ -19115,7 +22933,7 @@ subroutine nssl_2mom_gs &
& + qidpv(mgs) + qisbv(mgs) ) &
& +il5(mgs)*(qiint(mgs))
pvap(mgs) = &
- & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs)
+ & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs)
ELSE
pfrz(mgs) = 0.0
psub(mgs) = 0.0
@@ -19143,6 +22961,8 @@ subroutine nssl_2mom_gs &
!
!
do mgs = 1,ngscnt
+
+
qwvp(mgs) = qwvp(mgs) + &
& dtp*(pqwvi(mgs)+pqwvd(mgs))
qx(mgs,lc) = qx(mgs,lc) + &
@@ -19155,6 +22975,7 @@ subroutine nssl_2mom_gs &
& dtp*(pqswi(mgs)+pqswd(mgs))
qx(mgs,lh) = qx(mgs,lh) + &
& dtp*(pqhwi(mgs)+pqhwd(mgs))
+
IF ( lhl .gt. 1 ) THEN
qx(mgs,lhl) = qx(mgs,lhl) + &
& dtp*(pqhli(mgs)+pqhld(mgs))
@@ -19224,12 +23045,32 @@ subroutine nssl_2mom_gs &
+ ENDIF
+ ENDIF
+ IF ( ipconc .ge. 6 ) THEN
+ IF ( lzr .gt. 1 ) THEN
+ zx(mgs,lr) = zx(mgs,lr) + &
+ & dtp*(pzrwi(mgs)+pzrwd(mgs))
+ ENDIF
+ IF ( lzs .gt. 1 ) THEN
+ zx(mgs,ls) = zx(mgs,ls) + &
+ & dtp*(pzswi(mgs)+pzswd(mgs))
+ ENDIF
+ IF ( lzh .gt. 1 ) THEN
+ zx(mgs,lh) = zx(mgs,lh) + &
+ & dtp*(pzhwi(mgs)+pzhwd(mgs))
+ ENDIF
+ IF ( lzhl .gt. 1 ) THEN
+ zx(mgs,lhl) = zx(mgs,lhl) + &
+ & dtp*(pzhli(mgs)+pzhld(mgs))
+! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
+! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
+! ENDIF
ENDIF
ENDIF
end do
end if
-
IF ( has_wetscav ) THEN
DO mgs = 1,ngscnt
evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs))
@@ -19471,41 +23312,9 @@ subroutine nssl_2mom_gs &
tqvcon = temg(mgs)-cbw
ltemq = (temg(mgs)-163.15)/fqsat+1.5
ltemq = Min( nqsat, Max(1,ltemq) )
-! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN
-! C$PAR CRITICAL SECTION
-! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs),
-! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs),
-! : ltemq,igs(mgs),jy,kgs(mgs)
-! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt),
-! : ab(igs(mgs),jy,kgs(mgs),lt),
-! : t0(igs(mgs),jy,kgs(mgs))
-! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs)
-! STOP
-! C$PAR END CRITICAL SECTION
-! END IF
+
qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
qis(mgs) = pqs(mgs)*tabqis(ltemq)
-! qss(kz) = qvs(kz)
-! if ( temg(kz) .lt. tfr ) then
-! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = qis(kz)
-! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
-! > (qcw(kz) + qci(kz))
-! qss(kz) = qis(kz)
-! end if
-! dont get enough condensation with qcw .le./.gt. qxmin(lc)
-! if ( temg(mgs) .lt. tfr ) then
-! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )
-! > qss(mgs) = qvs(mgs)
-! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
-! > qss(mgs) = qis(mgs)
-! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
-! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /
-! > (qx(mgs,lc) + qitmp(mgs))
-! else
-! qss(mgs) = qvs(mgs)
-! end if
qss(mgs) = qvs(mgs)
if ( temg(mgs) .lt. tfr ) then
if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) &
@@ -19744,7 +23553,6 @@ subroutine nssl_2mom_gs &
-
if (ndebug .gt. 0 ) write(0,*) 'gs 11'
do mgs = 1,ngscnt
@@ -19775,6 +23583,29 @@ subroutine nssl_2mom_gs &
ENDIF
+
+
+
+!
+! 6th moments
+!
+
+ IF ( ipconc .ge. 6 ) THEN
+ DO il = lr,lhab
+ IF ( lz(il) .gt. 1 ) THEN
+ IF ( lf > 1 .and. il == lf ) THEN
+ lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il))
+ lfsave(mgs,4) = zx(mgs,il)
+ ENDIF
+
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + &
+ & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
+ zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il))
+
+ ENDIF
+ ENDDO
+
+ ENDIF
!
end do
!
@@ -19839,7 +23670,455 @@ subroutine nssl_2mom_gs &
ENDIF !}
ENDDO ! mgs
+ ELSE ! } { is three-moment, so have to adjust Z if size is too large
+ IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN
+
+! rdmx =
+! rdmn =
+
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
+ IF ( zx(mgs,lr) <= zxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ qx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+ ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN
+ tmp = cx(mgs,il)
+! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.)
+! STOP
+ IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE ! simple cutoff
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+
+
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r')
+
+
+ ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL
+
+
+
+ DO mgs = 1,ngscnt
+
+ IF ( lf > 1 .and. il == lf ) THEN
+ lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il))
+ lfsave(mgs,6) = cx(mgs,il)
+ ENDIF
+
+ IF ( il == lhl .and. lnhlf > 1 ) THEN
+ IF ( cx(mgs,lhl) > cxmin ) THEN
+ frac = chxf(mgs,lhl)/cx(mgs,lhl)
+ ELSE
+ frac = 0.0
+ ENDIF
+ ENDIF
+
+ IF ( il == lh .and. lnhf > 1 ) THEN
+ IF ( cx(mgs,lh) > cxmin ) THEN
+ frach = chxf(mgs,lh)/cx(mgs,lh)
+ ELSE
+ frach = 0.0
+ ENDIF
+ ENDIF
+
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il)
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ELSE
+ IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3
+ zx(mgs,il) = 0.0
+ ENDIF
+ ENDIF !}
+
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
+ & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
+ zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+
+! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
+
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
+
+ ELSE
+ ! have all valid moments, so find shape parameter
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN !{
+
+! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
+ DO i = 1,10
+! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{
+ tmp = cx(mgs,il)
+
+
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF !}
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
+ .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+
+ wtest = .false.
+ IF ( irescalerainopt == 0 ) THEN
+ wtest = .false.
+ ELSEIF ( irescalerainopt == 1 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc)
+ ELSEIF ( irescalerainopt == 2 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ELSEIF ( irescalerainopt == 3 ) THEN
+ wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ENDIF
+
+ IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN
+ ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
+ ! drops (i.e., favor preserving Z when alpha tries to go negative)
+ chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1
+ cx(mgs,il) = chw
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
+ ELSE
+ ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+
+! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! z = z1*(6./(pi*xdn(mgs,il)))**2
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+
+ ENDIF !}
+
+
+ ENDIF !}
+
+
+ ENDIF ! !}
+
+
+ ENDIF !}
+
+ IF ( lzr > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) ))
+ ENDIF
+ IF ( lzh > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) ))
+ ENDIF
+ IF ( lzhl > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) ))
+ ENDIF
+
+ IF ( il == lhl .and. lnhlf > 1 ) THEN
+ ! update chxf in case cx has changed
+ chxf(mgs,lhl) = frac*cx(mgs,lhl)
+ ENDIF
+ IF ( il == lh .and. lnhf > 1 ) THEN
+ ! update chxf in case cx has changed
+ chxf(mgs,lh) = frach*cx(mgs,lh)
+ ENDIF
+
+
+! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN
+! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6)
+! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4)
+! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs)
+!
+! ENDIF
+
+ ENDDO ! mgs
+
+! CALL cld_cpu('Z-DELABK')
+
+
+! CALL cld_cpu('Z-DELABK')
+
+
+
+
+ ENDIF ! } }
+
ENDIF ! }}
ENDIF ! }
diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90
index 271db11d0..44e552160 100644
--- a/physics/module_mp_thompson.F90
+++ b/physics/module_mp_thompson.F90
@@ -993,6 +993,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
rainprod, evapprod, &
#endif
refl_10cm, diagflag, do_radar_ref, &
+ max_hail_diam_sfc, &
vt_dbz_wt, first_time_step, &
re_cloud, re_ice, re_snow, &
has_reqc, has_reqi, has_reqs, &
@@ -1062,6 +1063,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
GRAUPELNC, GRAUPELNCV
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
refl_10cm
+ REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
+ max_hail_diam_sfc
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: &
vt_dbz_wt
LOGICAL, INTENT(IN) :: first_time_step
@@ -1416,6 +1419,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
qcten1(k) = 0.
endif initialize_extended_diagnostics
enddo
+ lsml = lsm(i,j)
if (is_aerosol_aware .or. merra2_aerosol_aware) then
do k = kts, kte
nc1d(k) = nc(i,k,j)
@@ -1423,7 +1427,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
nifa1d(k) = nifa(i,k,j)
enddo
else
- lsml = lsm(i,j)
do k = kts, kte
if(lsml == 1) then
nc1d(k) = Nt_c_l/rho(k)
@@ -1679,6 +1682,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
(nsteps>1 .and. istep==nsteps) .or. &
(nsteps==1 .and. ndt==1)) THEN
+ max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d)
+
!> - Call calc_refl10cm()
diagflag_present: IF ( PRESENT (diagflag) ) THEN
@@ -2464,17 +2469,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
!+---+-----------------------------------------------------------------+
!> - Calculate y-intercept, slope values for graupel.
!+---+-----------------------------------------------------------------+
- do k = kte, kts, -1
- ygra1 = alog10(max(1.E-9, rg(k)))
- zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
- N0_exp = 10.**(zans1)
- N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max)))
- lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
- lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
- ilamg(k) = 1./lamg
- N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
- enddo
-
+ call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g)
endif
!+---+-----------------------------------------------------------------+
@@ -3541,17 +3536,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
!+---+-----------------------------------------------------------------+
!> - Calculate y-intercept, slope values for graupel.
!+---+-----------------------------------------------------------------+
- do k = kte, kts, -1
- ygra1 = alog10(max(1.E-9, rg(k)))
- zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
- N0_exp = 10.**(zans1)
- N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max)))
- lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
- lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
- ilamg(k) = 1./lamg
- N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
- enddo
-
+ call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g)
endif
!+---+-----------------------------------------------------------------+
@@ -3589,7 +3574,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
!+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION
if (clap .gt. eps) then
if (is_aerosol_aware .or. merra2_aerosol_aware) then
- xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k)))
+ xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml))
else
if(lsml == 1) then
xnc = Nt_c_l
@@ -5366,14 +5351,15 @@ end subroutine table_ccnAct
! TO_DO ITEM: For radiation cooling producing fog, in which case the
!.. updraft velocity could easily be negative, we could use the temp
!.. and its tendency to diagnose a pretend postive updraft velocity.
- real function activ_ncloud(Tt, Ww, NCCN)
+ real function activ_ncloud(Tt, Ww, NCCN, lsm_in)
implicit none
REAL, INTENT(IN):: Tt, Ww, NCCN
+ INTEGER, INTENT(IN):: lsm_in
REAL:: n_local, w_local
INTEGER:: i, j, k, l, m, n
REAL:: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction
-
+ REAL:: lower_lim_nuc_frac
! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc
! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw
@@ -5420,6 +5406,14 @@ real function activ_ncloud(Tt, Ww, NCCN)
l = 3
m = 2
+ if (lsm_in .eq. 1) then ! land
+ lower_lim_nuc_frac = 0.
+ else if (lsm_in .eq. 0) then ! water
+ lower_lim_nuc_frac = 0.15
+ else
+ lower_lim_nuc_frac = 0.15 ! catch-all for anything else
+ endif
+
A = tnccn_act(i-1,j-1,k,l,m)
B = tnccn_act(i,j-1,k,l,m)
C = tnccn_act(i,j,k,l,m)
@@ -5434,7 +5428,8 @@ real function activ_ncloud(Tt, Ww, NCCN)
! u = (w_local-ta_Ww(j-1))/(ta_Ww(j)-ta_Ww(j-1))
fraction = (1.0-t)*(1.0-u)*A + t*(1.0-u)*B + t*u*C + (1.0-t)*u*D
-
+ fraction = MAX(fraction, lower_lim_nuc_frac)
+
! if (NCCN*fraction .gt. 0.75*Nt_c_max) then
! write(*,*) ' DEBUG-GT ', n_local, w_local, Tt, i, j, k
! endif
@@ -6085,16 +6080,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
!+---+-----------------------------------------------------------------+
if (ANY(L_qg .eqv. .true.)) then
- do k = kte, kts, -1
- ygra1 = alog10(max(1.E-9, rg(k)))
- zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
- N0_exp = 10.**(zans1)
- N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max)))
- lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
- lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
- ilamg(k) = 1./lamg
- N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
- enddo
+ call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g)
endif
!+---+-----------------------------------------------------------------+
@@ -6471,6 +6457,88 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1)
END SUBROUTINE semi_lagrange_sedim
+!>\ingroup aathompson
+!! @brief Calculates graupel size distribution parameters
+!!
+!! Calculates graupel intercept and slope parameters for
+!! for a vertical column
+!!
+!! @param[in] kts integer start index for vertical column
+!! @param[in] kte integer end index for vertical column
+!! @param[in] rand1 real random number for stochastic physics
+!! @param[in] rg real array, size(kts:kte) for graupel mass concentration [kg m^3]
+!! @param[out] ilamg double array, size(kts:kte) for inverse graupel slope parameter [m]
+!! @param[out] N0_g double array, size(kts:kte) for graupel intercept paramter [m-4]
+subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g)
+
+ implicit none
+
+ integer, intent(in) :: kts, kte
+ real, intent(in) :: rand1
+ real, intent(in) :: rg(:)
+ double precision, intent(out) :: ilamg(:), N0_g(:)
+
+ integer :: k
+ real :: ygra1, zans1
+ double precision :: N0_exp, lam_exp, lamg
+
+ do k = kte, kts, -1
+ ygra1 = alog10(max(1.e-9, rg(k)))
+ zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
+ N0_exp = 10.**(zans1)
+ N0_exp = max(dble(gonv_min), min(N0_exp, dble(gonv_max)))
+ lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
+ lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
+ ilamg(k) = 1./lamg
+ N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
+ enddo
+
+end subroutine graupel_psd_parameters
+
+!>\ingroup aathompson
+!! @brief Calculates graupel/hail maximum diameter
+!!
+!! Calculates graupel/hail maximum diameter (currently the 99th percentile of mass distribtuion)
+!! for a vertical column
+!!
+!! @param[in] kts integer start index for vertical column
+!! @param[in] kte integer end index for vertical column
+!! @param[in] qg real array, size(kts:kte) for graupel mass mixing ratio [kg kg^-1]
+!! @param[in] temperature double array, size(kts:kte) temperature [K]
+!! @param[in] pressure double array, size(kts:kte) pressure [Pa]
+!! @param[in] qv real array, size(kts:kte) water vapor mixing ratio [kg kg^-1]
+!! @param[out] max_hail_diam real maximum hail diameter [m]
+function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam)
+
+ implicit none
+
+ integer, intent(in) :: kts, kte
+ real, intent(in) :: qg(:), temperature(:), pressure(:), qv(:)
+ real :: max_hail_diam
+
+ integer :: k
+ real :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte)
+ double precision :: ilamg(kts:kte), N0_g(kts:kte)
+ real, parameter :: random_number = 0.
+
+ max_hail_column = 0.
+ rg = 0.
+ do k = kts, kte
+ rho(k) = 0.622*pressure(k)/(R*temperature(k)*(max(1.e-10, qv(k))+0.622))
+ if (qg(k) .gt. R1) then
+ rg(k) = qg(k)*rho(k)
+ else
+ rg(k) = R1
+ endif
+ enddo
+
+ call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, N0_g)
+
+ where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg
+ max_hail_diam = max_hail_column(kts)
+
+end function hail_mass_99th_percentile
+
!+---+-----------------------------------------------------------------+
!+---+-----------------------------------------------------------------+
END MODULE module_mp_thompson
diff --git a/physics/module_nst_model.f90 b/physics/module_nst_model.f90
index 980035fe6..74c75924b 100644
--- a/physics/module_nst_model.f90
+++ b/physics/module_nst_model.f90
@@ -1,5 +1,5 @@
!>\file module_nst_model.f90
-!! This file contains the diurnal thermocline layer model (DTM) of
+!! This file contains the diurnal thermocline layer model (DTM) of
!! the GFS NSST scheme.
!>\defgroup dtm_module GFS NSST Diurnal Thermocline Model
@@ -10,962 +10,967 @@
!> This module contains the diurnal thermocline layer model (DTM) of
!! the GFS NSST scheme.
module nst_module
+ !
+ ! the module of diurnal thermocline layer model
+ !
+ use machine , only : kind_phys
+ use module_nst_parameters , only : z_w_max, z_w_min, z_w_ini, eps_z_w, eps_conv
+ use module_nst_parameters , only : eps_sfs, niter_z_w, niter_conv, niter_sfs, ri_c
+ use module_nst_parameters , only : ri_g, omg_m, omg_sh, kw => tc_w, visw, t0k, cp_w
+ use module_nst_parameters , only : z_c_max, z_c_ini, ustar_a_min, delz, exp_const
+ use module_nst_parameters , only : rad2deg, const_rot, tw_max, sst_max
+ use module_nst_parameters , only : zero, one
+ use module_nst_water_prop , only : sw_rad_skin, sw_ps_9b, sw_ps_9b_aw
+
+ implicit none
+
+ private
+
+ public :: dtm_1p, dtm_1p_fca, dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, convdepth
+ public :: cal_w, cal_ttop, cool_skin, dtl_reset
+
+contains
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine contains the module of diurnal thermocline layer model.
+ subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, &
+ alpha,beta,alon,sinlat,soltim,grav,le,d_conv, &
+ xt,xs,xu,xv,xz,xzts,xtts)
+
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,&
+ hl_ts,rho,alpha,beta,alon,sinlat,soltim,&
+ grav,le,d_conv
+ real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts
+ ! local variables
+
+ !
+ ! input variables
+ !
+ ! timestep: integration time step in seconds
+ ! rich : critical ri (flow dependent)
+ ! tox : x wind stress (n*m^-2 or kg/m/s^2)
+ ! toy : y wind stress (n*m^-2 or kg/m/s^2)
+ ! i0 : solar radiation flux at the surface (wm^-2)
+ ! q : non-solar heat flux at the surface (wm^-2)
+ ! sss : salinity (ppt)
+ ! sep : sr(e-p) (ppt*m/s)
+ ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes
+ ! hl_ts : d(hl)/d(ts)
+ ! rho : sea water density (kg*m^-3)
+ ! alpha : thermal expansion coefficient (1/k)
+ ! beta : saline contraction coefficient (1/ppt)
+ ! sinlat : sine (lat)
+ ! grav : gravity accelleration
+ ! le : le=(2.501-.00237*tsea)*1e6
+ ! d-conv : fcl thickness
+ !
+ ! inout variables
+ !
+ ! xt : dtl heat content (m*k)
+ ! xs : dtl salinity content (m*ppt)
+ ! xu : dtl x current content (m*m/s)
+ ! xv : dtl y current content (m*m/s)
+ ! xz : dtl thickness (m)
+ ! xzts : d(xz)/d(ts) (m/k )
+ ! xtts : d(xt)/d(ts) (m)
+ !
+ ! logical lprnt
+
+ ! if (lprnt) print *,' first xt=',xt
+ if ( xt <= zero ) then ! dtl doesn't exist yet
+ call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, &
+ beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts)
+ elseif ( xt > zero ) then ! dtl already exists
+ !
+ ! forward the system one time step
+ !
+ call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, &
+ beta,alon,sinlat,soltim,grav,le,d_conv, &
+ xt,xs,xu,xv,xz,xzts,xtts)
+ endif ! if ( xt == 0 ) then
+
+ end subroutine dtm_1p
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine integrates one time step with modified Euler method.
+ subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, &
+ beta,alon,sinlat,soltim,grav,le,d_conv, &
+ xt,xs,xu,xv,xz,xzts,xtts)
+
+ !
+ ! subroutine eulerm: integrate one time step with modified euler method
+ !
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, &
+ hl_ts,rho,alpha,beta,alon,sinlat,soltim, &
+ grav,le,d_conv
+ real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts
+ ! local variables
+ real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0
+ real(kind=kind_phys) :: fw,aw,q_warm
+ real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1
+ real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2
+ real(kind=kind_phys) :: dzw,drho,fc
+ real(kind=kind_phys) :: alat,speed
+ ! logical lprnt
+
+ !
+ ! input variables
+ !
+ ! timestep: integration time step in seconds
+ ! rich : critial ri (flow/mass dependent)
+ ! tox : x wind stress (n*m^-2 or kg/m/s^2)
+ ! toy : y wind stress (n*m^-2 or kg/m/s^2)
+ ! i0 : solar radiation flux at the surface (wm^-2)
+ ! q : non-solar heat flux at the surface (wm^-2)
+ ! sss : salinity (ppt)
+ ! sep : sr(e-p) (ppt*m/s)
+ ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes
+ ! hl_ts : d(hl)/d(ts)
+ ! rho : sea water density (kg*m^-3)
+ ! alpha : thermal expansion coefficient (1/k)
+ ! beta : saline contraction coefficient (1/ppt)
+ ! alon : longitude (deg)
+ ! sinlat : sine (lat)
+ ! soltim : solar time
+ ! grav : gravity accelleration
+ ! le : le=(2.501-.00237*tsea)*1e6
+ ! d_conv : fcl thickness (m)
+ !
+ ! inout variables
+ !
+ ! xt : dtl heat content (m*k)
+ ! xs : dtl salinity content (m*ppt)
+ ! xu : dtl x current content (m*m/s)
+ ! xv : dtl y current content (m*m/s)
+ ! xz : dtl thickness (m)
+ ! xzts : d(xz)/d(ts) (m/k )
+ ! xtts : d(xt)/d(ts) (m)
+
+ xt0 = xt
+ xs0 = xs
+ xu0 = xu
+ xv0 = xv
+ xz0 = xz
+ xtts0 = xtts
+ xzts0 = xzts
+ speed = max(1.0e-8, xu0*xu0+xv0*xv0)
+
+ alat = asin(sinlat)*rad2deg
+
+ fc = const_rot*sinlat
+
+ call sw_ps_9b(xz0,fw)
+
+ q_warm = fw*i0-q !total heat abs in warm layer
+
+ call sw_ps_9b_aw(xz0,aw)
+
+ drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep
+
+ ! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) &
+ ! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0))
+ dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) &
+ + xz0*xz0*drho*grav / (4.0*rich*speed))
+
+ xt1 = xt0 + timestep*q_warm/(rho*cp_w)
+ xs1 = xs0 + timestep*sep
+ xu1 = xu0 + timestep*(fc*xv0+tox/rho)
+ xv1 = xv0 + timestep*(-fc*xu0+toy/rho)
+ xz1 = xz0 + timestep*dzw
+
+ ! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, &
+ ! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich
+
+ if ( xt1 <= zero .or. xz1 <= zero .or. xz1 > z_w_max ) then
+ call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
+ return
+ endif
-!
-! the module of diurnal thermocline layer model
-!
- use machine , only : kind_phys
- use module_nst_parameters, only: z_w_max,z_w_min,z_w_ini,eps_z_w,eps_conv, &
- eps_sfs,niter_z_w,niter_conv,niter_sfs,ri_c, &
- ri_g,omg_m,omg_sh, kw => tc_w,visw,t0k,cp_w, &
- z_c_max,z_c_ini,ustar_a_min,delz,exp_const, &
- rad2deg,const_rot,tw_max,sst_max
- use module_nst_water_prop, only: sw_rad_skin,sw_ps_9b,sw_ps_9b_aw
- implicit none
+ ! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa)
- contains
+ xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * &
+ ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho) &
+ +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) &
+ *grav*xz0*xz0/(4.0*rich) )*xzts0 ))
+ xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w)
-!>\ingroup gfs_nst_main_mod
-!! This subroutine contains the module of diurnal thermocline layer model.
- subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, &
- alpha,beta,alon,sinlat,soltim,grav,le,d_conv, &
- xt,xs,xu,xv,xz,xzts,xtts)
+ ! if ( 2.0*xt1/xz1 > 0.001 ) then
+ ! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,&
+ ! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te
+ ! endif
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,&
- hl_ts,rho,alpha,beta,alon,sinlat,soltim,&
- grav,le,d_conv
- real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts
-! local variables
-
-!
-! input variables
-!
-! timestep: integration time step in seconds
-! rich : critical ri (flow dependent)
-! tox : x wind stress (n*m^-2 or kg/m/s^2)
-! toy : y wind stress (n*m^-2 or kg/m/s^2)
-! i0 : solar radiation flux at the surface (wm^-2)
-! q : non-solar heat flux at the surface (wm^-2)
-! sss : salinity (ppt)
-! sep : sr(e-p) (ppt*m/s)
-! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes
-! hl_ts : d(hl)/d(ts)
-! rho : sea water density (kg*m^-3)
-! alpha : thermal expansion coefficient (1/k)
-! beta : saline contraction coefficient (1/ppt)
-! sinlat : sine (lat)
-! grav : gravity accelleration
-! le : le=(2.501-.00237*tsea)*1e6
-! d-conv : fcl thickness
-!
-! inout variables
-!
-! xt : dtl heat content (m*k)
-! xs : dtl salinity content (m*ppt)
-! xu : dtl x current content (m*m/s)
-! xv : dtl y current content (m*m/s)
-! xz : dtl thickness (m)
-! xzts : d(xz)/d(ts) (m/k )
-! xtts : d(xt)/d(ts) (m)
-!
-! logical lprnt
-
-! if (lprnt) print *,' first xt=',xt
- if ( xt <= 0.0 ) then ! dtl doesn't exist yet
- call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,&
- beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts)
- elseif ( xt > 0.0 ) then ! dtl already exists
-!
-! forward the system one time step
-!
- call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, &
- beta,alon,sinlat,soltim,grav,le,d_conv, &
- xt,xs,xu,xv,xz,xzts,xtts)
- endif ! if ( xt == 0 ) then
-
- end subroutine dtm_1p
+ call sw_ps_9b(xz1,fw)
+ q_warm = fw*i0-q !total heat abs in warm layer
+ call sw_ps_9b_aw(xz1,aw)
+ drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep
+ dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) &
+ + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1))
+
+ xt2 = xt0 + timestep*q_warm/(rho*cp_w)
+ xs2 = xs0 + timestep*sep
+ xu2 = xu0 + timestep*(fc*xv1+tox/rho)
+ xv2 = xv0 + timestep*(-fc*xu1+toy/rho)
+ xz2 = xz0 + timestep*dzw
+
+ ! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2
+
+ if ( xt2 <= zero .or. xz2 <= zero .or. xz2 > z_w_max ) then
+ call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
+ return
+ endif
-!>\ingroup gfs_nst_main_mod
-!! This subroutine integrates one time step with modified Euler method.
- subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,&
- beta,alon,sinlat,soltim,grav,le,d_conv, &
- xt,xs,xu,xv,xz,xzts,xtts)
+ xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * &
+ ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho) &
+ +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* &
+ grav*xz1*xz1/(4.0*rich) )*xzts1 ))
+ xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w)
+
+ xt = 0.5*(xt1 + xt2)
+ xs = 0.5*(xs1 + xs2)
+ xu = 0.5*(xu1 + xu2)
+ xv = 0.5*(xv1 + xv2)
+ xz = 0.5*(xz1 + xz2)
+ xzts = 0.5*(xzts1 + xzts2)
+ xtts = 0.5*(xtts1 + xtts2)
+
+ if ( xt <= zero .or. xz < zero .or. xz > z_w_max ) then
+ call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
+ endif
-!
-! subroutine eulerm: integrate one time step with modified euler method
-!
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,&
- hl_ts,rho,alpha,beta,alon,sinlat,soltim,&
- grav,le,d_conv
- real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts
-! local variables
- real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0
- real(kind=kind_phys) :: fw,aw,q_warm
- real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1
- real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2
- real(kind=kind_phys) :: dzw,drho,fc
- real(kind=kind_phys) :: alat,speed
-! logical lprnt
-
-!
-! input variables
-!
-! timestep: integration time step in seconds
-! rich : critial ri (flow/mass dependent)
-! tox : x wind stress (n*m^-2 or kg/m/s^2)
-! toy : y wind stress (n*m^-2 or kg/m/s^2)
-! i0 : solar radiation flux at the surface (wm^-2)
-! q : non-solar heat flux at the surface (wm^-2)
-! sss : salinity (ppt)
-! sep : sr(e-p) (ppt*m/s)
-! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes
-! hl_ts : d(hl)/d(ts)
-! rho : sea water density (kg*m^-3)
-! alpha : thermal expansion coefficient (1/k)
-! beta : saline contraction coefficient (1/ppt)
-! alon : longitude (deg)
-! sinlat : sine (lat)
-! soltim : solar time
-! grav : gravity accelleration
-! le : le=(2.501-.00237*tsea)*1e6
-! d_conv : fcl thickness (m)
-!
-! inout variables
-!
-! xt : dtl heat content (m*k)
-! xs : dtl salinity content (m*ppt)
-! xu : dtl x current content (m*m/s)
-! xv : dtl y current content (m*m/s)
-! xz : dtl thickness (m)
-! xzts : d(xz)/d(ts) (m/k )
-! xtts : d(xt)/d(ts) (m)
-
- xt0 = xt
- xs0 = xs
- xu0 = xu
- xv0 = xv
- xz0 = xz
- xtts0 = xtts
- xzts0 = xzts
- speed = max(1.0e-8, xu0*xu0+xv0*xv0)
-
- alat = asin(sinlat)*rad2deg
-
- fc = const_rot*sinlat
-
- call sw_ps_9b(xz0,fw)
-
- q_warm = fw*i0-q !total heat abs in warm layer
-
- call sw_ps_9b_aw(xz0,aw)
-
- drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep
-
-! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) &
-! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0))
- dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) &
- + xz0*xz0*drho*grav / (4.0*rich*speed))
-
- xt1 = xt0 + timestep*q_warm/(rho*cp_w)
- xs1 = xs0 + timestep*sep
- xu1 = xu0 + timestep*(fc*xv0+tox/rho)
- xv1 = xv0 + timestep*(-fc*xu0+toy/rho)
- xz1 = xz0 + timestep*dzw
-
-! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, &
-! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich
-
- if ( xt1 <= 0.0 .or. xz1 <= 0.0 .or. xz1 > z_w_max ) then
- call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
+ ! if (lprnt) print *,' xt=',xt,' xz=',xz
+ ! if ( 2.0*xt/xz > 0.001 ) then
+ ! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,&
+ ! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te
+ ! endif
return
- endif
-
-! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa)
-
- xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * &
- ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho)&
- +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) &
- *grav*xz0*xz0/(4.0*rich) )*xzts0 ))
- xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w)
-
-! if ( 2.0*xt1/xz1 > 0.001 ) then
-! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,&
-! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te
-! endif
-
- call sw_ps_9b(xz1,fw)
- q_warm = fw*i0-q !total heat abs in warm layer
- call sw_ps_9b_aw(xz1,aw)
- drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep
- dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) &
- + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1))
-
- xt2 = xt0 + timestep*q_warm/(rho*cp_w)
- xs2 = xs0 + timestep*sep
- xu2 = xu0 + timestep*(fc*xv1+tox/rho)
- xv2 = xv0 + timestep*(-fc*xu1+toy/rho)
- xz2 = xz0 + timestep*dzw
-
-! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2
-
- if ( xt2 <= 0.0 .or. xz2 <= 0.0 .or. xz2 > z_w_max ) then
- call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
- return
- endif
-
- xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * &
- ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho)&
- +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* &
- grav*xz1*xz1/(4.0*rich) )*xzts1 ))
- xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w)
-
- xt = 0.5*(xt1 + xt2)
- xs = 0.5*(xs1 + xs2)
- xu = 0.5*(xu1 + xu2)
- xv = 0.5*(xv1 + xv2)
- xz = 0.5*(xz1 + xz2)
- xzts = 0.5*(xzts1 + xzts2)
- xtts = 0.5*(xtts1 + xtts2)
-
- if ( xt <= 0.0 .or. xz < 0.0 .or. xz > z_w_max ) then
- call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
- endif
-
-! if (lprnt) print *,' xt=',xt,' xz=',xz
-! if ( 2.0*xt/xz > 0.001 ) then
-! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,&
-! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te
-! endif
- return
-
- end subroutine eulerm
-!>\ingroup gfs_nst_main_mod
-!! This subroutine applies xz adjustment.
- subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa)
-! apply xz adjustment: minimum depth adjustment (mda)
-! free convection adjustment (fca);
-! top layer adjustment (tla);
-! maximum warming adjustment (mwa)
-!
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv
- real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz
- real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa
-! local variables
- real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm
- real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa
-!
- real(kind=kind_phys) xz_mda
-
- tr_mda = 0.0; tr_fca = 0.0; tr_tla = 0.0; tr_mwa = 0.0
-
-! apply mda
- if ( z_w_min > xz ) then
- xz_mda = z_w_min
- endif
-! apply fca
- if ( d_conv > 0.0 ) then
- xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz)))
- tr_fca = 1.0
- if ( xz_fca >= z_w_max ) then
- call dtl_reset_cv(xt,xs,xu,xv,xz)
- go to 10
- endif
- endif
-! apply tla
- dz = min(xz,max(d_conv,delz))
- call sw_ps_9b(dz,fw)
- q_warm=fw*i0-q !total heat abs in warm layer
-
- if ( q_warm > 0.0 ) then
- call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0)
-! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz))
- ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz))
- if ( ttop > ttop0 ) then
- xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0
- tr_tla = 1.0
- if ( xz_tla >= z_w_max ) then
- call dtl_reset_cv(xt,xs,xu,xv,xz)
- go to 10
+ end subroutine eulerm
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine applies xz adjustment.
+ subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa)
+ ! apply xz adjustment: minimum depth adjustment (mda)
+ ! free convection adjustment (fca);
+ ! top layer adjustment (tla);
+ ! maximum warming adjustment (mwa)
+ !
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv
+ real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz
+ real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa
+ ! local variables
+ real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm
+ ! TODO: xz_mwa is unset but used below in max function
+ real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa
+ !
+ real(kind=kind_phys) :: xz_mda
+
+ tr_mda = zero; tr_fca = zero; tr_tla = zero; tr_mwa = zero
+
+ ! apply mda
+ if ( z_w_min > xz ) then
+ xz_mda = z_w_min
+ endif
+ ! apply fca
+ if ( d_conv > zero ) then
+ xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz)))
+ tr_fca = 1.0
+ if ( xz_fca >= z_w_max ) then
+ call dtl_reset_cv(xt,xs,xu,xv,xz)
+ go to 10
endif
- endif
- endif
+ endif
+ ! apply tla
+ dz = min(xz,max(d_conv,delz))
+ call sw_ps_9b(dz,fw)
+ q_warm=fw*i0-q !total heat abs in warm layer
-! apply mwa
- t0 = 2.0*xt/xz
- if ( t0 > tw_max ) then
- if ( xz >= z_w_max ) then
- call dtl_reset_cv(xt,xs,xu,xv,xz)
- go to 10
- endif
- endif
+ if ( q_warm > zero ) then
+ call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0)
+ ! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz))
+ ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz))
+ if ( ttop > ttop0 ) then
+ xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0
+ tr_tla = 1.0
+ if ( xz_tla >= z_w_max ) then
+ call dtl_reset_cv(xt,xs,xu,xv,xz)
+ go to 10
+ endif
+ endif
+ endif
- xz = max(xz_mda,xz_fca,xz_tla,xz_mwa)
+ ! apply mwa
+ t0 = 2.0*xt/xz
+ if ( t0 > tw_max ) then
+ if ( xz >= z_w_max ) then
+ call dtl_reset_cv(xt,xs,xu,xv,xz)
+ go to 10
+ endif
+ endif
- 10 continue
-
- end subroutine dtm_1p_zwa
+ xz = max(xz_mda,xz_fca,xz_tla,xz_mwa)
+
+10 continue
+
+ end subroutine dtm_1p_zwa
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine applies free convection adjustment(fca).
+ subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts)
+
+ ! apply xz adjustment: free convection adjustment (fca);
+ !
+ real(kind=kind_phys), intent(in) :: d_conv,xt,xtts
+ real(kind=kind_phys), intent(inout) :: xz,xzts
+ ! local variables
+ real(kind=kind_phys) :: t_fcl,t0
+ !
+ t0 = 2.0*xt/xz
+ t_fcl = t0*(1.0-d_conv/(2.0*xz))
+ xz = 2.0*xt/t_fcl
+ ! xzts = 2.0*xtts/t_fcl
+
+ end subroutine dtm_1p_fca
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine applies top layer adjustment (tla).
+ subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts)
+
+ ! apply xz adjustment: top layer adjustment (tla);
+ !
+ real(kind=kind_phys), intent(in) :: dz,te,xt,xtts
+ real(kind=kind_phys), intent(inout) :: xz,xzts
+ ! local variables
+ real(kind=kind_phys) :: tem
+ !
+ tem = xt*(xt-dz*te)
+ if (tem > zero) then
+ xz = (xt+sqrt(xt*(xt-dz*te)))/te
+ else
+ xz = z_w_max
+ endif
+ ! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te
+ end subroutine dtm_1p_tla
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine applies maximum warming adjustment (mwa).
+ subroutine dtm_1p_mwa(xt,xtts,xz,xzts)
+
+ ! apply xz adjustment: maximum warming adjustment (mwa)
+ !
+ real(kind=kind_phys), intent(in) :: xt,xtts
+ real(kind=kind_phys), intent(inout) :: xz,xzts
+ ! local variables
+ !
+ xz = 2.0*xt/tw_max
+ ! xzts = 2.0*xtts/tw_max
+ end subroutine dtm_1p_mwa
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine applies minimum depth adjustment (xz adjustment).
+ subroutine dtm_1p_mda(xt,xtts,xz,xzts)
+
+ ! apply xz adjustment: minimum depth adjustment (mda)
+ !
+ real(kind=kind_phys), intent(in) :: xt,xtts
+ real(kind=kind_phys), intent(inout) :: xz,xzts
+ ! local variables
+ real(kind=kind_phys) :: ta
+ !
+ xz = max(z_w_min,xz)
+ ta = 2.0*xt/xz
+ ! xzts = 2.0*xtts/ta
+
+ end subroutine dtm_1p_mda
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine applies maximum temperature adjustment (mta).
+ subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts)
+
+ ! apply xz adjustment: maximum temperature adjustment (mta)
+ !
+ real(kind=kind_phys), intent(in) :: dta,xt,xtts
+ real(kind=kind_phys), intent(inout) :: xz,xzts
+ ! local variables
+ real(kind=kind_phys) :: ta
+ !
+ ta = max(zero,2.0*xt/xz-dta)
+ if ( ta > zero ) then
+ xz = 2.0*xt/ta
+ else
+ xz = z_w_max
+ endif
+ ! xzts = 2.0*xtts/ta
+
+ end subroutine dtm_1p_mta
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine calculates depth for convective adjustment.
+ subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv)
+
+ !
+ ! calculate depth for convective adjustment
+ !
+
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta
+ real(kind=kind_phys), intent(in) :: xt,xs,xz
+ real(kind=kind_phys), intent(out) :: d_conv
+ real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1
+ integer :: n
+ !
+ ! input variables
+ !
+ ! timestep: time step in seconds
+ ! i0 : solar radiation flux at the surface (wm^-2)
+ ! q : non-solar heat flux at the surface (wm^-2)
+ ! sss : salinity (ppt)
+ ! sep : sr(e-p) (ppt*m/s)
+ ! rho : sea water density (kg*m^-3)
+ ! alpha : thermal expansion coefficient (1/k)
+ ! beta : saline contraction coefficient (1/ppt)
+ ! xt : initial heat content (k*m)
+ ! xs : initial salinity content (ppt*m)
+ ! xz : initial dtl thickness (m)
+ !
+ ! output variables
+ !
+ ! d_conv : free convection depth (m)
+
+ ! t : initial diurnal warming t (k)
+ ! s : initial diurnal warming s (ppt)
+
+ n = 0
+ t = 2.0*xt/xz
+ s = 2.0*xs/xz
+
+ s1 = alpha*rho*t-omg_m*beta*rho*s
+
+ if ( s1 == zero ) then
+ d_conv = zero
+ else
-!>\ingroup gfs_nst_main_mod
-!! This subroutine applies free convection adjustment(fca).
- subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts)
-
-! apply xz adjustment: free convection adjustment (fca);
-!
- real(kind=kind_phys), intent(in) :: d_conv,xt,xtts
- real(kind=kind_phys), intent(inout) :: xz,xzts
-! local variables
- real(kind=kind_phys) :: t_fcl,t0
-!
- t0 = 2.0*xt/xz
- t_fcl = t0*(1.0-d_conv/(2.0*xz))
- xz = 2.0*xt/t_fcl
-! xzts = 2.0*xtts/t_fcl
-
- end subroutine dtm_1p_fca
+ fac1 = alpha*q/cp_w+omg_m*beta*rho*sep
+ if ( i0 <= zero ) then
+ d_conv2=(2.0*xz*timestep/s1)*fac1
+ if ( d_conv2 > zero ) then
+ d_conv = sqrt(d_conv2)
+ else
+ d_conv = zero
+ endif
+ elseif ( i0 > zero ) then
+
+ d_conv_ini = zero
+
+ iter_conv: do n = 1, niter_conv
+ call sw_ps_9b(d_conv_ini,fxp)
+ call sw_ps_9b_aw(d_conv_ini,aw)
+ s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep
+ d_conv2=(2.0*xz*timestep/s1)*s2
+ if ( d_conv2 < zero ) then
+ d_conv = zero
+ exit iter_conv
+ endif
+ d_conv = sqrt(d_conv2)
+ if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv
+ d_conv_ini = d_conv
+ enddo iter_conv
+ d_conv = max(zero,min(d_conv,z_w_max))
+ endif ! if ( i0 <= zero ) then
+
+ endif ! if ( s1 == zero ) then
+
+ ! if ( d_conv > 0.01 ) then
+ ! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, &
+ ! s1,s2,d_conv2,aw
+ ! endif
+
+ end subroutine convdepth
+
+ !>\ingroup gfs_nst_main_mod
+ subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, &
+ alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts)
+ !
+ ! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables
+ !
+
+ integer,intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, &
+ hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le
+ real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts
+ real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0
+ real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1
+ real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1
+ real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat
+ integer :: n
+ !
+ ! input variables
+ !
+ ! timestep: time step in seconds
+ ! tox : x wind stress (n*m^-2 or kg/m/s^2)
+ ! toy : y wind stress (n*m^-2 or kg/m/s^2)
+ ! i0 : solar radiation flux at the surface (wm^-2)
+ ! q : non-solar heat flux at the surface (wm^-2)
+ ! sss : salinity (ppt)
+ ! sep : sr(e-p) (ppt*m/s)
+ ! rho : sea water density (kg*m^-3)
+ ! alpha : thermal expansion coefficient (1/k)
+ ! beta : saline contraction coefficient (1/ppt)
+ ! alon : longitude
+ ! sinlat : sine(latitude)
+ ! grav : gravity accelleration
+ ! le : le=(2.501-.00237*tsea)*1e6
+ !
+ ! output variables
+ !
+ ! xt : onset t content in dtl
+ ! xs : onset s content in dtl
+ ! xu : onset u content in dtl
+ ! xv : onset v content in dtl
+ ! xz : onset dtl thickness (m)
+ ! xzts : onset d(xz)/d(ts) (m/k )
+ ! xtts : onset d(xt)/d(ts) (m)
+
+ fc=1.46/10000.0/2.0*sinlat
+ alat = asin(sinlat)
+ !
+ ! initializing dtl (just before the onset)
+ !
+ xt0 = zero
+ xs0 = zero
+ xu0 = zero
+ xv0 = zero
+
+ z_w_tmp=z_w_ini
+
+ call sw_ps_9b(z_w_tmp,fw)
+ ! fw=0.5 !
+ q_warm=fw*i0-q !total heat abs in warm layer
-!>\ingroup gfs_nst_main_mod
-!! This subroutine applies top layer adjustment (tla).
- subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts)
-
-! apply xz adjustment: top layer adjustment (tla);
-!
- real(kind=kind_phys), intent(in) :: dz,te,xt,xtts
- real(kind=kind_phys), intent(inout) :: xz,xzts
-! local variables
- real(kind=kind_phys) tem
-!
- tem = xt*(xt-dz*te)
- if (tem > 0.0) then
- xz = (xt+sqrt(xt*(xt-dz*te)))/te
- else
- xz = z_w_max
- endif
-! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te
- end subroutine dtm_1p_tla
+ if ( abs(alat) > 1.0 ) then
+ ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep))
+ else
+ ftime=timestep
+ endif
-!>\ingroup gfs_nst_main_mod
-!! This subroutine applies maximum warming adjustment (mwa).
- subroutine dtm_1p_mwa(xt,xtts,xz,xzts)
-
-! apply xz adjustment: maximum warming adjustment (mwa)
-!
- real(kind=kind_phys), intent(in) :: xt,xtts
- real(kind=kind_phys), intent(inout) :: xz,xzts
-! local variables
-!
- xz = 2.0*xt/tw_max
-! xzts = 2.0*xtts/tw_max
- end subroutine dtm_1p_mwa
+ coeff1=alpha*grav/cp_w
+ coeff2=omg_m*beta*grav*rho
+ warml = coeff1*q_warm-coeff2*sep
+
+ if ( warml > zero .and. q_warm > zero) then
+ iters_z_w: do n = 1,niter_z_w
+ if ( warml > zero .and. q_warm > zero ) then
+ z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml)
+ else
+ z_w = z_w_max
+ exit iters_z_w
+ endif
+
+ ! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m
+
+ if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w
+ z_w_tmp=z_w
+ call sw_ps_9b(z_w_tmp,fw)
+ q_warm = fw*i0-q
+ warml = coeff1*q_warm-coeff2*sep
+ end do iters_z_w
+ else
+ z_w=z_w_max
+ endif
-!>\ingroup gfs_nst_main_mod
-!! This subroutine applies minimum depth adjustment (xz adjustment).
- subroutine dtm_1p_mda(xt,xtts,xz,xzts)
-
-! apply xz adjustment: minimum depth adjustment (mda)
-!
- real(kind=kind_phys), intent(in) :: xt,xtts
- real(kind=kind_phys), intent(inout) :: xz,xzts
-! local variables
- real(kind=kind_phys) :: ta
-!
- xz = max(z_w_min,xz)
- ta = 2.0*xt/xz
-! xzts = 2.0*xtts/ta
-
- end subroutine dtm_1p_mda
+ xz0 = max(z_w,z_w_min)
-!>\ingroup gfs_nst_main_mod
-!! This subroutine applies maximum temperature adjustment (mta).
- subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts)
-
-! apply xz adjustment: maximum temperature adjustment (mta)
-!
- real(kind=kind_phys), intent(in) :: dta,xt,xtts
- real(kind=kind_phys), intent(inout) :: xz,xzts
-! local variables
- real(kind=kind_phys) :: ta
-!
- ta = max(0.0,2.0*xt/xz-dta)
- if ( ta > 0.0 ) then
- xz = 2.0*xt/ta
- else
- xz = z_w_max
- endif
-! xzts = 2.0*xtts/ta
-
- end subroutine dtm_1p_mta
+ !
+ ! update xt, xs, xu, xv
+ !
+ if ( z_w < z_w_max .and. q_warm > zero) then
-!>\ingroup gfs_nst_main_mod
-!! This subroutine calculates depth for convective adjustment.
-subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv)
-
-!
-! calculate depth for convective adjustment
-!
-
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta
- real(kind=kind_phys), intent(in) :: xt,xs,xz
- real(kind=kind_phys), intent(out) :: d_conv
- real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1
- integer :: n
-!
-! input variables
-!
-! timestep: time step in seconds
-! i0 : solar radiation flux at the surface (wm^-2)
-! q : non-solar heat flux at the surface (wm^-2)
-! sss : salinity (ppt)
-! sep : sr(e-p) (ppt*m/s)
-! rho : sea water density (kg*m^-3)
-! alpha : thermal expansion coefficient (1/k)
-! beta : saline contraction coefficient (1/ppt)
-! xt : initial heat content (k*m)
-! xs : initial salinity content (ppt*m)
-! xz : initial dtl thickness (m)
-!
-! output variables
-!
-! d_conv : free convection depth (m)
-
-! t : initial diurnal warming t (k)
-! s : initial diurnal warming s (ppt)
-
- n = 0
- t = 2.0*xt/xz
- s = 2.0*xs/xz
-
- s1 = alpha*rho*t-omg_m*beta*rho*s
-
- if ( s1 == 0.0 ) then
- d_conv = 0.0
- else
-
- fac1 = alpha*q/cp_w+omg_m*beta*rho*sep
- if ( i0 <= 0.0 ) then
- d_conv2=(2.0*xz*timestep/s1)*fac1
- if ( d_conv2 > 0.0 ) then
- d_conv = sqrt(d_conv2)
- else
- d_conv = 0.0
- endif
- elseif ( i0 > 0.0 ) then
-
- d_conv_ini = 0.0
-
- iter_conv: do n = 1, niter_conv
- call sw_ps_9b(d_conv_ini,fxp)
- call sw_ps_9b_aw(d_conv_ini,aw)
- s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep
- d_conv2=(2.0*xz*timestep/s1)*s2
- if ( d_conv2 < 0.0 ) then
- d_conv = 0.0
- exit iter_conv
- endif
- d_conv = sqrt(d_conv2)
- if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv
- d_conv_ini = d_conv
- enddo iter_conv
- d_conv = max(0.0,min(d_conv,z_w_max))
- endif ! if ( i0 <= 0.0 ) then
+ call sw_ps_9b(z_w,fw)
+ q_warm=fw*i0-q !total heat abs in warm layer
- endif ! if ( s1 == 0.0 ) then
+ ft0 = q_warm/(rho*cp_w)
+ fs0 = sep
+ fu0 = fc*xv0+tox/rho
+ fv0 = -fc*xu0+toy/rho
-! if ( d_conv > 0.01 ) then
-! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, &
-! s1,s2,d_conv2,aw
-! endif
+ xt1 = xt0 + timestep*ft0
+ xs1 = xs0 + timestep*fs0
+ xu1 = xu0 + timestep*fu0
+ xv1 = xv0 + timestep*fv0
- end subroutine convdepth
+ fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) &
+ -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1)
+ xz1 = xz0 + timestep*fz0
-!>\ingroup gfs_nst_main_mod
- subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, &
- alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts)
-!
-! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables
-!
-
- integer,intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,&
- hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le
- real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts
- real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0
- real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1
- real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1
- real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat
- integer :: n
-!
-! input variables
-!
-! timestep: time step in seconds
-! tox : x wind stress (n*m^-2 or kg/m/s^2)
-! toy : y wind stress (n*m^-2 or kg/m/s^2)
-! i0 : solar radiation flux at the surface (wm^-2)
-! q : non-solar heat flux at the surface (wm^-2)
-! sss : salinity (ppt)
-! sep : sr(e-p) (ppt*m/s)
-! rho : sea water density (kg*m^-3)
-! alpha : thermal expansion coefficient (1/k)
-! beta : saline contraction coefficient (1/ppt)
-! alon : longitude
-! sinlat : sine(latitude)
-! grav : gravity accelleration
-! le : le=(2.501-.00237*tsea)*1e6
-!
-! output variables
-!
-! xt : onset t content in dtl
-! xs : onset s content in dtl
-! xu : onset u content in dtl
-! xv : onset v content in dtl
-! xz : onset dtl thickness (m)
-! xzts : onset d(xz)/d(ts) (m/k )
-! xtts : onset d(xt)/d(ts) (m)
-
- fc=1.46/10000.0/2.0*sinlat
- alat = asin(sinlat)
-!
-! initializing dtl (just before the onset)
-!
- xt0 = 0.0
- xs0 = 0.0
- xu0 = 0.0
- xv0 = 0.0
-
- z_w_tmp=z_w_ini
-
- call sw_ps_9b(z_w_tmp,fw)
-! fw=0.5 !
- q_warm=fw*i0-q !total heat abs in warm layer
-
- if ( abs(alat) > 1.0 ) then
- ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep))
- else
- ftime=timestep
- endif
-
- coeff1=alpha*grav/cp_w
- coeff2=omg_m*beta*grav*rho
- warml = coeff1*q_warm-coeff2*sep
-
- if ( warml > 0.0 .and. q_warm > 0.0) then
- iters_z_w: do n = 1,niter_z_w
- if ( warml > 0.0 .and. q_warm > 0.0 ) then
- z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml)
- else
- z_w = z_w_max
- exit iters_z_w
- endif
-
-! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m
-
- if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w
- z_w_tmp=z_w
- call sw_ps_9b(z_w_tmp,fw)
- q_warm = fw*i0-q
- warml = coeff1*q_warm-coeff2*sep
- end do iters_z_w
- else
- z_w=z_w_max
- endif
-
- xz0 = max(z_w,z_w_min)
-
-!
-! update xt, xs, xu, xv
-!
- if ( z_w < z_w_max .and. q_warm > 0.0) then
-
- call sw_ps_9b(z_w,fw)
- q_warm=fw*i0-q !total heat abs in warm layer
+ xz1 = max(xz1,z_w_min)
- ft0 = q_warm/(rho*cp_w)
- fs0 = sep
- fu0 = fc*xv0+tox/rho
- fv0 = -fc*xu0+toy/rho
+ if ( xt1 < zero .or. xz1 > z_w_max ) then
+ call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts)
+ return
+ endif
- xt1 = xt0 + timestep*ft0
- xs1 = xs0 + timestep*fs0
- xu1 = xu0 + timestep*fu0
- xv1 = xv0 + timestep*fv0
+ call sw_ps_9b(xz1,fw)
+ q_warm=fw*i0-q !total heat abs in warm layer
- fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) &
- -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1)
- xz1 = xz0 + timestep*fz0
+ ft1 = q_warm/(rho*cp_w)
+ fs1 = sep
+ fu1 = fc*xv1+tox/rho
+ fv1 = -fc*xu1+toy/rho
- xz1 = max(xz1,z_w_min)
+ fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) &
+ -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1)
- if ( xt1 < 0.0 .or. xz1 > z_w_max ) then
- call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts)
- return
- endif
+ xt = xt0 + 0.5*timestep*(ft0+ft1)
+ xs = xs0 + 0.5*timestep*(fs0+fs1)
+ xu = xu0 + 0.5*timestep*(fu0+fu1)
+ xv = xv0 + 0.5*timestep*(fv0+fv1)
+ xz = xz0 + 0.5*timestep*(fz0+fz1)
- call sw_ps_9b(xz1,fw)
- q_warm=fw*i0-q !total heat abs in warm layer
-
- ft1 = q_warm/(rho*cp_w)
- fs1 = sep
- fu1 = fc*xv1+tox/rho
- fv1 = -fc*xu1+toy/rho
+ xz = max(xz,z_w_min)
- fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) &
- -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1)
+ call sw_ps_9b_aw(xz,aw)
- xt = xt0 + 0.5*timestep*(ft0+ft1)
- xs = xs0 + 0.5*timestep*(fs0+fs1)
- xu = xu0 + 0.5*timestep*(fu0+fu1)
- xv = xv0 + 0.5*timestep*(fv0+fv1)
- xz = xz0 + 0.5*timestep*(fz0+fz1)
-
- xz = max(xz,z_w_min)
+ ! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss))
+ xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha))
+ xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w)
+ endif
- call sw_ps_9b_aw(xz,aw)
+ if ( xt < zero .or. xz > z_w_max ) then
+ call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts)
+ endif
-! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss))
- xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha))
- xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w)
- endif
+ return
- if ( xt < 0.0 .or. xz > z_w_max ) then
- call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts)
- endif
-
- return
+ end subroutine dtm_onset
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes coefficients (\a w_0 and \a w_d) to
+ !! calculate d(tw)/d(ts).
+ subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d)
+ !
+ ! abstract: calculate w_0,w_d
+ !
+ ! input variables
+ !
+ ! kdt : the number of time step
+ ! xt : dtl heat content
+ ! xz : dtl depth
+ ! xzts : d(zw)/d(ts)
+ ! xtts : d(xt)/d(ts)
+ !
+ ! output variables
+ !
+ ! w_0 : coefficint 1 to calculate d(tw)/d(ts)
+ ! w_d : coefficint 2 to calculate d(tw)/d(ts)
+
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts
+ real(kind=kind_phys), intent(out) :: w_0,w_d
+
+ w_0 = 2.0*(xtts-xt*xzts/xz)/xz
+ w_d = (2.0*xt*xzts/xz**2-w_0)/xz
+
+ ! if ( 2.0*xt/xz > 1.0 ) then
+ ! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts
+ ! endif
+ end subroutine cal_w
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine calculates the diurnal warming amount at the top layer
+ !! with thickness of \a delz.
+ subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop)
+ !
+ ! abstract: calculate
+ !
+ ! input variables
+ !
+ ! kdt : the number of record
+ ! timestep : the number of record
+ ! q_warm : total heat abs in layer dz
+ ! rho : sea water density
+ ! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz
+ ! xt : heat content in dtl at previous time
+ ! xz : dtl thickness at previous time
+ !
+ ! output variables
+ !
+ ! ttop : the diurnal warming amount at the top layer with thickness of delz
+
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz
+ real(kind=kind_phys), intent(out) :: ttop
+ real(kind=kind_phys) :: dt_warm,t0
+
+ dt_warm = (xt+xt)/xz
+ t0 = dt_warm*(1.0-dz/(xz+xz))
+ ttop = t0 + q_warm*timestep/(rho*cp_w*dz)
+
+ end subroutine cal_ttop
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine adjust dtm-1p dtl thickness by applying shear flow stability
+ !! with assumed exponential profile.
+ subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz)
+ !
+ ! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile
+ !
+ ! input variables
+ !
+ ! kdt : the number of record
+ ! xt : heat content in dtl
+ ! xs : salinity content in dtl
+ ! xu : u-current content in dtl
+ ! xv : v-current content in dtl
+ ! alpha
+ ! beta
+ ! grav
+ ! d_1p : dtl depth before sfs applied
+ !
+ ! output variables
+ !
+ ! xz : dtl depth
+
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p
+ real(kind=kind_phys), intent(out) :: xz
+ ! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem
+ real(kind=kind_phys) :: cc,l,d_sfs,tem
+ real(kind=kind_phys), parameter :: c2 = 0.3782
+
+ cc = ri_g/(grav*c2)
+
+ tem = alpha*xt - beta*xs
+ if (tem > zero) then
+ d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem)
+ else
+ d_sfs = zero
+ endif
- end subroutine dtm_onset
+ ! xz0 = d_1p
+ ! iter_sfs: do n = 1, niter_sfs
+ ! l = int_epn(0.0,xz0,0.0,xz0,2)
+ ! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l)
+ ! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs
+ ! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs
+ ! xz0 = d_sfs
+ ! enddo iter_sfs
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes coefficients (\a w_0 and \a w_d) to
-!! calculate d(tw)/d(ts).
- subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d)
-!
-! abstract: calculate w_0,w_d
-!
-! input variables
-!
-! kdt : the number of time step
-! xt : dtl heat content
-! xz : dtl depth
-! xzts : d(zw)/d(ts)
-! xtts : d(xt)/d(ts)
-!
-! output variables
-!
-! w_0 : coefficint 1 to calculate d(tw)/d(ts)
-! w_d : coefficint 2 to calculate d(tw)/d(ts)
-
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts
- real(kind=kind_phys), intent(out) :: w_0,w_d
-
- w_0 = 2.0*(xtts-xt*xzts/xz)/xz
- w_d = (2.0*xt*xzts/xz**2-w_0)/xz
-
-! if ( 2.0*xt/xz > 1.0 ) then
-! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts
-! endif
- end subroutine cal_w
+ ! ze = a2*d_sfs ! not used!
-!>\ingroup gfs_nst_main_mod
-!! This subroutine calculates the diurnal warming amount at the top layer
-!! with thickness of \a delz.
- subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop)
-!
-! abstract: calculate
-!
-! input variables
-!
-! kdt : the number of record
-! timestep : the number of record
-! q_warm : total heat abs in layer dz
-! rho : sea water density
-! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz
-! xt : heat content in dtl at previous time
-! xz : dtl thickness at previous time
-!
-! output variables
-!
-! ttop : the diurnal warming amount at the top layer with thickness of delz
-
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz
- real(kind=kind_phys), intent(out) :: ttop
- real(kind=kind_phys) :: dt_warm,t0
-
- dt_warm = (xt+xt)/xz
- t0 = dt_warm*(1.0-dz/(xz+xz))
- ttop = t0 + q_warm*timestep/(rho*cp_w*dz)
-
- end subroutine cal_ttop
+ l = int_epn(zero,d_sfs,zero,d_sfs,2)
-!>\ingroup gfs_nst_main_mod
-!! This subroutine adjust dtm-1p dtl thickness by applying shear flow stability
-!! with assumed exponential profile.
- subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz)
-!
-! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile
-!
-! input variables
-!
-! kdt : the number of record
-! xt : heat content in dtl
-! xs : salinity content in dtl
-! xu : u-current content in dtl
-! xv : v-current content in dtl
-! alpha
-! beta
-! grav
-! d_1p : dtl depth before sfs applied
-!
-! output variables
-!
-! xz : dtl depth
-
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p
- real(kind=kind_phys), intent(out) :: xz
-! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem
- real(kind=kind_phys) :: cc,l,d_sfs,tem
- real(kind=kind_phys), parameter :: c2 = 0.3782
- integer :: n
-
- cc = ri_g/(grav*c2)
-
- tem = alpha*xt - beta*xs
- if (tem > 0.0) then
- d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem)
- else
- d_sfs = 0.0
- endif
-
-! xz0 = d_1p
-! iter_sfs: do n = 1, niter_sfs
-! l = int_epn(0.0,xz0,0.0,xz0,2)
-! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l)
-! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs
-! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs
-! xz0 = d_sfs
-! enddo iter_sfs
-
-! ze = a2*d_sfs ! not used!
-
- l = int_epn(0.0,d_sfs,0.0,d_sfs,2)
-
-! t_sfs = xt/l
-! xz = (xt+xt) / t_sfs
+ ! t_sfs = xt/l
+ ! xz = (xt+xt) / t_sfs
xz = l + l
-! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs
- end subroutine app_sfs
-
-!>\ingroup gfs_nst_main_mod
-!! This subroutine calculates d(tz)/d(ts).
- subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr)
-!
-! abstract: calculate d(tz)/d(ts)
-!
-! input variables
-!
-! kdt : the number of record
-! xt : heat content in dtl
-! xz : dtl depth (m)
-! c_0 : coefficint 1 to calculate d(tc)/d(ts)
-! c_d : coefficint 2 to calculate d(tc)/d(ts)
-! w_0 : coefficint 1 to calculate d(tw)/d(ts)
-! w_d : coefficint 2 to calculate d(tw)/d(ts)
-!
-! output variables
-!
-! tztr : d(tz)/d(tr)
-
- integer, intent(in) :: kdt
- real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z
- real(kind=kind_phys), intent(out) :: tztr
-
- if ( xt > 0.0 ) then
- if ( z <= zc ) then
-! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0)
- tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0)
- elseif ( z > zc .and. z < zw ) then
-! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0)
- tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0)
- elseif ( z >= zw ) then
- tztr = 1.0
- endif
- elseif ( xt == 0.0 ) then
- if ( z <= zc ) then
-! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0)
- tztr = (1.0-z*c_d)/(1.0+c_0)
- else
+ ! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs
+ end subroutine app_sfs
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine calculates d(tz)/d(ts).
+ subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr)
+ !
+ ! abstract: calculate d(tz)/d(ts)
+ !
+ ! input variables
+ !
+ ! kdt : the number of record
+ ! xt : heat content in dtl
+ ! xz : dtl depth (m)
+ ! c_0 : coefficint 1 to calculate d(tc)/d(ts)
+ ! c_d : coefficint 2 to calculate d(tc)/d(ts)
+ ! w_0 : coefficint 1 to calculate d(tw)/d(ts)
+ ! w_d : coefficint 2 to calculate d(tw)/d(ts)
+ !
+ ! output variables
+ !
+ ! tztr : d(tz)/d(tr)
+
+ integer, intent(in) :: kdt
+ real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z
+ real(kind=kind_phys), intent(out) :: tztr
+
+ if ( xt > zero ) then
+ if ( z <= zc ) then
+ ! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0)
+ tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0)
+ elseif ( z > zc .and. z < zw ) then
+ ! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0)
+ tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0)
+ elseif ( z >= zw ) then
+ tztr = 1.0
+ endif
+ elseif ( xt == zero ) then
+ if ( z <= zc ) then
+ ! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0)
+ tztr = (1.0-z*c_d)/(1.0+c_0)
+ else
+ tztr = 1.0
+ endif
+ else
tztr = 1.0
- endif
- else
- tztr = 1.0
- endif
-
-! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr
- end subroutine cal_tztr
-
-!>\ingroup gfs_nst_main_mod
-!> This subroutine contains the upper ocean cool-skin parameterization
-!! (Fairall et al, 1996 \cite fairall_et_al_1996).
-subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d)
-!
-! upper ocean cool-skin parameterizaion, fairall et al, 1996.
-!
-! input:
-! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s)
-! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s)
-! f_sol_0 : solar radiation at the ocean surface (w/m^2)
-! evap : latent heat flux (w/m^2)
-! sss : ocean upper mixed layer salinity (ppu)
-! alpha : thermal expansion coefficient
-! beta : saline contraction coefficient
-! rho_w : oceanic density
-! rho_a : atmospheric density
-! ts : oceanic surface temperature
-! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes
-! hl_ts : d(hl)/d(ts)
-! grav : gravity
-! le :
-!
-! output:
-! deltat_c: cool-skin temperature correction (degrees k)
-! z_c : molecular sublayer (cool-skin) thickness (m)
-! c_0 : coefficient1 to calculate d(tz)/d(ts)
-! c_d : coefficient2 to calculate d(tz)/d(ts)
-
-!
- real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le
- real(kind=kind_phys), intent(out):: deltat_c,z_c,c_0,c_d
-! declare local variables
- real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6 &
- , tcwi=1.0/tcw
- real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2
- real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp
- real(kind=kind_phys) :: zcsq
- real(kind=kind_phys) :: cc1,cc2,cc3
-
-
- z_c = z_c_ini ! initial guess
-
- ustar1_a = max(ustar_a,ustar_a_min)
-
- call sw_rad_skin(z_c,fxp)
- deltaf = f_sol_0*fxp
-
- hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le
- bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw)
-
- if ( hb > 0 ) then
- xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333
- else
- xi = 6.0
- endif
- z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a ))
-
- call sw_rad_skin(z_c,fxp)
-
- deltaf = f_sol_0*fxp
- deltaf = f_nsol - deltaf
- if ( deltaf > 0 ) then
- deltat_c = deltaf * z_c / kw
- else
- deltat_c = 0.
- z_c = 0.
- endif
-!
-! calculate c_0 & c_d
-!
- if ( z_c > 0.0 ) then
- cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w))
- cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4
- cc3 = beta*sss*cp_w/(alpha*le)
- zcsq = z_c * z_c
- a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4)
-
- if ( hb > 0.0 .and. zcsq > 0.0 .and. alpha > 0.0) then
- bc1 = zcsq * (q_ts+cc3*hl_ts)
- bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq)
- zc_ts = bc1/bc2
-! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts)
- b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c &
- - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts)
- c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi
- c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi
+ endif
+ ! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr
+ end subroutine cal_tztr
+
+ !>\ingroup gfs_nst_main_mod
+ !> This subroutine contains the upper ocean cool-skin parameterization
+ !! (Fairall et al, 1996 \cite fairall_et_al_1996).
+ subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d)
+ !
+ ! upper ocean cool-skin parameterizaion, fairall et al, 1996.
+ !
+ ! input:
+ ! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s)
+ ! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s)
+ ! f_sol_0 : solar radiation at the ocean surface (w/m^2)
+ ! evap : latent heat flux (w/m^2)
+ ! sss : ocean upper mixed layer salinity (ppu)
+ ! alpha : thermal expansion coefficient
+ ! beta : saline contraction coefficient
+ ! rho_w : oceanic density
+ ! rho_a : atmospheric density
+ ! ts : oceanic surface temperature
+ ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes
+ ! hl_ts : d(hl)/d(ts)
+ ! grav : gravity
+ ! le :
+ !
+ ! output:
+ ! deltat_c: cool-skin temperature correction (degrees k)
+ ! z_c : molecular sublayer (cool-skin) thickness (m)
+ ! c_0 : coefficient1 to calculate d(tz)/d(ts)
+ ! c_d : coefficient2 to calculate d(tz)/d(ts)
+
+ !
+ real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le
+ real(kind=kind_phys), intent(out) :: deltat_c,z_c,c_0,c_d
+ ! declare local variables
+ real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6, tcwi=1.0/tcw
+ real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2
+ real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp
+ real(kind=kind_phys) :: zcsq
+ real(kind=kind_phys) :: cc1,cc2,cc3
+
+
+ z_c = z_c_ini ! initial guess
+
+ ustar1_a = max(ustar_a,ustar_a_min)
+
+ call sw_rad_skin(z_c,fxp)
+ deltaf = f_sol_0*fxp
+
+ hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le
+ bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw)
+
+ if ( hb > 0 ) then
+ xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333
else
- b_c = 0.0
- zc_ts = 0.0
- c_0 = z_c*q_ts*tcwi
- c_d = -q_ts*tcwi
+ xi = 6.0
endif
+ z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a ))
-! if ( c_0 < 0.0 ) then
-! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2
-! endif
+ call sw_rad_skin(z_c,fxp)
-! c_0 = z_c*q_ts/tcw
-! c_d = -q_ts/tcw
+ deltaf = f_sol_0*fxp
+ deltaf = f_nsol - deltaf
+ if ( deltaf > 0 ) then
+ deltat_c = deltaf * z_c / kw
+ else
+ deltat_c = zero
+ z_c = zero
+ endif
+ !
+ ! calculate c_0 & c_d
+ !
+ if ( z_c > zero ) then
+ cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w))
+ cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4
+ cc3 = beta*sss*cp_w/(alpha*le)
+ zcsq = z_c * z_c
+ a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4)
+
+ if ( hb > zero .and. zcsq > zero .and. alpha > zero) then
+ bc1 = zcsq * (q_ts+cc3*hl_ts)
+ bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq)
+ zc_ts = bc1/bc2
+ ! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts)
+ b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c &
+ - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts)
+ c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi
+ c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi
+
+ else
+ b_c = zero
+ zc_ts = zero
+ c_0 = z_c*q_ts*tcwi
+ c_d = -q_ts*tcwi
+ endif
- else
- c_0 = 0.0
- c_d = 0.0
- endif ! if ( z_c > 0.0 ) then
+ ! if ( c_0 < 0.0 ) then
+ ! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2
+ ! endif
- end subroutine cool_skin
-!
-!======================
-!
-!>\ingroup gfs_nst_main_mod
-!! This function calculates a definitive integral of an exponential curve (power of 2).
- real function int_epn(z1,z2,zmx,ztr,n)
-!
-! abstract: calculate a definitive integral of an exponetial curve (power of 2)
-!
- real(kind_phys) :: z1,z2,zmx,ztr,zi
- real(kind_phys) :: fa,fb,fi,int
- integer :: m,i,n
-
- m = nint((z2-z1)/delz)
- fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n)
- fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n)
- int = 0.0
- do i = 1, m-1
- zi = z1 + delz*float(i)
- fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n)
- int = int + fi
- enddo
- int_epn = delz*((fa+fb)/2.0 + int)
- end function int_epn
+ ! c_0 = z_c*q_ts/tcw
+ ! c_d = -q_ts/tcw
-!>\ingroup gfs_nst_main_mod
-!! This subroutine resets the value of xt,xs,xu,xv,xz.
- subroutine dtl_reset_cv(xt,xs,xu,xv,xz)
- real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz
- xt = 0.0
- xs = 0.0
- xu = 0.0
- xv = 0.0
+ else
+ c_0 = zero
+ c_d = zero
+ endif ! if ( z_c > 0.0 ) then
+
+ end subroutine cool_skin
+ !
+ !======================
+ !
+ !>\ingroup gfs_nst_main_mod
+ !! This function calculates a definitive integral of an exponential curve (power of 2).
+ real function int_epn(z1,z2,zmx,ztr,n)
+ !
+ ! abstract: calculate a definitive integral of an exponetial curve (power of 2)
+ !
+ real(kind_phys) :: z1,z2,zmx,ztr,zi
+ real(kind_phys) :: fa,fb,fi,int
+ integer :: m,i,n
+
+ m = nint((z2-z1)/delz)
+ fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n)
+ fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n)
+ int = zero
+ do i = 1, m-1
+ zi = z1 + delz*float(i)
+ fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n)
+ int = int + fi
+ enddo
+ int_epn = delz*((fa+fb)/2.0 + int)
+ end function int_epn
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine resets the value of xt,xs,xu,xv,xz.
+ subroutine dtl_reset_cv(xt,xs,xu,xv,xz)
+ real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz
+ xt = zero
+ xs = zero
+ xu = zero
+ xv = zero
xz = z_w_max
- end subroutine dtl_reset_cv
-
-!>\ingroup gfs_nst_main_mod
-!! This subroutine resets the value of xt,xs,xu,xv,xz,xtts,xzts.
- subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
- real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts
- xt = 0.0
- xs = 0.0
- xu = 0.0
- xv = 0.0
+ end subroutine dtl_reset_cv
+
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine resets the value of xt,xs,xu,xv,xz,xtts,xzts.
+ subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts)
+ real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts
+ xt = zero
+ xs = zero
+ xu = zero
+ xv = zero
xz = z_w_max
- xtts = 0.0
- xzts = 0.0
- end subroutine dtl_reset
+ xtts = zero
+ xzts = zero
+ end subroutine dtl_reset
end module nst_module
diff --git a/physics/module_nst_parameters.f90 b/physics/module_nst_parameters.f90
index ee0a34914..5308345e2 100644
--- a/physics/module_nst_parameters.f90
+++ b/physics/module_nst_parameters.f90
@@ -9,74 +9,87 @@
!! history:
!! 20210305: X.Li, reduce z_w_max from 30 m to 20 m
module module_nst_parameters
+
use machine, only : kind_phys
!
! air constants and coefficients from the atmospehric model
- use physcons, only: &
- eps => con_eps &
- ,cp_a => con_cp & !< spec heat air @p (j/kg/k)
- , epsm1 => con_epsm1 &
- , hvap => con_hvap & !< lat heat h2o cond (j/kg)
- ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4)
- ,grav => con_g & !< acceleration due to gravity (kg/m/s^2)
- ,omega => con_omega & !< ang vel of earth (1/s)
- ,rvrdm1 => con_fvirt &
- ,rd => con_rd &
- ,rocp => con_rocp & !< r/cp
- ,pi => con_pi
+ use physcons, only: &
+ eps => con_eps & !< con_rd/con_rv (nd)
+ ,cp_a => con_cp & !< spec heat air @p (j/kg/k)
+ ,epsm1 => con_epsm1 & !< eps - 1 (nd)
+ ,hvap => con_hvap & !< lat heat h2o cond (j/kg)
+ ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4)
+ ,grav => con_g & !< acceleration due to gravity (kg/m/s^2)
+ ,omega => con_omega & !< ang vel of earth (1/s)
+ ,rvrdm1 => con_fvirt & !< con_rv/con_rd-1. (nd)
+ ,rd => con_rd & !< gas constant air (j/kg/k)
+ ,rocp => con_rocp & !< r/cp
+ ,pi => con_pi
+
+ implicit none
+
+ private
+
+ public :: sigma_r
+ public :: zero, one, half
+ public :: niter_conv, niter_z_w, niter_sfs
+ public :: z_w_max, z_w_min, z_w_ini, z_c_max, z_c_ini, eps_z_w, eps_conv, eps_sfs
+ public :: ri_c, ri_g, omg_m, omg_sh, tc_w, visw, cp_w, t0k, ustar_a_min, delz, exp_const
+ public :: rad2deg, const_rot, tw_max, sst_max, solar_time_6am, tau_min, wd_max
+
+ real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, half = 0.5_kind_phys
!
! note: take timestep from here later
- public
integer :: &
niter_conv = 5, &
niter_z_w = 5, &
niter_sfs = 5
- real (kind=kind_phys), parameter :: &
- !
- ! general constants
- sec_in_day=86400. &
- ,sec_in_hour=3600. &
- ,solar_time_6am=21600.0 &
- ,const_rot=0.000073 & !< constant to calculate corioli force
- ,ri_c=0.65 &
- ,ri_g=0.25 &
- ,eps_z_w=0.01 & !< criteria to finish iterations for z_w
- ,eps_conv=0.01 & !< criteria to finish iterations for d_conv
- ,eps_sfs=0.01 & !< criteria to finish iterations for d_sfs
- ,z_w_max=20.0 & !< max warm layer thickness
- ,z_w_min=0.2 & !< min warm layer thickness
- ,z_w_ini=0.2 & !< initial warm layer thickness in dtl_onset
- ,z_c_max=0.01 & !< maximum of sub-layer thickness (m)
- ,z_c_ini=0.001 & !< initial value of z_c
- ,ustar_a_min=0.031 & !< minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight
- ,tau_min=0.005 & !< minimum of wind stress for dtm
- ,exp_const=9.5 & !< coefficient in exponet profile
- ,delz=0.1 & !< vertical increment for integral calculation (m)
- ,von=0.4 & !< von karman's "constant"
- ,t0k=273.16 & !< celsius to kelvin
- ,gray=0.97 &
- ,sst_max=308.16 &
- ,tw_max=5.0 &
- ,wd_max=2.0 &
- ,omg_m =1.0 & !< trace factor to apply salinity effect
- ,omg_rot = 1.0 & !< trace factor to apply rotation effect
- ,omg_sh = 1.0 & !< trace factor to apply sensible heat due to rainfall effect
- ,visw=1.e-6 & !< m2/s kinematic viscosity water
- ,novalue=0 &
- ,smallnumber=1.e-6 &
- ,timestep_oc=sec_in_day/8. & !< time step in the ocean model (3 hours)
- ,radian=2.*pi/180. &
- ,rad2deg=180./pi &
- ,cp_w=4000. & !< specific heat water (j/kg/k )
- ,rho0_w=1022.0 & !< density water (kg/m3 ) (or 1024.438)
- ,vis_w=1.e-6 & !< kinematic viscosity water (m2/s )
- ,tc_w=0.6 & !< thermal conductivity water (w/m/k )
- ,capa_w =3950.0 & !< heat capacity of sea water !
- ,thref =1.0e-3 !< reference value of specific volume (m**3/kg)
+ !
+ ! general constants
+ real (kind=kind_phys), parameter :: &
+ sec_in_day = 86400. &
+ ,sec_in_hour = 3600. &
+ ,solar_time_6am = 21600.0 &
+ ,const_rot = 0.000073 & !< constant to calculate corioli force
+ ,ri_c = 0.65 &
+ ,ri_g = 0.25 &
+ ,eps_z_w = 0.01 & !< criteria to finish iterations for z_w
+ ,eps_conv = 0.01 & !< criteria to finish iterations for d_conv
+ ,eps_sfs = 0.01 & !< criteria to finish iterations for d_sfs
+ ,z_w_max = 20.0 & !< max warm layer thickness
+ ,z_w_min = 0.2 & !< min warm layer thickness
+ ,z_w_ini = 0.2 & !< initial warm layer thickness in dtl_onset
+ ,z_c_max = 0.01 & !< maximum of sub-layer thickness (m)
+ ,z_c_ini = 0.001 & !< initial value of z_c
+ ,ustar_a_min = 0.031 & !< minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight
+ ,tau_min = 0.005 & !< minimum of wind stress for dtm
+ ,exp_const = 9.5 & !< coefficient in exponet profile
+ ,delz = 0.1 & !< vertical increment for integral calculation (m)
+ ,von = 0.4 & !< von karman's "constant"
+ ,t0k = 273.16 & !< celsius to kelvin
+ ,gray = 0.97 &
+ ,sst_max = 308.16 &
+ ,tw_max = 5.0 &
+ ,wd_max = 2.0 &
+ ,omg_m = 1.0 & !< trace factor to apply salinity effect
+ ,omg_rot = 1.0 & !< trace factor to apply rotation effect
+ ,omg_sh = 1.0 & !< trace factor to apply sensible heat due to rainfall effect
+ ,visw = 1.e-6 & !< m2/s kinematic viscosity water
+ ,novalue = 0 &
+ ,smallnumber = 1.e-6 &
+ ,timestep_oc = sec_in_day/8. & !< time step in the ocean model (3 hours)
+ ,radian = 2.*pi/180. &
+ ,rad2deg = 180./pi &
+ ,cp_w = 4000. & !< specific heat water (j/kg/k )
+ ,rho0_w = 1022.0 & !< density water (kg/m3 ) (or 1024.438)
+ ,vis_w = 1.e-6 & !< kinematic viscosity water (m2/s )
+ ,tc_w = 0.6 & !< thermal conductivity water (w/m/k )
+ ,capa_w = 3950.0 & !< heat capacity of sea water !
+ ,thref = 1.0e-3 !< reference value of specific volume (m**3/kg)
!!$!============================================
!!$
-!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap
+!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap
!!$ ,alpha=1 ! thermal expansion coefficient
!!$ ,beta ! saline contraction coefficient
!!$ ,cp=1 !=1 specific heat of sea water
@@ -95,7 +108,7 @@ module module_nst_parameters
!!$ fdg=1.00 !based on results from flux workshop august 1995
!!$ tok=273.16 ! celsius to kelvin
!!$ twopi=3.14159*2.
-!!$
+!!$
!!$c air constants and coefficients
!!$ rgas=287.1 !j/kg/k gas const. dry air
!!$ xlv=(2.501-0.00237*ts)*1e+6 !j/kg latent heat of vaporization at ts
@@ -104,7 +117,7 @@ module module_nst_parameters
!!$ rhoa=p*100./(rgas*(t+tok)*(1.+.61*q)) !kg/m3 moist air density ( " )
!!$ visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) !m2/s
!!$ !kinematic viscosity of dry air - andreas (1989) crrel rep. 89-11
-!!$c
+!!$c
!!$c cool skin constants
!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft.
!!$ be=0.026 !salinity expansion coefft.
@@ -126,11 +139,11 @@ module module_nst_parameters
!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3
!!$ real , parameter :: hslab=50.0 !slab ocean depth
!!$ real , parameter :: bad=-1.0e+10
-!!$ real , parameter :: tmin=2.68e+02
+!!$ real , parameter :: tmin=2.68e+02
!!$ real , parameter :: tmax=3.11e+02
!!$
!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2
-!!$ real, parameter :: capa =3950.0 !heat capacity of sea water
+!!$ real, parameter :: capa =3950.0 !heat capacity of sea water
!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3
!!$ real, parameter :: tmin=2.68e+02 !normal minimal temp
!!$ real, parameter :: tmax=3.11e+02 !normal max temp
diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90
index 6a183da52..858659e90 100644
--- a/physics/module_nst_water_prop.f90
+++ b/physics/module_nst_water_prop.f90
@@ -1,3 +1,4 @@
+
!>\file module_nst_water_prop.f90
!! This file contains GFS NSST water property subroutines.
@@ -5,44 +6,45 @@
!!This module contains GFS NSST water property subroutines.
!!\ingroup gfs_nst_main_mod
module module_nst_water_prop
- use machine, only : kind_phys
- use module_nst_parameters, only : t0k
+ use machine , only : kind_phys
+ use module_nst_parameters , only : t0k, zero, one, half
+
+ implicit none
!
private
- public :: rhocoef,density,sw_rad,sw_rad_aw,sw_rad_sum,sw_rad_upper,sw_rad_upper_aw,sw_rad_skin,grv,solar_time_from_julian,compjd, &
- sw_ps_9b,sw_ps_9b_aw,get_dtzm_point,get_dtzm_2d
+ public :: rhocoef, density, sw_rad_skin, grv, sw_ps_9b, sw_ps_9b_aw, get_dtzm_point, get_dtzm_2d
!
interface sw_ps_9b
module procedure sw_ps_9b
- end interface
+ end interface sw_ps_9b
interface sw_ps_9b_aw
module procedure sw_ps_9b_aw
- end interface
+ end interface sw_ps_9b_aw
!
interface sw_rad
module procedure sw_fairall_6exp_v1 ! sw_wick_v1
- end interface
+ end interface sw_rad
interface sw_rad_aw
module procedure sw_fairall_6exp_v1_aw
- end interface
+ end interface sw_rad_aw
interface sw_rad_sum
module procedure sw_fairall_6exp_v1_sum
- end interface
+ end interface sw_rad_sum
interface sw_rad_upper
module procedure sw_soloviev_3exp_v2
- end interface
+ end interface sw_rad_upper
interface sw_rad_upper_aw
module procedure sw_soloviev_3exp_v2_aw
- end interface
+ end interface sw_rad_upper_aw
interface sw_rad_skin
module procedure sw_ohlmann_v1
- end interface
+ end interface sw_rad_skin
contains
! ------------------------------------------------------
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes thermal expansion coefficient (alpha)
-!! and saline contraction coefficient (beta).
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes thermal expansion coefficient (alpha)
+ !! and saline contraction coefficient (beta).
subroutine rhocoef(t, s, rhoref, alpha, beta)
! ------------------------------------------------------
@@ -53,7 +55,6 @@ subroutine rhocoef(t, s, rhoref, alpha, beta)
! dynamical oceanography, pp310.
! note: compression effects are not included
- implicit none
real(kind=kind_phys), intent(in) :: t, s, rhoref
real(kind=kind_phys), intent(out) :: alpha, beta
real(kind=kind_phys) :: tc
@@ -78,18 +79,17 @@ subroutine rhocoef(t, s, rhoref, alpha, beta)
+ 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 &
+ 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 &
+ 1.5 * 1.0227e-4 * tc * s**.5 &
- - 1.5 * 1.6546e-6 * tc**2 * s**.5 &
+ - 1.5 * 1.6546e-6 * tc**2 * s**.5 &
+ 2.0 * 4.8314e-4 * s
beta = beta / rhoref
end subroutine rhocoef
! ----------------------------------------
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes sea water density.
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes sea water density.
subroutine density(t, s, rho)
! ----------------------------------------
- implicit none
! input
real(kind=kind_phys), intent(in) :: t !unit, k
@@ -104,7 +104,7 @@ subroutine density(t, s, rho)
! introduction to dynamical oceanography, pp310).
! compression effects are not included
- rho = 0.0
+ rho = zero
tc = t - t0k
! effect of temperature on density (lines 1-3)
@@ -123,9 +123,9 @@ end subroutine density
!
!======================
!
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes the fraction of the solar radiation absorbed
-!! by the depth z following Paulson and Simpson (1981) \cite paulson_and_simpson_1981 .
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes the fraction of the solar radiation absorbed
+ !! by the depth z following Paulson and Simpson (1981) \cite paulson_and_simpson_1981 .
elemental subroutine sw_ps_9b(z,fxp)
!
! fraction of the solar radiation absorbed by the ocean at the depth z
@@ -137,18 +137,17 @@ elemental subroutine sw_ps_9b(z,fxp)
! output:
! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real,intent(in):: z
- real,intent(out):: fxp
- real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) &
- ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: fxp
+ real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/)
+ real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
!
- if(z>0) then
- fxp=1.0-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ &
- f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ &
- f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9)))
+ if(z>zero) then
+ fxp=one-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ &
+ f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ &
+ f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9)))
else
- fxp=0.
+ fxp=zero
endif
!
end subroutine sw_ps_9b
@@ -158,8 +157,8 @@ end subroutine sw_ps_9b
!
!======================
!
-!>\ingroup gfs_nst_main_mod
-!! This subroutine
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine
elemental subroutine sw_ps_9b_aw(z,aw)
!
! d(fw)/d(z) for 9-band
@@ -170,27 +169,26 @@ elemental subroutine sw_ps_9b_aw(z,aw)
! output:
! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real,intent(in):: z
- real,intent(out):: aw
- real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) &
- ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: aw
+ real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/)
+ real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
!
- if(z>0) then
- aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ &
- (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ &
- (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9))
+ if(z>zero) then
+ aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ &
+ (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ &
+ (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9))
else
- aw=0.
+ aw=zero
endif
!
end subroutine sw_ps_9b_aw
!
!======================
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes fraction of the solar radiation absorbed by the ocean at the depth
-!! z (Fairall et al. (1996) \cite fairall_et_al_1996, p. 1298) following Paulson and Simpson
-!! (1981) \cite paulson_and_simpson_1981 .
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes fraction of the solar radiation absorbed by the ocean at the depth
+ !! z (Fairall et al. (1996) \cite fairall_et_al_1996, p. 1298) following Paulson and Simpson
+ !! (1981) \cite paulson_and_simpson_1981 .
elemental subroutine sw_fairall_6exp_v1(z,fxp)
!
! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298)
@@ -202,20 +200,20 @@ elemental subroutine sw_fairall_6exp_v1(z,fxp)
! output:
! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z
- real(kind=kind_phys),intent(out):: fxp
- real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) &
- ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
- real(kind=kind_phys),dimension(9) :: zgamma
- real(kind=kind_phys),dimension(9) :: f_c
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: fxp
+
+ real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/)
+ real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
+ real(kind=kind_phys), dimension(9) :: zgamma
+ real(kind=kind_phys), dimension(9) :: f_c
!
- if(z>0) then
+ if(z>zero) then
zgamma=z/gamma
- f_c=f*(1.-1./zgamma*(1-exp(-zgamma)))
+ f_c=f*(one-one/zgamma*(one-exp(-zgamma)))
fxp=sum(f_c)
else
- fxp=0.
+ fxp=zero
endif
!
end subroutine sw_fairall_6exp_v1
@@ -223,10 +221,10 @@ end subroutine sw_fairall_6exp_v1
!======================
!
!
-!>\ingroup gfs_nst_main_mod
-!! This subroutine calculates fraction of the solar radiation absorbed by the
-!! ocean at the depth z (fairall et al.(1996) \cite fairall_et_al_1996; p.1298)
-!! following Paulson and Simpson (1981) \cite paulson_and_simpson_1981.
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine calculates fraction of the solar radiation absorbed by the
+ !! ocean at the depth z (fairall et al.(1996) \cite fairall_et_al_1996; p.1298)
+ !! following Paulson and Simpson (1981) \cite paulson_and_simpson_1981.
elemental subroutine sw_fairall_6exp_v1_aw(z,aw)
!
! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298)
@@ -240,34 +238,31 @@ elemental subroutine sw_fairall_6exp_v1_aw(z,aw)
!
! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z
- real(kind=kind_phys),intent(out):: aw
- real(kind=kind_phys) :: fxp
- real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) &
- ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
- real(kind=kind_phys),dimension(9) :: zgamma
- real(kind=kind_phys),dimension(9) :: f_aw
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: aw
+
+ real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/)
+ real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
+ real(kind=kind_phys), dimension(9) :: zgamma
+ real(kind=kind_phys), dimension(9) :: f_aw
!
- if(z>0) then
+ if(z>zero) then
zgamma=z/gamma
- f_aw=(f/z)*((gamma/z)*(1-exp(-zgamma))-exp(-zgamma))
+ f_aw=(f/z)*((gamma/z)*(one-exp(-zgamma))-exp(-zgamma))
aw=sum(f_aw)
-
-! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw
-
+ ! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw
else
- aw=0.
+ aw=zero
endif
!
end subroutine sw_fairall_6exp_v1_aw
!
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes fraction of the solar radiation absorbed by the ocean at the
-!! depth z (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1298) following Paulson and
-!! Simpson (1981) \cite paulson_and_simpson_1981 .
-!>\param[in] z depth (m)
-!>\param[out] sum for convection depth calculation
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes fraction of the solar radiation absorbed by the ocean at the
+ !! depth z (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1298) following Paulson and
+ !! Simpson (1981) \cite paulson_and_simpson_1981 .
+ !>\param[in] z depth (m)
+ !>\param[out] sum for convection depth calculation
elemental subroutine sw_fairall_6exp_v1_sum(z,sum)
!
! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298)
@@ -280,30 +275,30 @@ elemental subroutine sw_fairall_6exp_v1_sum(z,sum)
! sum: for convection depth calculation
!
!
- implicit none
- real(kind=kind_phys),intent(in):: z
- real(kind=kind_phys),intent(out):: sum
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: sum
+
real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/)
- real(kind=kind_phys),dimension(9) :: zgamma
- real(kind=kind_phys),dimension(9) :: f_sum
+ real(kind=kind_phys), dimension(9) :: zgamma
+ real(kind=kind_phys), dimension(9) :: f_sum
!
-! zgamma=z/gamma
-! f_sum=(zgamma/z)*exp(-zgamma)
-! sum=sum(f_sum)
+ ! zgamma=z/gamma
+ ! f_sum=(zgamma/z)*exp(-zgamma)
+ ! sum=sum(f_sum)
- sum=(1.0/gamma(1))*exp(-z/gamma(1))+(1.0/gamma(2))*exp(-z/gamma(2))+(1.0/gamma(3))*exp(-z/gamma(3))+ &
- (1.0/gamma(4))*exp(-z/gamma(4))+(1.0/gamma(5))*exp(-z/gamma(5))+(1.0/gamma(6))*exp(-z/gamma(6))+ &
- (1.0/gamma(7))*exp(-z/gamma(7))+(1.0/gamma(8))*exp(-z/gamma(8))+(1.0/gamma(9))*exp(-z/gamma(9))
+ sum=( one/gamma(1))*exp(-z/gamma(1))+(one/gamma(2))*exp(-z/gamma(2))+(one/gamma(3))*exp(-z/gamma(3))+ &
+ (one/gamma(4))*exp(-z/gamma(4))+(one/gamma(5))*exp(-z/gamma(5))+(one/gamma(6))*exp(-z/gamma(6))+ &
+ (one/gamma(7))*exp(-z/gamma(7))+(one/gamma(8))*exp(-z/gamma(8))+(one/gamma(9))*exp(-z/gamma(9))
!
end subroutine sw_fairall_6exp_v1_sum
!
!======================
-!>\ingroup gfs_nst_main_mod
-!! Solar radiation absorbed by the ocean at the depth z (Fairall et al. (1996)
-!! \cite fairall_et_al_1996, p.1298)
-!!\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$)
-!!\param[in] z depth (m)
-!!\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$)
+ !>\ingroup gfs_nst_main_mod
+ !! Solar radiation absorbed by the ocean at the depth z (Fairall et al. (1996)
+ !! \cite fairall_et_al_1996, p.1298)
+ !!\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$)
+ !!\param[in] z depth (m)
+ !!\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$)
elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z)
!
! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298)
@@ -315,26 +310,25 @@ elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z)
! output:
! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z,f_sol_0
- real(kind=kind_phys),intent(out):: df_sol_z
+ real(kind=kind_phys), intent(in) :: z,f_sol_0
+ real(kind=kind_phys), intent(out) :: df_sol_z
!
- if(z>0) then
- df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(1.-exp(-z/8.e-4)))
+ if(z>zero) then
+ df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(one-exp(-z/8.e-4)))
else
- df_sol_z=0.
+ df_sol_z=zero
endif
!
end subroutine sw_fairall_simple_v1
!
!======================
!
-!>\ingroup gfs_nst_main_mod
-!! solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars (2005)
-!! \cite zeng_and_beljaars_2005 , p.5).
-!>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$)
-!>\param[in] z depth (m)
-!>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$)
+ !>\ingroup gfs_nst_main_mod
+ !! solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars (2005)
+ !! \cite zeng_and_beljaars_2005 , p.5).
+ !>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$)
+ !>\param[in] z depth (m)
+ !>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$)
elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z)
!
! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5)
@@ -346,27 +340,26 @@ elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z)
! output:
! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z,f_sol_0
- real(kind=kind_phys),intent(out):: df_sol_z
+ real(kind=kind_phys), intent(in) :: z,f_sol_0
+ real(kind=kind_phys), intent(out) :: df_sol_z
!
- if(z>0) then
- df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(1.-exp(-z/8.e-4)))
+ if(z>zero) then
+ df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(one-exp(-z/8.e-4)))
else
- df_sol_z=0.
+ df_sol_z=zero
endif
!
end subroutine sw_wick_v1
!
!======================
!
-!>\ingroup gfs_nst_main_mod
-!! This subroutine computes solar radiation absorbed by the ocean at the depth z
-!! (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1301) following
-!! Soloviev and Vershinsky (1982) \cite soloviev_and_vershinsky_1982.
-!>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$)
-!>\param[in] z depth (m)
-!>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$)
+ !>\ingroup gfs_nst_main_mod
+ !! This subroutine computes solar radiation absorbed by the ocean at the depth z
+ !! (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1301) following
+ !! Soloviev and Vershinsky (1982) \cite soloviev_and_vershinsky_1982.
+ !>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$)
+ !>\param[in] z depth (m)
+ !>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$)
elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z)
!
! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301)
@@ -379,25 +372,24 @@ elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z)
! output:
! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z,f_sol_0
- real(kind=kind_phys),intent(out):: df_sol_z
- real(kind=kind_phys),dimension(3) :: f_c
- real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/) &
- ,gamma=(/12.8,0.357,0.014/)
+ real(kind=kind_phys), intent(in) :: z,f_sol_0
+ real(kind=kind_phys), intent(out) :: df_sol_z
+ real(kind=kind_phys), dimension(3) :: f_c
+ real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/)
+ real(kind=kind_phys), dimension(3), parameter :: gamma=(/12.82,0.357,0.014/)
!
- if(z>0) then
- f_c = f*gamma(int(1-exp(-z/gamma)))
- df_sol_z = f_sol_0*(1.0-sum(f_c)/z)
+ if(z>zero) then
+ f_c = f*gamma(int(one-exp(-z/gamma)))
+ df_sol_z = f_sol_0*(one-sum(f_c)/z)
else
- df_sol_z = 0.
+ df_sol_z = zero
endif
!
end subroutine sw_soloviev_3exp_v1
!
!======================
!
-!>\ingroup gfs_nst_main_mod
+ !>\ingroup gfs_nst_main_mod
elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z)
!
! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301)
@@ -410,23 +402,22 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z)
! output:
! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z,f_sol_0
- real(kind=kind_phys),intent(out):: df_sol_z
+ real(kind=kind_phys), intent(in) :: z,f_sol_0
+ real(kind=kind_phys), intent(out) :: df_sol_z
!
- if(z>0) then
- df_sol_z=f_sol_0*(1.0 &
- -(0.28*0.014*(1.-exp(-z/0.014)) &
- +0.27*0.357*(1.-exp(-z/0.357)) &
- +.45*12.82*(1.-exp(-z/12.82)))/z &
+ if(z>zero) then
+ df_sol_z=f_sol_0*(one &
+ -(0.28*0.014*(one-exp(-z/0.014)) &
+ + 0.27*0.357*(one-exp(-z/0.357)) &
+ + 0.45*12.82*(one-exp(-z/12.82)))/z &
)
else
- df_sol_z=0.
+ df_sol_z=zero
endif
!
end subroutine sw_soloviev_3exp_v2
-!>\ingroup gfs_nst_main_mod
+ !>\ingroup gfs_nst_main_mod
elemental subroutine sw_soloviev_3exp_v2_aw(z,aw)
!
! aw = d(fxp)/d(z)
@@ -438,27 +429,26 @@ elemental subroutine sw_soloviev_3exp_v2_aw(z,aw)
! output:
! aw: d(fxp)/d(z)
!
- implicit none
- real(kind=kind_phys),intent(in):: z
- real(kind=kind_phys),intent(out):: aw
- real(kind=kind_phys):: fxp
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: aw
+ real(kind=kind_phys) :: fxp
!
- if(z>0) then
- fxp=(1.0 &
- -(0.28*0.014*(1.-exp(-z/0.014)) &
- + 0.27*0.357*(1.-exp(-z/0.357)) &
- + 0.45*12.82*(1.-exp(-z/12.82)))/z &
+ if(z>zero) then
+ fxp=(one &
+ -(0.28*0.014*(one-exp(-z/0.014)) &
+ + 0.27*0.357*(one-exp(-z/0.357)) &
+ + 0.45*12.82*(one-exp(-z/12.82)))/z &
)
- aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82))
+ aw=one-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82))
else
- aw=0.
+ aw=zero
endif
end subroutine sw_soloviev_3exp_v2_aw
!
!
!======================
!
-!>\ingroup gfs_nst_main_mod
+ !>\ingroup gfs_nst_main_mod
elemental subroutine sw_ohlmann_v1(z,fxp)
!
! fraction of the solar radiation absorbed by the ocean at the depth z
@@ -469,294 +459,276 @@ elemental subroutine sw_ohlmann_v1(z,fxp)
! output:
! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2)
!
- implicit none
- real(kind=kind_phys),intent(in):: z
- real(kind=kind_phys),intent(out):: fxp
+ real(kind=kind_phys), intent(in) :: z
+ real(kind=kind_phys), intent(out) :: fxp
!
- if(z>0) then
- fxp=.065+11.*z-6.6e-5/z*(1.-exp(-z/8.0e-4))
+ if(z>zero) then
+ fxp=.065+11.*z-6.6e-5/z*(one-exp(-z/8.0e-4))
else
- fxp=0.
+ fxp=zero
endif
!
end subroutine sw_ohlmann_v1
!
-!>\ingroup gfs_nst_main_mod
-function grv(lat)
- real(kind=kind_phys) :: lat
- real(kind=kind_phys) :: gamma,c1,c2,c3,c4,pi,phi,x
- gamma=9.7803267715
- c1=0.0052790414
- c2=0.0000232718
- c3=0.0000001262
- c4=0.0000000007
- pi=3.141593
-
- phi=lat*pi/180
- x=sin(phi)
- grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8))
- !print *,'grav=',grv,lat
-end function grv
-
-!>\ingroup gfs_nst_main_mod
-!>This subroutine computes solar time from the julian date.
-subroutine solar_time_from_julian(jday,xlon,soltim)
- !
- ! calculate solar time from the julian date
+ !>\ingroup gfs_nst_main_mod
+ real(kind_phys) function grv(x)
+ real(kind=kind_phys) :: x !< sin(lat)
+ real(kind=kind_phys) :: gamma,c1,c2,c3,c4
+ gamma=9.7803267715
+ c1=0.0052790414
+ c2=0.0000232718
+ c3=0.0000001262
+ c4=0.0000000007
+
+ grv=gamma*(one+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8))
+ end function grv
+
+ !>\ingroup gfs_nst_main_mod
+ !>This subroutine computes solar time from the julian date.
+ subroutine solar_time_from_julian(jday,xlon,soltim)
+ !
+ ! calculate solar time from the julian date
+ !
+ real(kind=kind_phys), intent(in) :: jday
+ real(kind=kind_phys), intent(in) :: xlon
+ real(kind=kind_phys), intent(out) :: soltim
+ real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime
+ !
+ fjd=jday-floor(jday)
+ fjd=jday
+ xhr=floor(fjd*24.0)-sign(12.0,fjd-half)
+ xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-half))*60.0
+ xsec=zero
+ intime=xhr+xmin/60.0+xsec/3600.0+24.0
+ soltim=mod(xlon/15.0+intime,24.0)*3600.0
+ end subroutine solar_time_from_julian
+
!
- implicit none
- real(kind=kind_phys), intent(in) :: jday
- real(kind=kind_phys), intent(in) :: xlon
- real(kind=kind_phys), intent(out) :: soltim
- real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime
- integer :: nn
+ !***********************************************************************
!
- fjd=jday-floor(jday)
- fjd=jday
- xhr=floor(fjd*24.0)-sign(12.0,fjd-0.5)
- xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-0.5))*60
- xsec=0
- intime=xhr+xmin/60.0+xsec/3600.0+24.0
- soltim=mod(xlon/15.0+intime,24.0)*3600.0
-end subroutine solar_time_from_julian
-
-!
-!***********************************************************************
-!
-!>\ingroup gfs_nst_main_mod
-!> This subroutine computes julian day and fraction from year,
-!! month, day and time UTC.
- subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd)
-!fpp$ noconcur r
-!$$$ subprogram documentation block
-! . . . .
-! subprogram: compjd computes julian day and fraction
-! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07
-!
-! abstract: computes julian day and fraction
-! from year, month, day and time utc.
-!
-! program history log:
-! 77-05-06 ray orzol,gfdl
-! 98-05-15 iredell y2k compliance
-!
-! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd)
-! input argument list:
-! jyr - year (4 digits)
-! jmnth - month
-! jday - day
-! jhr - hour
-! jmn - minutes
-! output argument list:
-! jd - julian day.
-! fjd - fraction of the julian day.
-!
-! subprograms called:
-! iw3jdn compute julian day number
-!
-! attributes:
-! language: fortran.
-!
-!$$$
- use machine , only :kind_phys
- implicit none
-!
- integer jyr,jmnth,jday,jhr,jmn,jd
- integer iw3jdn
- real (kind=kind_phys) fjd
- jd=iw3jdn(jyr,jmnth,jday)
- if(jhr.lt.12) then
- jd=jd-1
- fjd=0.5+jhr/24.+jmn/1440.
- else
- fjd=(jhr-12)/24.+jmn/1440.
- endif
- end subroutine compjd
-
-!>\ingroup gfs_nst_main_mod
-!>This subroutine computes dtm (the mean of \f$dT(z)\f$).
- subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm)
-! ===================================================================== !
-! !
-! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) !
-! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool !
-! !
-! usage: !
-! !
-! call get_dtm12 !
-! !
-! inputs: !
-! (xt,xz,dt_cool,zc,z1,z2, !
-! outputs: !
-! dtm) !
-! !
-! program history log: !
-! !
-! 2015 -- xu li createad original code !
-! inputs: !
-! xt - real, heat content in dtl 1 !
-! xz - real, dtl thickness 1 !
-! dt_cool - real, sub-layer cooling amount 1 !
-! zc - sub-layer cooling thickness 1 !
-! z1 - lower bound of depth of sea temperature 1 !
-! z2 - upper bound of depth of sea temperature 1 !
-! outputs: !
-! dtm - mean of dT(z) (z1 to z2) 1 !
-!
- use machine , only : kind_phys
-
- implicit none
-
- real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2
- real (kind=kind_phys), intent(out) :: dtm
-! Local variables
- real (kind=kind_phys) :: dt_warm,dtw,dtc
-
-!
-! get the mean warming in the range of z=z1 to z=z2
-!
- dtw = 0.0
- if ( xt > 0.0 ) then
- dt_warm = (xt+xt)/xz ! Tw(0)
- if ( z1 < z2) then
- if ( z2 < xz ) then
- dtw = dt_warm*(1.0-(z1+z2)/(xz+xz))
- elseif ( z1 < xz .and. z2 >= xz ) then
- dtw = 0.5*(1.0-z1/xz)*dt_warm*(xz-z1)/(z2-z1)
- endif
- elseif ( z1 == z2 ) then
- if ( z1 < xz ) then
- dtw = dt_warm*(1.0-z1/xz)
- endif
+ !>\ingroup gfs_nst_main_mod
+ !> This subroutine computes julian day and fraction from year,
+ !! month, day and time UTC.
+ subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd)
+ !fpp$ noconcur r
+ !$$$ subprogram documentation block
+ ! . . . .
+ ! subprogram: compjd computes julian day and fraction
+ ! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07
+ !
+ ! abstract: computes julian day and fraction
+ ! from year, month, day and time utc.
+ !
+ ! program history log:
+ ! 77-05-06 ray orzol,gfdl
+ ! 98-05-15 iredell y2k compliance
+ !
+ ! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd)
+ ! input argument list:
+ ! jyr - year (4 digits)
+ ! jmnth - month
+ ! jday - day
+ ! jhr - hour
+ ! jmn - minutes
+ ! output argument list:
+ ! jd - julian day.
+ ! fjd - fraction of the julian day.
+ !
+ ! subprograms called:
+ ! iw3jdn compute julian day number
+ !
+ ! attributes:
+ ! language: fortran.
+ !
+ !$$$
+ !
+ integer :: jyr,jmnth,jday,jhr,jmn,jd
+ integer :: iw3jdn
+ real (kind=kind_phys) fjd
+ jd=iw3jdn(jyr,jmnth,jday)
+ if(jhr.lt.12) then
+ jd=jd-1
+ fjd=half+jhr/24.+jmn/1440.
+ else
+ fjd=(jhr-12)/24.+jmn/1440.
endif
- endif
-!
-! get the mean cooling in the range of z=z1 to z=z2
-!
- dtc = 0.0
- if ( zc > 0.0 ) then
- if ( z1 < z2) then
- if ( z2 < zc ) then
- dtc = dt_cool*(1.0-(z1+z2)/(zc+zc))
- elseif ( z1 < zc .and. z2 >= zc ) then
- dtc = 0.5*(1.0-z1/zc)*dt_cool*(zc-z1)/(z2-z1)
- endif
- elseif ( z1 == z2 ) then
- if ( z1 < zc ) then
- dtc = dt_cool*(1.0-z1/zc)
- endif
+ end subroutine compjd
+
+ !>\ingroup gfs_nst_main_mod
+ !>This subroutine computes dtm (the mean of \f$dT(z)\f$).
+ subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm)
+ ! ===================================================================== !
+ ! !
+ ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) !
+ ! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool !
+ ! !
+ ! usage: !
+ ! !
+ ! call get_dtm12 !
+ ! !
+ ! inputs: !
+ ! (xt,xz,dt_cool,zc,z1,z2, !
+ ! outputs: !
+ ! dtm) !
+ ! !
+ ! program history log: !
+ ! !
+ ! 2015 -- xu li createad original code !
+ ! inputs: !
+ ! xt - real, heat content in dtl 1 !
+ ! xz - real, dtl thickness 1 !
+ ! dt_cool - real, sub-layer cooling amount 1 !
+ ! zc - sub-layer cooling thickness 1 !
+ ! z1 - lower bound of depth of sea temperature 1 !
+ ! z2 - upper bound of depth of sea temperature 1 !
+ ! outputs: !
+ ! dtm - mean of dT(z) (z1 to z2) 1 !
+ !
+ real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2
+ real (kind=kind_phys), intent(out) :: dtm
+ ! Local variables
+ real (kind=kind_phys) :: dt_warm,dtw,dtc
+
+ !
+ ! get the mean warming in the range of z=z1 to z=z2
+ !
+ dtw = zero
+ if ( xt > zero ) then
+ dt_warm = (xt+xt)/xz ! Tw(0)
+ if ( z1 < z2) then
+ if ( z2 < xz ) then
+ dtw = dt_warm*(one-(z1+z2)/(xz+xz))
+ elseif ( z1 < xz .and. z2 >= xz ) then
+ dtw = half*(one-z1/xz)*dt_warm*(xz-z1)/(z2-z1)
+ endif
+ elseif ( z1 == z2 ) then
+ if ( z1 < xz ) then
+ dtw = dt_warm*(one-z1/xz)
+ endif
+ endif
endif
- endif
-
-!
-! get the mean T departure from Tf in the range of z=z1 to z=z2
-!
- dtm = dtw - dtc
-
- end subroutine get_dtzm_point
-
-!>\ingroup gfs_nst_main_mod
- subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm)
-!subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm)
-! ===================================================================== !
-! !
-! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) !
-! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool !
-! !
-! usage: !
-! !
-! call get_dtzm_2d !
-! !
-! inputs: !
-! (xt,xz,dt_cool,zc,z1,z2, !
-! outputs: !
-! dtm) !
-! !
-! program history log: !
-! !
-! 2015 -- xu li createad original code !
-! inputs: !
-! xt - real, heat content in dtl 1 !
-! xz - real, dtl thickness 1 !
-! dt_cool - real, sub-layer cooling amount 1 !
-! zc - sub-layer cooling thickness 1 !
-! wet - logical, flag for wet point (ocean or lake) 1 !
-! icy - logical, flag for ice point (ocean or lake) 1 !
-! nx - integer, dimension in x-direction (zonal) 1 !
-! ny - integer, dimension in y-direction (meridional) 1 !
-! z1 - lower bound of depth of sea temperature 1 !
-! z2 - upper bound of depth of sea temperature 1 !
-! nth - integer, num of openmp thread 1 !
-! outputs: !
-! dtm - mean of dT(z) (z1 to z2) 1 !
-!
- use machine , only : kind_phys
-
- implicit none
-
- integer, intent(in) :: nx,ny, nth
- real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc
- logical, dimension(nx,ny), intent(in) :: wet
-! logical, dimension(nx,ny), intent(in) :: wet,icy
- real (kind=kind_phys), intent(in) :: z1,z2
- real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm
-! Local variables
- integer :: i,j
- real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi
- real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0
-
-
-!$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi)
- do j = 1, ny
- do i= 1, nx
-
- dtm(i,j) = zero ! initialize dtm
-
- if ( wet(i,j) ) then
-!
-! get the mean warming in the range of z=z1 to z=z2
-!
- dtw = zero
- if ( xt(i,j) > zero ) then
- xzi = one / xz(i,j)
- dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0)
- if (z1 < z2) then
- if ( z2 < xz(i,j) ) then
- dtw = dt_warm * (one-half*(z1+z2)*xzi)
- elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then
- dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1)
- endif
- elseif (z1 == z2 ) then
- if (z1 < xz(i,j) ) then
- dtw = dt_warm * (one-z1*xzi)
- endif
+ !
+ ! get the mean cooling in the range of z=z1 to z=z2
+ !
+ dtc = zero
+ if ( zc > zero ) then
+ if ( z1 < z2) then
+ if ( z2 < zc ) then
+ dtc = dt_cool*(one-(z1+z2)/(zc+zc))
+ elseif ( z1 < zc .and. z2 >= zc ) then
+ dtc = half*(one-z1/zc)*dt_cool*(zc-z1)/(z2-z1)
endif
- endif
-!
-! get the mean cooling in the range of z=0 to z=zsea
-!
- dtc = zero
- if ( zc(i,j) > zero ) then
- if ( z1 < z2) then
- if ( z2 < zc(i,j) ) then
- dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j)))
- elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then
- dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1)
- endif
- elseif ( z1 == z2 ) then
- if ( z1 < zc(i,j) ) then
- dtc = dt_cool(i,j) * (one-z1/zc(i,j))
- endif
+ elseif ( z1 == z2 ) then
+ if ( z1 < zc ) then
+ dtc = dt_cool*(one-z1/zc)
endif
- endif
-! get the mean T departure from Tf in the range of z=z1 to z=z2
- dtm(i,j) = dtw - dtc
- endif ! if ( wet(i,j)) then
+ endif
+ endif
+
+ !
+ ! get the mean T departure from Tf in the range of z=z1 to z=z2
+ !
+ dtm = dtw - dtc
+
+ end subroutine get_dtzm_point
+
+ !>\ingroup gfs_nst_main_mod
+ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm)
+ !subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm)
+ ! ===================================================================== !
+ ! !
+ ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) !
+ ! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool !
+ ! !
+ ! usage: !
+ ! !
+ ! call get_dtzm_2d !
+ ! !
+ ! inputs: !
+ ! (xt,xz,dt_cool,zc,z1,z2, !
+ ! outputs: !
+ ! dtm) !
+ ! !
+ ! program history log: !
+ ! !
+ ! 2015 -- xu li createad original code !
+ ! inputs: !
+ ! xt - real, heat content in dtl 1 !
+ ! xz - real, dtl thickness 1 !
+ ! dt_cool - real, sub-layer cooling amount 1 !
+ ! zc - sub-layer cooling thickness 1 !
+ ! wet - logical, flag for wet point (ocean or lake) 1 !
+ ! icy - logical, flag for ice point (ocean or lake) 1 !
+ ! nx - integer, dimension in x-direction (zonal) 1 !
+ ! ny - integer, dimension in y-direction (meridional) 1 !
+ ! z1 - lower bound of depth of sea temperature 1 !
+ ! z2 - upper bound of depth of sea temperature 1 !
+ ! nth - integer, num of openmp thread 1 !
+ ! outputs: !
+ ! dtm - mean of dT(z) (z1 to z2) 1 !
+ !
+ integer, intent(in) :: nx,ny, nth
+ real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc
+ logical, dimension(nx,ny), intent(in) :: wet
+ ! logical, dimension(nx,ny), intent(in) :: wet,icy
+ real (kind=kind_phys), intent(in) :: z1,z2
+ real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm
+ ! Local variables
+ integer :: i,j
+ real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi
+
+
+ !$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi)
+ do j = 1, ny
+ do i= 1, nx
+
+ dtm(i,j) = zero ! initialize dtm
+
+ if ( wet(i,j) ) then
+ !
+ ! get the mean warming in the range of z=z1 to z=z2
+ !
+ dtw = zero
+ if ( xt(i,j) > zero ) then
+ xzi = one / xz(i,j)
+ dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0)
+ if (z1 < z2) then
+ if ( z2 < xz(i,j) ) then
+ dtw = dt_warm * (one-half*(z1+z2)*xzi)
+ elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then
+ dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1)
+ endif
+ elseif (z1 == z2 ) then
+ if (z1 < xz(i,j) ) then
+ dtw = dt_warm * (one-z1*xzi)
+ endif
+ endif
+ endif
+ !
+ ! get the mean cooling in the range of z=0 to z=zsea
+ !
+ dtc = zero
+ if ( zc(i,j) > zero ) then
+ if ( z1 < z2) then
+ if ( z2 < zc(i,j) ) then
+ dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j)))
+ elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then
+ dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1)
+ endif
+ elseif ( z1 == z2 ) then
+ if ( z1 < zc(i,j) ) then
+ dtc = dt_cool(i,j) * (one-z1/zc(i,j))
+ endif
+ endif
+ endif
+ ! get the mean T departure from Tf in the range of z=z1 to z=z2
+ dtm(i,j) = dtw - dtc
+ endif ! if ( wet(i,j)) then
+ enddo
enddo
- enddo
-!
+ !
- end subroutine get_dtzm_2d
+ end subroutine get_dtzm_2d
end module module_nst_water_prop
diff --git a/physics/module_ozphys.F90 b/physics/module_ozphys.F90
new file mode 100644
index 000000000..f824736b1
--- /dev/null
+++ b/physics/module_ozphys.F90
@@ -0,0 +1,628 @@
+! #########################################################################################
+!> \section arg_table_module_ozphys Argument table
+!! \htmlinclude module_ozphys.html
+!!
+!
+!> The operational GFS currently parameterizes ozone production and destruction based on
+!! monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval Research Laboratory
+!! through CHEM2D chemistry model (McCormack et al. (2006) \cite mccormack_et_al_2006).
+!!
+!! There are two implementations of this parameterization within this module.
+!! run_o3prog_2006 - Relies on either two/four mean monthly coefficients. This is explained
+!! in (https://doi.org/10.5194/acp-6-4943-2006. See Eq.(4)).
+!! run_o3prog_2015 - Relies on six mean monthly coefficients, specifically for NRL
+!! parameterization and climatological T and O3 are in location 5 and 6 of
+!! the coefficient array.
+!!
+!! Both of these rely on the scheme being setup correctly by invoking the load(), setup(),
+!! and update() procedures prior to calling the run() procedure.
+!!
+!! load_o3prog() - Read in data and load into type ty_ozphys (called once from host)
+!! setup_o3prog() - Create spatial interpolation indices (called once, after model grid is known)
+!! update_o3prog() - Update ozone concentration in time (call in physics loop, before run())
+!! *CAVEAT* Since the radiation is often run at a lower temporal resolution
+!! than the rest of the physics, update_o3prog() needs to be
+!! called before the radiation, which is called before the physics.
+!! For example, within the physics loop:
+!! update_o3prog() -> radiation() -> run_o3prog() -> physics....
+!!
+!! Additionally, there is the functionality to not use interactive ozone, instead reverting
+!! to ozone climatology. In this case, analagous to when using prognostic ozone, there are
+!! update() and run() procedures that need to be called before the radiation.
+!! For example, within the physics loop:
+!! update_o3clim() -> run_o3clim() -> radiation() -> physics...
+!!
+!!\author June 2015 - Shrinivas Moorthi
+!!\modified Sep 2023 - Dustin Swales
+!!
+! #########################################################################################
+module module_ozphys
+ use machine, only : kind_phys
+ use funcphys, only : fpkapx
+ implicit none
+
+ public ty_ozphys
+
+! #########################################################################################
+!> \section arg_table_ty_ozphys Argument Table
+!! \htmlinclude ty_ozphys.html
+!!
+!> Derived type containing data and procedures needed by ozone photochemistry parameterization
+!! *Note* All data field are ordered from surface-to-toa.
+!!
+! #########################################################################################
+ type ty_ozphys
+ ! Prognostic ozone.
+ integer :: nlat !< Number of latitudes.
+ integer :: nlev !< Number of vertical layers.
+ integer :: ntime !< Number of times.
+ integer :: ncf !< Number of coefficients.
+ real(kind_phys), allocatable :: lat(:) !< Latitude.
+ real(kind_phys), allocatable :: pres(:) !< Pressure levels.
+ real(kind_phys), allocatable :: po3(:) !< Natural log pressure of levels.
+ real(kind_phys), allocatable :: time(:) !< Time.
+ real(kind_phys), allocatable :: data(:,:,:,:) !< Ozone forcing data (raw)
+ ! Climotological ozone.
+ integer :: nlatc !< Number of latitudes.
+ integer :: nlevc !< Number of vertical layers.
+ integer :: ntimec !< Number of times.
+ real(kind_phys) :: blatc !< Parameter for ozone climotology
+ real(kind_phys) :: dphiozc !< Parameter for ozone climotology
+ real(kind_phys), allocatable :: pkstr(:) !<
+ real(kind_phys), allocatable :: pstr(:) !<
+ real(kind_phys), allocatable :: datac(:,:,:) !< Ozone climotological data
+ integer :: k1oz !< Lower interpolation index in datac(dim=3), time dim
+ integer :: k2oz !< Upper interpolation index in datac(dim=3), time dim
+ real(kind_phys) :: facoz !< Parameter for ozone climotology
+ contains
+ procedure, public :: load_o3prog
+ procedure, public :: setup_o3prog
+ procedure, public :: update_o3prog
+ procedure, public :: run_o3prog_2015
+ procedure, public :: run_o3prog_2006
+ !
+ procedure, public :: load_o3clim
+ procedure, public :: update_o3clim
+ procedure, public :: run_o3clim
+ end type ty_ozphys
+
+contains
+ ! #########################################################################################
+ ! Procedure (type-bound) for loading data for prognostic ozone.
+ ! #########################################################################################
+ function load_o3prog(this, file, fileID) result (err_message)
+ class(ty_ozphys), intent(inout) :: this
+ integer, intent(in) :: fileID
+ character(len=*), intent(in) :: file
+ character(len=128) :: err_message
+ integer :: i1, i2, i3
+ real(kind=4), dimension(:), allocatable :: lat4, pres4, time4, tempin
+ real(kind=4) :: blatc4
+
+ ! Get dimensions from data file
+ open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian')
+ read (fileID) this%ncf, this%nlat, this%nlev, this%ntime
+ rewind(fileID)
+
+ allocate (this%lat(this%nlat))
+ allocate (this%pres(this%nlev))
+ allocate (this%po3(this%nlev))
+ allocate (this%time(this%ntime+1))
+ allocate (this%data(this%nlat,this%nlev,this%ncf,this%ntime))
+
+ allocate(lat4(this%nlat), pres4(this%nlev), time4(this%ntime+1))
+ read (fileID) this%ncf, this%nlat, this%nlev, this%ntime, lat4, pres4, time4
+
+ ! Store
+ this%pres(:) = pres4(:)
+ this%po3(:) = log(100.0*this%pres(:)) ! from mb to ln(Pa)
+ this%lat(:) = lat4(:)
+ this%time(:) = time4(:)
+ deallocate(lat4, pres4, time4)
+
+ allocate(tempin(this%nlat))
+ do i1=1,this%ntime
+ do i2=1,this%ncf
+ do i3=1,this%nlev
+ read(fileID) tempin
+ this%data(:,i3,i2,i1) = tempin(:)
+ enddo
+ enddo
+ enddo
+ deallocate(tempin)
+ close(fileID)
+
+ end function load_o3prog
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for setting up interpolation indices between data-grid and
+ ! model-grid.
+ ! Called once during initialization
+ ! #########################################################################################
+ subroutine setup_o3prog(this, lat, idx1, idx2, idxh)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: lat(:)
+ integer, intent(out) :: idx1(:), idx2(:)
+ real(kind_phys), intent(out) :: idxh(:)
+ integer :: i,j
+
+ do j=1,size(lat)
+ idx2(j) = this%nlat + 1
+ do i=1,this%nlat
+ if (lat(j) < this%lat(i)) then
+ idx2(j) = i
+ exit
+ endif
+ enddo
+ idx1(j) = max(idx2(j)-1,1)
+ idx2(j) = min(idx2(j),this%nlat)
+ if (idx2(j) .ne. idx1(j)) then
+ idxh(j) = (lat(j) - this%lat(idx1(j))) / (this%lat(idx2(j)) - this%lat(idx1(j)))
+ else
+ idxh(j) = 1.0
+ endif
+ enddo
+
+ end subroutine setup_o3prog
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for updating data used in prognostic ozone scheme.
+ ! #########################################################################################
+ subroutine update_o3prog(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl)
+ class(ty_ozphys), intent(in) :: this
+ integer, intent(in) :: idx1(:), idx2(:)
+ real(kind_phys), intent(in) :: idxh(:)
+ real(kind_phys), intent(in) :: rjday
+ integer, intent(in) :: idxt1, idxt2
+ real(kind_phys), intent(out) :: ozpl(:,:,:)
+ integer :: nc, l, j, j1, j2
+ real(kind_phys) :: tem, tx1, tx2
+
+ tx1 = (this%time(idxt2) - rjday) / (this%time(idxt2) - this%time(idxt1))
+ tx2 = 1.0 - tx1
+
+ do nc=1,this%ncf
+ do l=1,this%nlev
+ do j=1,size(ozpl(:,1,1))
+ j1 = idx1(j)
+ j2 = idx2(j)
+ tem = 1.0 - idxh(j)
+ ozpl(j,l,nc) = tx1*(tem*this%data(j1,l,nc,idxt1)+idxh(j)*this%data(j2,l,nc,idxt1)) &
+ + tx2*(tem*this%data(j1,l,nc,idxt2)+idxh(j)*this%data(j2,l,nc,idxt2))
+ enddo
+ enddo
+ enddo
+
+ end subroutine update_o3prog
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for NRL prognostic ozone (2015).
+ ! #########################################################################################
+ subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, &
+ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: &
+ con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2)
+ real(kind_phys), intent(in) :: &
+ dt ! Model timestep (sec)
+ real(kind_phys), intent(in), dimension(:,:) :: &
+ p, & ! Model Pressure (Pa)
+ t, & ! Model temperature (K)
+ dp ! Model layer thickness (Pa)
+ real(kind_phys), intent(in), dimension(:,:,:) :: &
+ ozpl ! Ozone forcing data
+ real(kind_phys), intent(inout), dimension(:,:) :: &
+ oz ! Ozone concentration updated by physics
+ real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: &
+ do3_dt_prd, & ! Physics tendency: production and loss effect
+ do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect
+ do3_dt_temp, & ! Physics tendency: temperature effect
+ do3_dt_ohoz ! Physics tendency: overhead ozone effect
+
+ integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf
+ logical, dimension(size(p,1)) :: flg
+ real(kind_phys) :: pmax, pmin, tem, temp
+ real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib
+ real(kind_phys), dimension(size(p,1),this%ncf) :: prod
+ real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi
+ real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz
+
+ ! Dimensions
+ nCol = size(p,1)
+ nLev = size(p,2)
+
+ ! Temporaries
+ ozi = oz
+
+ colo3(:,nLev+1) = 0.0
+ coloz(:,nLev+1) = 0.0
+
+ do iLev=nLev,1,-1
+ pmin = 1.0e10
+ pmax = -1.0e10
+
+ do iCol=1,nCol
+ wk1(iCol) = log(p(iCol,iLev))
+ pmin = min(wk1(iCol), pmin)
+ pmax = max(wk1(iCol), pmax)
+ prod(iCol,:) = 0._kind_phys
+ enddo
+ kmax = 1
+ kmin = 1
+ do k=1,this%nlev-1
+ if (pmin < this%po3(k)) kmax = k
+ if (pmax < this%po3(k)) kmin = k
+ enddo
+ !
+ do k=kmin,kmax
+ temp = 1.0 / (this%po3(k) - this%po3(k+1))
+ do iCol=1,nCol
+ flg(iCol) = .false.
+ if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then
+ flg(iCol) = .true.
+ wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp
+ wk3(iCol) = 1.0 - wk2(iCol)
+ endif
+ enddo
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (flg(iCol)) then
+ prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf)
+ endif
+ enddo
+ enddo
+ enddo
+
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (wk1(iCol) < this%po3(this%nlev)) then
+ prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf)
+ endif
+ if (wk1(iCol) >= this%po3(1)) then
+ prod(iCol,iCf) = ozpl(iCol,1,iCf)
+ endif
+ enddo
+ enddo
+ do iCol=1,nCol
+ colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev)*con_1ovg
+ coloz(iCol,iLev) = coloz(iCol,iLev+1) + prod(iCol,6) * dp(iCol,iLev)*con_1ovg
+ prod(iCol,2) = min(prod(iCol,2), 0.0)
+ enddo
+ do iCol=1,nCol
+ ozib(iCol) = ozi(iCol,iLev)
+ tem = prod(iCol,1) - prod(iCol,2) * prod(iCol,6) &
+ + prod(iCol,3) * (t(iCol,iLev) - prod(iCol,5)) &
+ + prod(iCol,4) * (colo3(iCol,iLev)-coloz(iCol,iLev))
+ oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 - prod(iCol,2)*dt)
+ enddo
+
+ ! Diagnostics (optional)
+ if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = (prod(:,1)-prod(:,2)*prod(:,6))*dt
+ if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:))
+ if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3)*(t(:,iLev)-prod(:,5))*dt
+ if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * (colo3(:,iLev)-coloz(:,iLev))*dt
+ enddo
+
+ return
+ end subroutine run_o3prog_2015
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for NRL prognostic ozone (2006).
+ ! #########################################################################################
+ subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, &
+ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: &
+ con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2)
+ real(kind_phys), intent(in) :: &
+ dt ! Model timestep (sec)
+ real(kind_phys), intent(in), dimension(:,:) :: &
+ p, & ! Model Pressure (Pa)
+ t, & ! Model temperature (K)
+ dp ! Model layer thickness (Pa)
+ real(kind_phys), intent(in), dimension(:,:,:) :: &
+ ozpl ! Ozone forcing data
+ real(kind_phys), intent(inout), dimension(:,:) :: &
+ oz ! Ozone concentration updated by physics
+ real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: &
+ do3_dt_prd, & ! Physics tendency: production and loss effect
+ do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect
+ do3_dt_temp, & ! Physics tendency: temperature effect
+ do3_dt_ohoz ! Physics tendency: overhead ozone effect
+
+ ! Locals
+ integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf
+ logical, dimension(size(p,1)) :: flg
+ real(kind_phys) :: pmax, pmin, tem, temp
+ real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib
+ real(kind_phys), dimension(size(p,1),this%ncf) :: prod
+ real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi
+ real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz
+
+ ! Dimensions
+ nCol = size(p,1)
+ nLev = size(p,2)
+
+ ! Temporaries
+ ozi = oz
+
+ !> - Calculate vertical integrated column ozone values.
+ if (this%ncf > 2) then
+ colo3(:,nLev+1) = 0.0
+ do iLev=nLev,1,-1
+ do iCol=1,nCol
+ colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev) * con_1ovg
+ enddo
+ enddo
+ endif
+
+ !> - Apply vertically linear interpolation to the ozone coefficients.
+ do iLev=1,nLev
+ pmin = 1.0e10
+ pmax = -1.0e10
+
+ do iCol=1,nCol
+ wk1(iCol) = log(p(iCol,iLev))
+ pmin = min(wk1(iCol), pmin)
+ pmax = max(wk1(iCol), pmax)
+ prod(iCol,:) = 0._kind_phys
+ enddo
+ kmax = 1
+ kmin = 1
+ do k=1,this%nlev-1
+ if (pmin < this%po3(k)) kmax = k
+ if (pmax < this%po3(k)) kmin = k
+ enddo
+
+ do k=kmin,kmax
+ temp = 1.0 / (this%po3(k) - this%po3(k+1))
+ do iCol=1,nCol
+ flg(iCol) = .false.
+ if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then
+ flg(iCol) = .true.
+ wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp
+ wk3(iCol) = 1.0 - wk2(iCol)
+ endif
+ enddo
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (flg(iCol)) then
+ prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf)
+ endif
+ enddo
+ enddo
+ enddo
+
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (wk1(iCol) < this%po3(this%nlev)) then
+ prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf)
+ endif
+ if (wk1(iCol) >= this%po3(1)) then
+ prod(iCol,iCf) = ozpl(iCol,1,iCf)
+ endif
+ enddo
+ enddo
+
+ if (this%ncf == 2) then
+ do iCol=1,nCol
+ ozib(iCol) = ozi(iCol,iLev)
+ oz(iCol,iLev) = (ozib(iCol) + prod(iCol,1)*dt) / (1.0 + prod(iCol,2)*dt)
+ enddo
+ endif
+
+ if (this%ncf == 4) then
+ do iCol=1,nCol
+ ozib(iCol) = ozi(iCol,iLev)
+ tem = prod(iCol,1) + prod(iCol,3)*t(iCol,iLev) + prod(iCol,4)*colo3(iCol,iLev+1)
+ oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 + prod(iCol,2)*dt)
+ enddo
+ endif
+ ! Diagnostics (optional)
+ if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = prod(:,1)*dt
+ if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:))
+ if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3) * t(:,iLev) * dt
+ if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * colo3(:,iLev) * dt
+
+ enddo
+
+ return
+ end subroutine run_o3prog_2006
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for NRL updating climotological ozone.
+ ! #########################################################################################
+ subroutine run_o3clim(this, lat, prslk, con_pi, oz)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: &
+ con_pi ! Physics constant: Pi
+ real(kind_phys), intent(in), dimension(:) :: &
+ lat ! Grid latitude
+ real(kind_phys), intent(in), dimension(:,:) :: &
+ prslk ! Exner function
+ real(kind_phys), intent(out), dimension(:,:) :: &
+ oz ! Ozone concentration updated by climotology
+
+ integer :: nCol, iCol, nLev, iLev, j, j1, j2, l, ll
+ real(kind_phys) :: elte, deglat, tem, tem1, tem2, tem3, tem4, temp
+ real(kind_phys), allocatable :: o3i(:,:),wk1(:)
+ logical :: top_at_1
+
+ nCol = size(prslk(:,1))
+ nLev = size(prslk(1,:))
+ allocate(o3i(nCol, this%nlevc),wk1(nCol))
+
+ ! What is vertical ordering?
+ top_at_1 = (prslk(1,1) .lt. prslk(1, nLev))
+
+ elte = this%blatc + (this%nlatc-1)*this%dphiozc
+
+ do iCol = 1, nCol
+ deglat = lat(iCol) * 180.0 / con_pi
+ if (deglat > this%blatc .and. deglat < elte) then
+ tem1 = (deglat - this%blatc) / this%dphiozc + 1
+ j1 = tem1
+ j2 = j1 + 1
+ tem1 = tem1 - j1
+ elseif (deglat <= this%blatc) then
+ j1 = 1
+ j2 = 1
+ tem1 = 1.0
+ elseif (deglat >= elte) then
+ j1 = this%nlatc
+ j2 = this%nlatc
+ tem1 = 1.0
+ endif
+
+ tem2 = 1.0 - tem1
+ do j = 1, this%nlevc
+ tem3 = tem2*this%datac(j1,j,this%k1oz) + tem1*this%datac(j2,j,this%k1oz)
+ tem4 = tem2*this%datac(j1,j,this%k2oz) + tem1*this%datac(j2,j,this%k2oz)
+ o3i(iCol,j) = tem4*this%facoz + tem3*(1.0 - this%facoz)
+ enddo
+ enddo
+
+ do iLev = 1, nLev
+ ll = iLev
+ if (.not. top_at_1) ll = nLev - iLev + 1
+
+ do iCol = 1, nCol
+ wk1(iCol) = prslk(iCol,ll)
+ enddo
+
+ do j = 1, this%nlevc-1
+ temp = 1.0 / (this%pkstr(j+1) - this%pkstr(j))
+ do iCol = 1, nCol
+ if (wk1(iCol) > this%pkstr(j) .and. wk1(iCol) <= this%pkstr(j+1)) then
+ tem = (this%pkstr(j+1) - wk1(iCol)) * temp
+ oz(iCol,ll) = tem * o3i(iCol,j) + (1.0 - tem) * o3i(iCol,j+1)
+ endif
+ enddo
+ enddo
+
+ do iCol = 1, nCol
+ if (wk1(iCol) > this%pkstr(this%nlevc)) oz(iCol,ll) = o3i(iCol,this%nlevc)
+ if (wk1(iCol) < this%pkstr(1)) oz(iCol,ll) = o3i(iCol,1)
+ enddo
+ enddo
+
+ return
+ end subroutine run_o3clim
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for loading data for climotological ozone.
+ ! #########################################################################################
+ function load_o3clim(this, file, fileID) result (err_message)
+ class(ty_ozphys), intent(inout) :: this
+ integer, intent(in) :: fileID
+ character(len=*), intent(in) :: file
+ character(len=128) :: err_message
+
+ ! Locals
+ real(kind=4) :: blatc4
+ integer :: iLev, iLat, imo
+ real(kind=4), allocatable :: o3clim4(:,:,:), pstr4(:)
+ integer, allocatable :: imond(:), ilatt(:,:)
+
+ open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian')
+ read (fileID,end=101) this%nlatc, this%nlevc, this%ntimec, blatc4
+101 if (this%nlevc < 10 .or. this%nlevc > 100) then
+ rewind (fileID)
+ this%nlevc = 17
+ this%nlatc = 18
+ this%blatc = -85.0
+ else
+ this%blatc = blatc4
+ endif
+ this%nlat = 2
+ this%nlev = 1
+ this%ntimec = 1
+ this%ncf = 0
+ this%dphiozc = -(this%blatc+this%blatc)/(this%nlatc-1)
+
+ allocate (o3clim4(this%nlatc,this%nlevc,12), pstr4(this%nlevc), imond(12), ilatt(this%nlatc,12) )
+
+ allocate (this%pkstr(this%nlevc), this%pstr(this%nlevc), this%datac(this%nlatc,this%nlevc,12))
+ if ( this%nlevc == 17 ) then ! For the operational ozone climatology
+ do iLev = 1, this%nlevc
+ read (fileID,15) pstr4(iLev)
+15 format(f10.3)
+ enddo
+
+ do imo = 1, 12
+ do iLat = 1, this%nlatc
+ read (fileID,16) imond(imo), ilatt(iLat,imo), (o3clim4(iLat,iLev,imo),iLev=1,10)
+16 format(i2,i4,10f6.2)
+ read (fileID,20) (o3clim4(iLat,iLev,imo),iLev=11,this%nlevc)
+20 format(6x,10f6.2)
+ enddo
+ enddo
+ else ! For newer ozone climatology
+ read (fileID)
+ do iLev = 1, this%nlevc
+ read (fileID) pstr4(iLev)
+ enddo
+
+ do imo = 1, 12
+ do iLev = 1, this%nlevc
+ read (fileID) (o3clim4(iLat,iLev,imo),iLat=1,this%nlatc)
+ enddo
+ enddo
+ endif ! end if_this%nlevc_block
+
+ do imo = 1, 12
+ do iLev = 1, this%nlevc
+ do iLat = 1, this%nlatc
+ this%datac(iLat,iLev,imo) = o3clim4(iLat,iLev,imo) * 1.655e-6
+ enddo
+ enddo
+ enddo
+
+ do iLev = 1, this%nlevc
+ this%pstr(iLev) = pstr4(iLev)
+ this%pkstr(iLev) = fpkapx(this%pstr(iLev)*100.0)
+ enddo
+
+ end function load_o3clim
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for updating temporal interpolation index when using climotological
+ ! ozone
+ ! #########################################################################################
+ subroutine update_o3clim(this, imon, iday, ihour, loz1st)
+ class(ty_ozphys), intent(inout) :: this
+ integer, intent(in) :: imon, iday, ihour
+ logical, intent(in) :: loz1st
+
+ integer :: midmon=15, midm=15, midp=45, id
+ integer, parameter, dimension(13) :: mdays = (/31,28,31,30,31,30,31,31,30,31,30,31,30/)
+ logical :: change
+
+ midmon = mdays(imon)/2 + 1
+ change = loz1st .or. ( (iday==midmon) .and. (ihour==0) )
+
+ if ( change ) then
+ if ( iday < midmon ) then
+ this%k1oz = mod(imon+10, 12) + 1
+ midm = mdays(this%k1oz)/2 + 1
+ this%k2oz = imon
+ midp = mdays(this%k1oz) + midmon
+ else
+ this%k1oz = imon
+ midm = midmon
+ this%k2oz = mod(imon, 12) + 1
+ midp = mdays(this%k2oz)/2 + 1 + mdays(this%k1oz)
+ endif
+ endif
+
+ if (iday < midmon) then
+ id = iday + mdays(this%k1oz)
+ else
+ id = iday
+ endif
+
+ this%facoz = float(id - midm) / float(midp - midm)
+
+ end subroutine update_o3clim
+
+ end module module_ozphys
diff --git a/physics/module_ozphys.meta b/physics/module_ozphys.meta
new file mode 100644
index 000000000..2922d16d7
--- /dev/null
+++ b/physics/module_ozphys.meta
@@ -0,0 +1,24 @@
+[ccpp-table-properties]
+ name = ty_ozphys
+ type = ddt
+ dependencies =
+
+[ccpp-arg-table]
+ name = ty_ozphys
+ type = ddt
+
+########################################################################
+[ccpp-table-properties]
+ name = module_ozphys
+ type = module
+ dependencies = machine.F,funcphys.f90
+
+[ccpp-arg-table]
+ name = module_ozphys
+ type = module
+[ty_ozphys]
+ standard_name = ty_ozphys
+ long_name = definition of type ty_ozphys
+ units = DDT
+ dimensions = ()
+ type = ty_ozphys
\ No newline at end of file
diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90
index eecc5493c..3d847348d 100644
--- a/physics/module_sf_mynn.F90
+++ b/physics/module_sf_mynn.F90
@@ -26,7 +26,7 @@ MODULE module_sf_mynn
!
! LAND only:
! "iz0tlnd" namelist option is used to select the following momentum options:
-! (default) =0: Zilitinkevich (1995); Czil now set to 0.085
+! (default) =0: Zilitinkevich (1995); Czil now set to 0.095
! =1: Czil_new (modified according to Chen & Zhang 2008)
! =2: Modified Yang et al (2002, 2008) - generalized for all landuse
! =3: constant zt = z0/7.4 (original form; Garratt 1992)
@@ -225,7 +225,7 @@ SUBROUTINE SFCLAY_mynn( &
! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0/3.5
! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992)
! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5
-!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.085,
+!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.095,
! (land =1: Czil_new (modified according to Chen & Zhang 2008)
! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse
! =3: constant zt = z0/7.4 (Garratt 1992)
@@ -947,7 +947,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE:
THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K)
THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I))
- if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 360.) &
+ if(THVSK_lnd(I) < 160. .or. THVSK_lnd(I) > 390.) &
print *,'THVSK_lnd(I)',itimestep,i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i)
endif
if(icy(i)) then
@@ -956,7 +956,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE:
THSK_ice(I) = TSK_ice(I)*THCON(I) !(K)
THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K)
- if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 360.) &
+ if(THVSK_ice(I) < 160. .or. THVSK_ice(I) > 390.) &
print *,'THVSK_ice(I)',itimestep,i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i)
endif
if(wet(i)) then
@@ -965,7 +965,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE:
THSK_wat(I) = TSK_wat(I)*THCON(I) !(K)
THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K)
- if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 360.) &
+ if(THVSK_wat(I) < 160. .or. THVSK_wat(I) > 390.) &
print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i)
endif
endif ! flag_iter
@@ -1380,6 +1380,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
else
ZNTstoch_lnd(I) = ZNT_lnd(I)
endif
+ !add limit to prevent ridiculous values of z0 (more than dz/15)
+ ZNTstoch_lnd(I) = min(ZNTstoch_lnd(I), dz8w1d(i)*0.0666_kind_phys)
!--------------------------------------
! LAND
@@ -2604,7 +2606,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,&
IF ( IZ0TLND2 .EQ. 1 ) THEN
CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) )
ELSE
- CZIL = 0.085 !0.075 !0.10
+ CZIL = 0.095 !0.075 !0.10
END IF
Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar))
diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/module_sf_noahmp_glacier.F90
index 6e34c43af..fcbe40a70 100644
--- a/physics/module_sf_noahmp_glacier.F90
+++ b/physics/module_sf_noahmp_glacier.F90
@@ -2652,7 +2652,7 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in
!to obtain equilibrium state of snow in glacier region
- if(sneqv > mwd) then ! 100 mm -> maximum water depth
+ if(sneqv > mwd .and. isnow /= 0) then ! 100 mm -> maximum water depth
bdsnow = snice(0) / dzsnso(0)
snoflow = (sneqv - mwd)
snice(0) = snice(0) - snoflow
diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90
index 86853dabe..6abd59f69 100644
--- a/physics/module_sf_noahmplsm.F90
+++ b/physics/module_sf_noahmplsm.F90
@@ -2116,7 +2116,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in
! thermal properties of soil, snow, lake, and frozen soil
call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
- dt ,snowh ,snice ,snliq , & !in
+ dt ,snowh ,snice ,snliq , shdfac, & !in
smc ,sh2o ,tg ,stc ,ur , & !in
lat ,z0m ,zlvl ,vegtyp , & !in
df ,hcpct ,snicev ,snliqv ,epore , & !out
@@ -2463,7 +2463,7 @@ end subroutine energy
!>\ingroup NoahMP_LSM
subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
- dt ,snowh ,snice ,snliq , & !in
+ dt ,snowh ,snice ,snliq , shdfac, & !in
smc ,sh2o ,tg ,stc ,ur , & !in
lat ,z0m ,zlvl ,vegtyp , & !in
df ,hcpct ,snicev ,snliqv ,epore , & !out
@@ -2480,6 +2480,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso ,
real (kind=kind_phys) , intent(in) :: dt !< time step [s]
real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice !< snow ice mass (kg/m2)
real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq !< snow liq mass (kg/m2)
+ real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0]
real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !< thickness of snow/soil layers [m]
real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !< soil moisture (ice + liq.) [m3/m3]
real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sh2o !< liquid soil moisture [m3/m3]
@@ -2539,6 +2540,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso ,
! not in use because of the separation of the canopy layer from the ground.
! but this may represent the effects of leaf litter (niu comments)
! df1 = df1 * exp (sbeta * shdfac)
+ df(1) = df(1) * exp (sbeta * shdfac)
! compute lake thermal properties
! (no consideration of turbulent mixing for this version)
@@ -4888,7 +4890,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , &
end if
endif ! 4
-! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3
+! use sfc_diag to calculate t2mb and q2b for opt_sfc=1&3
if(opt_diag ==3) then
if(opt_sfc == 1 .or. opt_sfc == 3) then
@@ -5823,7 +5825,8 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl,
elseif (opt_trs == chen09) then
- z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
+! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
+ z0m_out = fveg * z0m + (1.0 - fveg) * z0mg
czil = 10.0 ** (- 0.4 * parameters%hvt)
reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
@@ -5873,7 +5876,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl,
z0h_out = z0m_out
- elseif (opt_trs == tessel) then
+ elseif (opt_trs == chen09 .or. opt_trs == tessel) then
if (vegtyp <= 5) then
z0h_out = z0m_out
@@ -5881,7 +5884,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl,
z0h_out = z0m_out * 0.01
endif
- elseif (opt_trs == blumel99 .or. opt_trs == chen09) then
+ elseif (opt_trs == blumel99) then
reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
if (reyn > 2.0) then
diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90
index 160127e43..b15592052 100644
--- a/physics/module_sf_ruclsm.F90
+++ b/physics/module_sf_ruclsm.F90
@@ -97,6 +97,7 @@ SUBROUTINE LSMRUC(xlat,xlon, &
MAVAIL,CANWAT,VEGFRA, &
ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, &
landusef, nlcat, soilctop, nscat, &
+ smcwlt, smcref, &
QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, &
TBOT,IVGTYP,ISLTYP,XLAND, &
ISWATER,ISICE,XICE,XICE_THRESHOLD, &
@@ -107,6 +108,7 @@ SUBROUTINE LSMRUC(xlat,xlon, &
RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, &
SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, &
SMFR3D,KEEPFR3DFLAG, &
+ add_fire_heat_flux,fire_heat_flux, &
myj,shdmin,shdmax,rdlai2d, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
@@ -239,6 +241,8 @@ SUBROUTINE LSMRUC(xlat,xlon, &
real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN
real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt
real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev
+ LOGICAL, intent(in) :: add_fire_heat_flux
+ real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: fire_heat_flux
LOGICAL, intent(in) :: rdlai2d
real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS
@@ -252,6 +256,8 @@ SUBROUTINE LSMRUC(xlat,xlon, &
SNOALB, &
ALB, &
LAI, &
+ SMCWLT, &
+ SMCREF, &
EMISS, &
EMISBCK, &
MAVAIL, &
@@ -757,6 +763,8 @@ SUBROUTINE LSMRUC(xlat,xlon, &
!-- update background emissivity for land points, can have vegetation mosaic effect
EMISBCK(I,J) = EMISSL(I,J)
+ smcwlt(i,j) = wilt
+ smcref(i,j) = ref
IF (debug_print ) THEN
if(init)then
@@ -961,6 +969,7 @@ SUBROUTINE LSMRUC(xlat,xlon, &
snoalb(i,j),albbck(i,j),lai(i,j), &
hgt(i,j),stdev(i,j), & !new
myj,seaice(i,j),isice, &
+ add_fire_heat_flux,fire_heat_flux(i,j), &
!--- soil fixed fields
QWRTZ, &
rhocs,dqm,qmin,ref, &
@@ -1212,6 +1221,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, &
ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, &
MYJ,SEAICE,ISICE, &
+ add_fire_heat_flux,fire_heat_flux, &
QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields
sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, &
cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & !--- constants
@@ -1256,7 +1266,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
SEAICE, &
RHO, &
QKMS, &
- TKMS
+ TKMS, &
+ fire_heat_flux
+ LOGICAL, INTENT(IN ) :: add_fire_heat_flux
INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP
!--- 2-D variables
@@ -1509,7 +1521,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
ENDIF
if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then
-!*** Update snow density for current temperature (Koren et al. 1999)
+!*** Update snow density for current temperature (Koren et al 1999,doi:10.1029/1999JD900232.)
BSN=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys)
if(bsn*snwe*100._kind_phys.lt.1.e-4_kind_phys) goto 777
XSN=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys)
@@ -1691,7 +1703,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
IF (NEWSN > zero .and. snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN
! new snow
KEEP_SNOW_ALBEDO = one
- !snow_mosaic=0. ! ???
+ ! turn off separate treatment of snow covered and snow-free portions of the grid cell
+ snow_mosaic=0. ! ???
ENDIF
IF (debug_print ) THEN
@@ -1813,6 +1826,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
UPFLUX = T3 *SOILT
XINET = EMISS_snowfree*(GLW-UPFLUX)
RNET = GSWnew + XINET
+ IF ( add_fire_heat_flux .and. fire_heat_flux >0 ) then ! JLS
+ IF (debug_print ) THEN
+ print *,'RNET snow-free, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon
+ ENDIF
+ RNET = RNET + fire_heat_flux
+ ENDIF
+
IF (debug_print ) THEN
print *,'Fractional snow - snowfrac=',snowfrac
print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet
@@ -1837,7 +1857,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
ilands = ivgtyp
- CALL SOIL(debug_print,xlat,xlon, &
+ CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,&
!--- input variables
i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, &
@@ -1933,6 +1953,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
if (SEAICE .LT. 0.5_kind_phys) then
! LAND
+ IF ( add_fire_heat_flux .and. fire_heat_flux>0 ) then ! JLS
+ IF (debug_print ) THEN
+ print *,'RNET snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon
+ ENDIF
+ RNET = RNET + fire_heat_flux
+ ENDIF
if(snow_mosaic==one)then
snfr=one
else
@@ -2051,7 +2077,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
hfx = hfxs*(one-snowfrac) + hfx*snowfrac
s = ss*(one-snowfrac) + s*snowfrac
evapl = evapls*(one-snowfrac)
- sublim = sublim*snowfrac
prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac
fltot = fltots*(one-snowfrac) + fltot*snowfrac
ALB = MAX(keep_snow_albedo*alb, &
@@ -2063,10 +2088,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac
runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac
- smelt = smelt * snowfrac
- snoh = snoh * snowfrac
- snflx = snflx * snowfrac
- snom = snom * snowfrac
mavail = mavails*(one-snowfrac) + one*snowfrac
infiltr = infiltrs*(one-snowfrac) + infiltr*snowfrac
@@ -2090,7 +2111,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
qvg = qvgs*(one-snowfrac) + qvg*snowfrac
qsg = qsgs*(one-snowfrac) + qsg*snowfrac
qcg = qcgs*(one-snowfrac) + qcg*snowfrac
- sublim = eeta*snowfrac
+ sublim = eeta
eeta = eetas*(one-snowfrac) + eeta*snowfrac
qfx = qfxs*(one-snowfrac) + qfx*snowfrac
hfx = hfxs*(one-snowfrac) + hfx*snowfrac
@@ -2104,10 +2125,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
(emissn - emiss_snowfree) * snowfrac), emissn))
runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac
runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac
- smelt = smelt * snowfrac
- snoh = snoh * snowfrac
- snflx = snflx * snowfrac
- snom = snom * snowfrac
IF (debug_print ) THEN
print *,'SOILT combined on ice', soilt
ENDIF
@@ -2190,15 +2207,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
IF (debug_print ) then
!if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
print *,'Snowfallac xlat, xlon',xlat,xlon
- print *,'newsn,rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio
+ print *,'newsn [m],rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio
print *,'Time-step newsn depth [m], swe [m]',newsn,newsn*rhonewsn
print *,'Time-step smelt: swe [m]' ,smelt*delt
print *,'Time-step sublim: swe,[kg m-2]',sublim*delt
endif
- snowfallac = snowfallac + max(zero,(newsn*rhonewsn - & ! source of snow (swe) [m]
- (smelt+sublim*1.e-3_kind_phys)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m]
- /rhonewsn)*rhowater ! snow accumulation in snow depth [mm]
+ snowfallac = snowfallac + newsn * 1.e3_kind_phys ! accumulated snow depth [mm], using variable snow density
IF (debug_print ) THEN
!if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
@@ -2223,7 +2238,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia
if(SEAICE .LT. 0.5_kind_phys) then
! LAND
- CALL SOIL(debug_print,xlat,xlon, &
+ IF ( add_fire_heat_flux .and. fire_heat_flux>0) then ! JLS
+ IF (debug_print ) THEN
+ print *,'RNET no snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon
+ endif
+ RNET = RNET + fire_heat_flux
+ ENDIF
+
+ CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,&
!--- input variables
i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, &
@@ -2316,7 +2338,7 @@ END FUNCTION QSN
!>\ingroup lsm_ruc_group
!> This subroutine calculates energy and moisture budget for vegetated surfaces
!! without snow, heat diffusion and Richards eqns in soil.
- SUBROUTINE SOIL (debug_print,xlat,xlon, &
+ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,&
i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables
PRCPMS,RAINF,PATM,QVATM,QCATM, &
GLW,GSW,GSWin,EMISS,RNET, &
@@ -2398,7 +2420,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, &
INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
nddzs !nddzs=2*(nzs-2)
INTEGER, INTENT(IN ) :: i,j,iland,isoil
- real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon
+ real (kind_phys), INTENT(IN ) :: DELT,CONFLX
+ real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon
LOGICAL, INTENT(IN ) :: myj
!--- 3-D Atmospheric variables
real (kind_phys), &
@@ -2622,6 +2645,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, &
! hydraulic condeuctivities
!******************************************************************
CALL SOILPROP( debug_print, &
+ xlat, xlon, testptlat, testptlon, &
!--- input variables
nzs,fwsat,lwsat,tav,keepfr, &
soilmois,soiliqw,soilice, &
@@ -2657,6 +2681,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, &
! TRANSF computes transpiration function
!**************************************************************
CALL TRANSF(debug_print, &
+ xlat, xlon, testptlat, testptlon, &
!--- input variables
nzs,nroot,soiliqw,tabs,lai,gswin, &
!--- soil fixed fields
@@ -2714,7 +2739,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, &
! SOILTEMP soilves heat budget and diffusion eqn. in soil
!**************************************************************
- CALL SOILTEMP(debug_print,xlat,xlon, &
+ CALL SOILTEMP(debug_print,xlat,xlon,testptlat,testptlon,&
!--- input variables
i,j,iland,isoil, &
delt,ktau,conflx,nzs,nddzs,nroot, &
@@ -2784,6 +2809,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, &
! and Richards eqn.
!*************************************************************************
CALL SOILMOIST (debug_print, &
+ xlat, xlon, testptlat, testptlon, &
!-- input
delt,nzs,nddzs,DTDZS,DTDZS2,RIW, &
zsmain,zshalf,diffu,hydro, &
@@ -3578,6 +3604,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, &
! hydraulic condeuctivities
!******************************************************************
CALL SOILPROP(debug_print, &
+ xlat, xlon, testptlat, testptlon, &
!--- input variables
nzs,fwsat,lwsat,tav,keepfr, &
soilmois,soiliqw,soilice, &
@@ -3628,6 +3655,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, &
! TRANSF computes transpiration function
!**************************************************************
CALL TRANSF(debug_print, &
+ xlat, xlon, testptlat, testptlon, &
!--- input variables
nzs,nroot,soiliqw,tabs,lai,gswin, &
!--- soil fixed fields
@@ -3723,7 +3751,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, &
!--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28)
! AND TSO,ETA PROFILES
!*************************************************************************
- CALL SOILMOIST (debug_print, &
+ CALL SOILMOIST (debug_print,xlat,xlon,testptlat,testptlon,&
!-- input
delt,nzs,nddzs,DTDZS,DTDZS2,RIW, &
zsmain,zshalf,diffu,hydro, &
@@ -4046,35 +4074,25 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, &
RHOnewCSN=sheatsn * RHOnewSN
if(isncond_opt == 1) then
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
- !-- some areas with large snow depth have unrealistically
- !-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
- !-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
- else
- !-- old version thdifsn = 0.265/RHOCSN
- THDIFSN = 0.265_kind_phys/RHOCSN
- endif
+ !-- old version thdifsn = 0.265/RHOCSN
+ THDIFSN = 0.265_kind_phys/RHOCSN
else
!-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
!-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
fact = one
if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then
keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
- !-- fact is added by tgs based on 4 Jan 2017 testing
- fact = 5._kind_phys
else
keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
- fact = 2._kind_phys
endif
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
+ if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
!-- some areas with large snow depth have unrealistically
!-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
+ !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
+ !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
!-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
+ thdifsn = 4.431718e-7_kind_phys
else
thdifsn = keff/rhocsn * fact
endif
@@ -4510,35 +4528,25 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, &
RHOCSN=sheatsn* RHOSN
if(isncond_opt == 1) then
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
- !-- some areas with large snow depth have unrealistically
- !-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
- !-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
- else
- !-- old version thdifsn = 0.265/RHOCSN
- THDIFSN = 0.265_kind_phys/RHOCSN
- endif
+ !-- old version thdifsn = 0.265/RHOCSN
+ THDIFSN = 0.265_kind_phys/RHOCSN
else
!-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
!-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
fact = one
if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then
keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
- !-- fact is added by tgs based on 4 Jan 2017 testing
- fact = 5._kind_phys
else
keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
- fact = 2._kind_phys
endif
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
+ if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
!-- some areas with large snow depth have unrealistically
!-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
+ !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
+ !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
!-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
+ thdifsn = 4.431718e-7_kind_phys
else
thdifsn = keff/rhocsn * fact
endif
@@ -4679,7 +4687,7 @@ END SUBROUTINE SNOWSEAICE
!>\ingroup lsm_ruc_group
!> This subroutine solves energy budget equation and heat diffusion
!! equation.
- SUBROUTINE SOILTEMP( debug_print,xlat,xlon, &
+ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,&
i,j,iland,isoil, & !--- input variables
delt,ktau,conflx,nzs,nddzs,nroot, &
PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, &
@@ -4749,7 +4757,8 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, &
INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
nddzs !nddzs=2*(nzs-2)
INTEGER, INTENT(IN ) :: i,j,iland,isoil
- real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon
+ real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF
+ real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon
real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM
!--- 3-D Atmospheric variables
real (kind_phys), &
@@ -5193,27 +5202,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, &
RHOCSN=sheatsn* RHOSN
RHOnewCSN=sheatsn* RHOnewSN
if(isncond_opt == 1) then
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
- !-- some areas with large snow depth have unrealistically
- !-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
- !-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
- else
- !-- old version thdifsn = 0.265/RHOCSN
- THDIFSN = 0.265_kind_phys/RHOCSN
- endif
+ !-- old version thdifsn = 0.265/RHOCSN
+ THDIFSN = 0.265_kind_phys/RHOCSN
else
!-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
!-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
fact = one
if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then
keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
- !-- fact is added by tgs based on 4 Jan 2017 testing
- fact = 5._kind_phys
else
keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
- fact = 2._kind_phys
if(debug_print) then
print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact
print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn
@@ -5223,12 +5221,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, &
print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff
endif
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
+ if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
!-- some areas with large snow depth have unrealistically
!-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
+ !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
+ !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
!-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
+ thdifsn = 4.431718e-7_kind_phys
else
thdifsn = keff/rhocsn * fact
endif
@@ -5587,7 +5586,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, &
nmelt = 1
soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT
QSG=min(QSG, QSN(soiltfrac,TBQ)/PP)
- qvg=qsg
+ qvg=snowfrac*qsg+(one-snowfrac)*qvg
T3 = STBOLT*TN*TN*TN
UPFLUX = T3 * 0.5_kind_phys*(TN + SOILTfrac)
XINET = EMISS*(GLW-UPFLUX)
@@ -5776,27 +5775,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, &
RHOCSN=sheatsn* RHOSN
if(isncond_opt == 1) then
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
- !-- some areas with large snow depth have unrealistically
- !-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
- !-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
- else
- !-- old version thdifsn = 0.265/RHOCSN
- THDIFSN = 0.265_kind_phys/RHOCSN
- endif
+ !-- old version thdifsn = 0.265/RHOCSN
+ THDIFSN = 0.265_kind_phys/RHOCSN
else
!-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
!-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
fact = one
if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then
keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
- !-- fact is added by tgs based on 4 Jan 2017 testing
- fact = 5._kind_phys
else
keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
- fact = 2._kind_phys
if(debug_print) then
print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff
print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn
@@ -5807,12 +5795,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, &
xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact
endif
- if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then
+ if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
!-- some areas with large snow depth have unrealistically
!-- low snow density (in the Rockie's with snow depth > 1 m).
- !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs.
+ !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
+ !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
!-- In future a better compaction scheme is needed for these areas.
- thdifsn = 2.5e-6_kind_phys
+ thdifsn = 4.431718e-7_kind_phys
else
thdifsn = keff/rhocsn * fact
endif
@@ -5959,6 +5948,7 @@ END SUBROUTINE SNOWTEMP
!! This subroutine solves moisture budget and computes soil moisture
!! and surface and sub-surface runoffs.
SUBROUTINE SOILMOIST ( debug_print, &
+ xlat, xlon, testptlat, testptlon, &
DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & !--- input parameters
ZSMAIN,ZSHALF,DIFFU,HYDRO, &
QSG,QVG,QCG,QCATM,QVATM,PRCP, &
@@ -6012,6 +6002,7 @@ SUBROUTINE SOILMOIST ( debug_print, &
!--- input variables
LOGICAL, INTENT(IN ) :: debug_print
real (kind_phys), INTENT(IN ) :: DELT
+ real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon
INTEGER, INTENT(IN ) :: NZS,NDDZS
! input variables
@@ -6099,8 +6090,12 @@ SUBROUTINE SOILMOIST ( debug_print, &
DENOM=one+X2+X4-Q2*COSMC(K)
COSMC(K+1)=Q4/DENOM
IF (debug_print ) THEN
- print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' &
- ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' &
+ ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k
+ endif
ENDIF
RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) &
+TRANSP(KN) &
@@ -6131,8 +6126,12 @@ SUBROUTINE SOILMOIST ( debug_print, &
TOTLIQ=PRCP-DRIP/DELT-(one-VEGFRAC)*DEW*RAS-SMELT
IF (debug_print ) THEN
-print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', &
- UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', &
+ UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT
+ endif
ENDIF
FLX=TOTLIQ
@@ -6175,7 +6174,7 @@ SUBROUTINE SOILMOIST ( debug_print, &
INFMAX1 = zero
ENDIF
IF (debug_print ) THEN
- print *,'INFMAX1 before frozen part',INFMAX1
+ print *,'INFMAX1 before frozen part',INFMAX1
ENDIF
! ----------- FROZEN GROUND VERSION --------------------------
@@ -6209,8 +6208,8 @@ SUBROUTINE SOILMOIST ( debug_print, &
INFMAX = MAX(INFMAX1,HYDRO(1)*SOILMOIS(1))
INFMAX = MIN(INFMAX, -TOTLIQ)
IF (debug_print ) THEN
-print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', &
- INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ
+ print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', &
+ INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ
ENDIF
!----
IF (-TOTLIQ.GT.INFMAX)THEN
@@ -6260,8 +6259,12 @@ SUBROUTINE SOILMOIST ( debug_print, &
END IF
IF (debug_print ) THEN
- print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw
- print *,'COSMC,RHSMC',COSMC,RHSMC
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw
+ print *,'COSMC,RHSMC',COSMC,RHSMC
+ endif
ENDIF
!--- FINAL SOLUTION FOR SOILMOIS
! DO K=2,NZS1
@@ -6287,7 +6290,11 @@ SUBROUTINE SOILMOIST ( debug_print, &
END IF
END DO
IF (debug_print ) THEN
- print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw
+ endif
ENDIF
MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac)))
@@ -6299,6 +6306,7 @@ END SUBROUTINE SOILMOIST
!! This subroutine computes thermal diffusivity, and diffusional and
!! hydraulic condeuctivities in soil.
SUBROUTINE SOILPROP( debug_print, &
+ xlat, xlon, testptlat, testptlon, &
nzs,fwsat,lwsat,tav,keepfr, & !--- input variables
soilmois,soiliqw,soilice, &
soilmoism,soiliqwm,soilicem, &
@@ -6332,6 +6340,8 @@ SUBROUTINE SOILPROP( debug_print, &
!--- soil properties
LOGICAL, INTENT(IN ) :: debug_print
INTEGER, INTENT(IN ) :: NZS
+ real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon
+
real (kind_phys) , &
INTENT(IN ) :: RHOCS, &
BCLH, &
@@ -6508,6 +6518,7 @@ END SUBROUTINE SOILPROP
!> This subroutine solves the transpiration function (EQs. 18,19 in
!! Smirnova et al.(1997) \cite Smirnova_1997)
SUBROUTINE TRANSF( debug_print, &
+ xlat,xlon,testptlat,testptlon, &
nzs,nroot,soiliqw,tabs,lai,gswin, & !--- input variables
dqm,qmin,ref,wilt,zshalf,pc,iland, & !--- soil fixed fields
tranf,transum) !--- output variables
@@ -6528,6 +6539,7 @@ SUBROUTINE TRANSF( debug_print, &
LOGICAL, INTENT(IN ) :: debug_print
INTEGER, INTENT(IN ) :: nroot,nzs,iland
+ real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon
real (kind_phys) , &
INTENT(IN ) :: GSWin, TABS, lai
@@ -6574,7 +6586,7 @@ SUBROUTINE TRANSF( debug_print, &
ap4=59.656_kind_phys
gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4
if(totliq.ge.ref) gx=one
- if(totliq.le.zero) gx=zero
+ if(totliq.le.wilt) gx=zero
if(gx.gt.one) gx=one
if(gx.lt.zero) gx=zero
DID=zshalf(2)
@@ -6587,7 +6599,7 @@ SUBROUTINE TRANSF( debug_print, &
TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID
ENDIF
!-- uncomment next line for non-linear root distribution
- TRANF(1)=part(1)
+ !TRANF(1)=part(1)
DO K=2,NROOT
totliq=soiliqw(k)+qmin
@@ -6597,7 +6609,7 @@ SUBROUTINE TRANSF( debug_print, &
sm4=sm3*sm1
gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4
if(totliq.ge.ref) gx=one
- if(totliq.le.zero) gx=zero
+ if(totliq.le.wilt) gx=zero
if(gx.gt.one) gx=one
if(gx.lt.zero) gx=zero
DID=zshalf(K+1)-zshalf(K)
@@ -6611,8 +6623,16 @@ SUBROUTINE TRANSF( debug_print, &
/(REF-WILT)*DID
ENDIF
!-- uncomment next line for non-linear root distribution
-! TRANF(k)=part(k)
+ !TRANF(k)=part(k)
END DO
+ IF (debug_print ) THEN
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'soiliqw =',soiliqw,'wilt=',wilt,'qmin= ',qmin
+ print *,'tranf = ',tranf
+ endif
+ ENDIF
! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013)
if(lai > 4._kind_phys) then
@@ -6624,7 +6644,11 @@ SUBROUTINE TRANSF( debug_print, &
! pctot=min(0.8,max(pc,pc*lai))
endif
IF ( debug_print ) THEN
- print *,'pctot,lai,pc',pctot,lai,pc
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'pctot,lai,pc',pctot,lai,pc
+ endif
ENDIF
!---
!--- air temperature function
@@ -6634,9 +6658,6 @@ SUBROUTINE TRANSF( debug_print, &
ELSE
FTEM = one / (one + EXP(0.5_kind_phys * (TABS - 314.0_kind_phys)))
ENDIF
- IF ( debug_print ) THEN
- print *,'tabs,ftem',tabs,ftem
- ENDIF
!--- incoming solar function
cmin = one/rsmax_data
cmax = one/rstbl(iland)
@@ -6659,27 +6680,33 @@ SUBROUTINE TRANSF( debug_print, &
else
fsol = one
endif
- IF ( debug_print ) THEN
- print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol
- ENDIF
!--- total conductance
totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax
IF ( debug_print ) THEN
- print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' &
- ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol',GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol
+ print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' &
+ ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd
+ endif
ENDIF
!-- TRANSUM - total for the rooting zone
transum=zero
DO K=1,NROOT
! linear root distribution
- TRANF(k)=max(cmin,TRANF(k)*totcnd)
+ TRANF(k)=max(zero,TRANF(k)*totcnd)
transum=transum+tranf(k)
END DO
IF ( debug_print ) THEN
- print *,'transum,TRANF',transum,tranf
- endif
+ if (abs(xlat-testptlat).lt.0.05 .and. &
+ abs(xlon-testptlon).lt.0.05)then
+ print *,'xlat,xlon=',xlat,xlon
+ print *,'transum,TRANF',transum,tranf
+ endif
+ ENDIF
!-----------------------------------------------------------------
END SUBROUTINE TRANSF
diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90
index 59ca877fa..e79376709 100644
--- a/physics/mp_nssl.F90
+++ b/physics/mp_nssl.F90
@@ -26,13 +26,13 @@ module mp_nssl
!! \htmlinclude mp_nssl_init.html
!!
subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
- mpirank, mpiroot, &
- con_g, con_rd, con_cp, con_rv, &
- con_t0c, con_cliq, con_csol, con_eps, &
- imp_physics, imp_physics_nssl, &
- nssl_cccn, nssl_alphah, nssl_alphahl, &
- nssl_alphar, nssl_ehw0, nssl_ehlw0, &
- nssl_ccn_on, nssl_hail_on, nssl_invertccn )
+ mpirank, mpiroot, &
+ con_g, con_rd, con_cp, con_rv, &
+ con_t0c, con_cliq, con_csol, con_eps, &
+ imp_physics, imp_physics_nssl, &
+ nssl_cccn, nssl_alphah, nssl_alphahl, &
+ nssl_alphar, nssl_ehw0, nssl_ehlw0, &
+ nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment )
use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const
@@ -53,13 +53,13 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
integer, intent(in) :: imp_physics
integer, intent(in) :: imp_physics_nssl
real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl
- real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn
+ real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment
! Local variables: dimensions used in nssl_init
integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k
real :: nssl_params(20)
- integer :: ihailv
+ integer :: ihailv,ipc
! Initialize the CCPP error handling variables
@@ -104,9 +104,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
nssl_params(:) = 0.0
- nssl_params(1) = nssl_cccn
- nssl_params(2) = nssl_alphah
- nssl_params(3) = nssl_alphahl
+ ! nssl_params(1) = nssl_cccn ! use direct interface instead
+ ! nssl_params(2) = nssl_alphah ! use direct interface instead
+ ! nssl_params(3) = nssl_alphahl ! use direct interface instead
nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment
nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment
nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment
@@ -114,10 +114,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
nssl_params(8) = 500. ! nssl_rho_qh
nssl_params(9) = 800. ! nssl_rho_qhl
nssl_params(10) = 100. ! nssl_rho_qs
- nssl_params(11) = 0 ! nssl_ipelec_tmp
- nssl_params(12) = 11 ! nssl_isaund
- nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off
- nssl_params(15) = nssl_alphar
nssl_qccn = nssl_cccn/1.225
! if (mpirank==mpiroot) then
@@ -129,10 +125,21 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
ELSE
ihailv = -1
ENDIF
+
+ IF ( nssl_3moment ) THEN
+ ipc = 8
+ ELSE
+ ipc = 5
+ ENDIF
! write(0,*) 'call nssl_2mom_init'
- CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, &
- ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot)
+ CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, &
+ ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, &
+ nssl_alphar=nssl_alphar, &
+ nssl_alphah=nssl_alphah, &
+ nssl_alphahl=nssl_alphahl, &
+ nssl_cccn=nssl_cccn, &
+ errflg=errflg,myrank=mpirank,mpiroot=mpiroot)
! For restart runs, the init is done here
if (restart) then
@@ -158,17 +165,18 @@ end subroutine mp_nssl_init
!! \htmlinclude mp_nssl_run.html
!!
subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
-! spechum, cccn, qc, qr, qi, qs, qh, qhl, &
- spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, &
- ccw, crw, cci, csw, chw, chl, vh, vhl, &
- tgrs, prslk, prsl, phii, omega, dtp, &
- prcp, rain, graupel, ice, snow, sr, &
+ spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, &
+ ccw, crw, cci, csw, chw, chl, vh, vhl, &
+ zrw, zhw, zhl, &
+ tgrs, prslk, prsl, phii, omega, dtp, &
+ prcp, rain, graupel, ice, snow, sr, &
refl_10cm, do_radar_ref, first_time_step, restart, &
- re_cloud, re_ice, re_snow, re_rain, &
- nleffr, nieffr, nseffr, nreffr, &
- imp_physics, convert_dry_rho, &
- imp_physics_nssl, nssl_ccn_on, &
- nssl_hail_on, nssl_invertccn, ntccn, ntccna, &
+ re_cloud, re_ice, re_snow, re_rain, &
+ nleffr, nieffr, nseffr, nreffr, &
+ imp_physics, convert_dry_rho, &
+ imp_physics_nssl, nssl_ccn_on, &
+ nssl_hail_on, nssl_invertccn, nssl_3moment, &
+ ntccn, ntccna, &
errflg, errmsg)
use module_mp_nssl_2mom, only: calcnfromq, na
@@ -197,6 +205,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number
real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume
real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume
+ real(kind_phys), intent(inout) :: zrw(:,:) !(1:ncol,1:nlev) rain reflectivity
+ real(kind_phys), intent(inout) :: zhw(:,:) !(1:ncol,1:nlev) graupel reflectivity
+ real(kind_phys), intent(inout) :: zhl(:,:) !(1:ncol,1:nlev) hail reflectivity
! State variables and timestep information
real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev)
real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev)
@@ -223,7 +234,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
integer, intent(in) :: nleffr, nieffr, nseffr, nreffr
integer, intent(in) :: imp_physics
integer, intent(in) :: imp_physics_nssl
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment
integer, intent(in) :: ntccn, ntccna
integer, intent(out) :: errflg
@@ -256,6 +267,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
! create temporaries for hail in case it does not exist
!real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio)
real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio)
+ real(kind_phys) :: zrw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
+ real(kind_phys) :: zhw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
+ real(kind_phys) :: zhl_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
! Vertical velocity and level width
real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1
real(kind_phys) :: dz(1:ncol,1:nlev) !< m
@@ -342,10 +356,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ns_mp = csw/(1.0_kind_phys-spechum)
nh_mp = chw/(1.0_kind_phys-spechum)
vh_mp = vh/(1.0_kind_phys-spechum)
+ IF ( nssl_3moment ) THEN
+ zrw_mp = zrw/(1.0_kind_phys-spechum)
+ zhw_mp = zhw/(1.0_kind_phys-spechum)
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl_mp = qhl/(1.0_kind_phys-spechum)
nhl_mp = chl/(1.0_kind_phys-spechum)
vhl_mp = vhl/(1.0_kind_phys-spechum)
+ IF ( nssl_3moment ) THEN
+ zhl_mp = zhl/(1.0_kind_phys-spechum)
+ ENDIF
ENDIF
ELSE
! qv_mp = spechum ! /(1.0_kind_phys-spechum)
@@ -361,10 +382,18 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ni_mp = cci
ns_mp = csw
nh_mp = chw
+ vh_mp = vh
+ IF ( nssl_3moment ) THEN
+ zrw_mp = zrw
+ zhw_mp = zhw
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl_mp = qhl ! /(1.0_kind_phys-spechum)
nhl_mp = chl
vhl_mp = vhl
+ IF ( nssl_3moment ) THEN
+ zhl_mp = zhl
+ ENDIF
ENDIF
ENDIF
@@ -572,110 +601,114 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
IF ( nssl_ccn_on ) THEN
-
- CALL nssl_2mom_driver( &
- ITIMESTEP=itimestep, &
- ! TH=th, &
- tt=tgrs, &
- QV=qv_mp, &
- QC=qc_mp, &
- QR=qr_mp, &
- QI=qi_mp, &
- QS=qs_mp, &
- QH=qh_mp, &
- QHL=qhl_mp, &
- CCW=nc_mp, &
- CRW=nr_mp, &
- CCI=ni_mp, &
- CSW=ns_mp, &
- CHW=nh_mp, &
- CHL=nhl_mp, &
- VHW=vh_mp, &
- VHL=vhl_mp, &
- cn=cn_mp, &
-! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
- cna=cna_mp, f_cna=.false. , &
- PII=prslk, &
- P=prsl, &
- W=w, &
- DZ=dz, &
- DTP=dtptmp, &
- DN=rho, &
- rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
- snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
-! icenc=ice_mp, icencv=delta_ice_mp, &
- GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, &
- dbz = refl_10cm, &
-! nssl_progn=.false., &
- diagflag = diagflag, &
- errmsg=errmsg,errflg=errflg, &
- re_cloud=re_cloud_mp, &
- re_ice=re_ice_mp, &
- re_snow=re_snow_mp, &
- re_rain=re_rain_mp, &
- has_reqc=has_reqc, & ! ala G. Thompson
- has_reqi=has_reqi, & ! ala G. Thompson
- has_reqs=has_reqs, & ! ala G. Thompson
- has_reqr=has_reqr, &
+ CALL nssl_2mom_driver( &
+ ITIMESTEP=itimestep, &
+ ! TH=th, &
+ tt=tgrs, &
+ QV=qv_mp, &
+ QC=qc_mp, &
+ QR=qr_mp, &
+ QI=qi_mp, &
+ QS=qs_mp, &
+ QH=qh_mp, &
+ QHL=qhl_mp, &
+ CCW=nc_mp, &
+ CRW=nr_mp, &
+ CCI=ni_mp, &
+ CSW=ns_mp, &
+ CHW=nh_mp, &
+ CHL=nhl_mp, &
+ VHW=vh_mp, &
+ VHL=vhl_mp, &
+ cn=cn_mp, &
+ ZRW=zrw_mp, &
+ ZHW=zhw_mp, &
+ ZHL=zhl_mp, &
+! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
+ cna=cna_mp, f_cna=.false. , &
+ PII=prslk, &
+ P=prsl, &
+ W=w, &
+ DZ=dz, &
+ DTP=dtptmp, &
+ DN=rho, &
+ rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
+ snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
+ GRPLNC=xgraupel_mp, &
+ GRPLNCV=xdelta_graupel_mp, &
+ sr=sr, &
+ dbz = refl_10cm, &
+ diagflag = diagflag, &
+ errmsg=errmsg,errflg=errflg, &
+ re_cloud=re_cloud_mp, &
+ re_ice=re_ice_mp, &
+ re_snow=re_snow_mp, &
+ re_rain=re_rain_mp, &
+ has_reqc=has_reqc, &
+ has_reqi=has_reqi, &
+ has_reqs=has_reqs, &
+ has_reqr=has_reqr, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
)
-
ELSE
- CALL nssl_2mom_driver( &
- ITIMESTEP=itimestep, &
- ! TH=th, &
- tt=tgrs, &
- QV=qv_mp, &
- QC=qc_mp, &
- QR=qr_mp, &
- QI=qi_mp, &
- QS=qs_mp, &
- QH=qh_mp, &
- QHL=qhl_mp, &
-! CCW=qnc_mp, &
- CCW=nc_mp, &
- CRW=nr_mp, &
- CCI=ni_mp, &
- CSW=ns_mp, &
- CHW=nh_mp, &
- CHL=nhl_mp, &
- VHW=vh_mp, &
- VHL=vhl_mp, &
- ! cn=cccn, &
- PII=prslk, &
- P=prsl, &
- W=w, &
- DZ=dz, &
- DTP=dtptmp, &
- DN=rho, &
- rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
- snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
-! icenc=ice_mp, icencv=delta_ice_mp, &
- GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, &
- dbz = refl_10cm, &
-! nssl_progn=.false., &
- diagflag = diagflag, &
- errmsg=errmsg,errflg=errflg, &
- re_cloud=re_cloud_mp, &
- re_ice=re_ice_mp, &
- re_snow=re_snow_mp, &
- re_rain=re_rain_mp, &
- has_reqc=has_reqc, & ! ala G. Thompson
- has_reqi=has_reqi, & ! ala G. Thompson
- has_reqs=has_reqs, & ! ala G. Thompson
- has_reqr=has_reqr, &
+ CALL nssl_2mom_driver( &
+ ITIMESTEP=itimestep, &
+ ! TH=th, &
+ tt=tgrs, &
+ QV=qv_mp, &
+ QC=qc_mp, &
+ QR=qr_mp, &
+ QI=qi_mp, &
+ QS=qs_mp, &
+ QH=qh_mp, &
+ QHL=qhl_mp, &
+ CCW=nc_mp, &
+ CRW=nr_mp, &
+ CCI=ni_mp, &
+ CSW=ns_mp, &
+ CHW=nh_mp, &
+ CHL=nhl_mp, &
+ VHW=vh_mp, &
+ VHL=vhl_mp, &
+! cn=cn_mp, &
+ ZRW=zrw_mp, &
+ ZHW=zhw_mp, &
+ ZHL=zhl_mp, &
+! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
+! cna=cna_mp, f_cna=.false. , &
+ PII=prslk, &
+ P=prsl, &
+ W=w, &
+ DZ=dz, &
+ DTP=dtptmp, &
+ DN=rho, &
+ rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
+ snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
+ GRPLNC=xgraupel_mp, &
+ GRPLNCV=xdelta_graupel_mp, &
+ sr=sr, &
+ dbz = refl_10cm, &
+ diagflag = diagflag, &
+ errmsg=errmsg,errflg=errflg, &
+ re_cloud=re_cloud_mp, &
+ re_ice=re_ice_mp, &
+ re_snow=re_snow_mp, &
+ re_rain=re_rain_mp, &
+ has_reqc=has_reqc, &
+ has_reqi=has_reqi, &
+ has_reqs=has_reqs, &
+ has_reqr=has_reqr, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
)
-
+
ENDIF
-
-
+
DO i = 1,ncol
delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip
delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel
@@ -684,7 +717,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ENDDO
ENDDO
-
+
ENDIF
@@ -750,10 +783,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
csw = ns_mp/(1.0_kind_phys+qv_mp)
chw = nh_mp/(1.0_kind_phys+qv_mp)
vh = vh_mp/(1.0_kind_phys+qv_mp)
+ IF ( nssl_3moment ) THEN
+ zrw = zrw_mp/(1.0_kind_phys+qv_mp)
+ zhw = zhw_mp/(1.0_kind_phys+qv_mp)
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl = qhl_mp/(1.0_kind_phys+qv_mp)
chl = nhl_mp/(1.0_kind_phys+qv_mp)
vhl = vhl_mp/(1.0_kind_phys+qv_mp)
+ IF ( nssl_3moment ) THEN
+ zhl = zhl_mp/(1.0_kind_phys+qv_mp)
+ ENDIF
ENDIF
ELSE
! spechum = qv_mp ! /(1.0_kind_phys+qv_mp)
@@ -770,10 +810,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
csw = ns_mp
chw = nh_mp
vh = vh_mp
+ IF ( nssl_3moment ) THEN
+ zrw = zrw_mp
+ zhw = zhw_mp
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl = qhl_mp ! /(1.0_kind_phys+qv_mp)
chl = nhl_mp
vhl = vhl_mp
+ IF ( nssl_3moment ) THEN
+ zhl = zhl_mp
+ ENDIF
ENDIF
ENDIF
diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta
index 6bbf92c73..337b1ab76 100644
--- a/physics/mp_nssl.meta
+++ b/physics/mp_nssl.meta
@@ -210,6 +210,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
########################################################################
[ccpp-arg-table]
name = mp_nssl_run
@@ -387,6 +394,30 @@
type = real
kind = kind_phys
intent = inout
+[zrw]
+ standard_name = reflectivity_of_rain_of_new_state
+ long_name = rain reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[zhw]
+ standard_name = reflectivity_of_graupel_of_new_state
+ long_name = graupel reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[zhl]
+ standard_name = reflectivity_of_hail_of_new_state
+ long_name = hail reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
[tgrs]
standard_name = air_temperature_of_new_state
long_name = model layer mean temperature
@@ -614,6 +645,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[ntccn]
standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array
long_name = tracer index for cloud condensation nuclei number concentration
diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90
index c456e87cd..7b5b83b37 100644
--- a/physics/mp_thompson.F90
+++ b/physics/mp_thompson.F90
@@ -329,6 +329,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, &
first_time_step, istep, nsteps, &
prcp, rain, graupel, ice, snow, sr, &
refl_10cm, fullradar_diag, &
+ max_hail_diam_sfc, &
do_radar_ref, aerfld, &
mpicomm, mpirank, mpiroot, blkno, &
ext_diag, diag3d, reset_diag3d, &
@@ -387,6 +388,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, &
real(kind_phys), intent( out) :: sr(:)
! Radar reflectivity
real(kind_phys), intent(inout) :: refl_10cm(:,:)
+ real(kind_phys), intent(inout) :: max_hail_diam_sfc(:)
logical, intent(in ) :: do_radar_ref
logical, intent(in) :: sedi_semi
integer, intent(in) :: decfl
@@ -698,6 +700,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, &
graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, &
refl_10cm=refl_10cm, &
diagflag=diagflag, do_radar_ref=do_radar_ref_mp, &
+ max_hail_diam_sfc=max_hail_diam_sfc, &
has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, &
aero_ind_fdb=aero_ind_fdb, rand_perturb_on=spp_mp_opt, &
kme_stoch=kme_stoch, &
@@ -738,6 +741,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, &
graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, &
refl_10cm=refl_10cm, &
diagflag=diagflag, do_radar_ref=do_radar_ref_mp, &
+ max_hail_diam_sfc=max_hail_diam_sfc, &
has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, &
rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, &
rand_pert=spp_wts_mp, spp_var_list=spp_var_list, &
diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta
index 5918e4dd9..ae1072d39 100644
--- a/physics/mp_thompson.meta
+++ b/physics/mp_thompson.meta
@@ -610,6 +610,14 @@
type = real
kind = kind_phys
intent = out
+[max_hail_diam_sfc]
+ standard_name = max_hail_diameter_sfc
+ long_name = instantaneous maximum hail diameter at lowest model level
+ units = m
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = inout
[fullradar_diag]
standard_name = do_full_radar_reflectivity
long_name = flag for computing full radar reflectivity
diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90
index 3c7de235f..487753027 100644
--- a/physics/mynnedmf_wrapper.F90
+++ b/physics/mynnedmf_wrapper.F90
@@ -131,7 +131,8 @@ SUBROUTINE mynnedmf_wrapper_run( &
& edmf_a,edmf_w,edmf_qt, &
& edmf_thl,edmf_ent,edmf_qc, &
& sub_thl,sub_sqv,det_thl,det_sqv,&
- & nupdraft,maxMF,ktop_plume, &
+ & maxwidth,maxMF,ztop_plume, &
+ & ktop_plume, &
& dudt, dvdt, dtdt, &
& dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw
& dqdt_ice, dqdt_snow, & ! <=== ntiw, ntsw
@@ -310,9 +311,9 @@ SUBROUTINE mynnedmf_wrapper_run( &
real(kind_phys), dimension(:), intent(out) :: &
& ch,dtsfc1,dqsfc1,dusfc1,dvsfc1, &
& dtsfci_diag,dqsfci_diag,dusfci_diag,dvsfci_diag, &
- & maxMF
+ & maxMF,maxwidth,ztop_plume
integer, dimension(:), intent(inout) :: &
- & kpbl,nupdraft,ktop_plume
+ & kpbl,ktop_plume
real(kind_phys), dimension(:), intent(inout) :: &
& dusfc_cpl,dvsfc_cpl,dtsfc_cpl,dqsfc_cpl
@@ -325,6 +326,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
integer :: idtend
real(kind_phys), dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1
real(kind_phys), allocatable :: save_qke_adv(:,:)
+ real(kind_phys), dimension(levs) :: kzero
! Initialize CCPP error handling variables
errmsg = ''
@@ -355,6 +357,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
!print*,"in MYNN, initflag=",initflag
endif
+ kzero = zero !generic zero array
!initialize arrays for test
EMIS_ANT_NO = 0.
@@ -391,7 +394,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
FLAG_QNI= .true.
FLAG_QC = .true.
FLAG_QNC= .true.
- FLAG_QS = .false. !.true.
+ FLAG_QS = .true.
FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field?
FLAG_QNIFA= .false.
FLAG_QNBCA= .false.
@@ -400,7 +403,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
sqv(i,k) = qgrs_water_vapor(i,k)
sqc(i,k) = qgrs_liquid_cloud(i,k)
sqi(i,k) = qgrs_ice(i,k)
- sqs(i,k) = 0.0 !qgrs_snow(i,k)
+ sqs(i,k) = qgrs_snow(i,k)
ozone(i,k) = qgrs_ozone(i,k)
qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k)
qni(i,k) = qgrs_cloud_ice_num_conc(i,k)
@@ -418,7 +421,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
FLAG_QI = .true.
FLAG_QNI= .true.
FLAG_QC = .true.
- FLAG_QS = .false.
+ FLAG_QS = .true. !pipe it in, but do not mix
FLAG_QNC= .true.
FLAG_QNWFA= .true.
FLAG_QNIFA= .true.
@@ -428,7 +431,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
sqv(i,k) = qgrs_water_vapor(i,k)
sqc(i,k) = qgrs_liquid_cloud(i,k)
sqi(i,k) = qgrs_ice(i,k)
- sqs(i,k) = 0. !qgrs_snow(i,k)
+ sqs(i,k) = qgrs_snow(i,k)
qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k)
qni(i,k) = qgrs_cloud_ice_num_conc(i,k)
ozone(i,k) = qgrs_ozone(i,k)
@@ -441,7 +444,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
FLAG_QI = .true.
FLAG_QNI= .true.
FLAG_QC = .true.
- FLAG_QS = .false.
+ FLAG_QS = .true.
FLAG_QNC= .true.
FLAG_QNWFA= .false.
FLAG_QNIFA= .false.
@@ -451,7 +454,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
sqv(i,k) = qgrs_water_vapor(i,k)
sqc(i,k) = qgrs_liquid_cloud(i,k)
sqi(i,k) = qgrs_ice(i,k)
- sqs(i,k) = 0. !qgrs_snow(i,k)
+ sqs(i,k) = qgrs_snow(i,k)
qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k)
qni(i,k) = qgrs_cloud_ice_num_conc(i,k)
ozone(i,k) = qgrs_ozone(i,k)
@@ -464,7 +467,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
FLAG_QI = .true.
FLAG_QNI= .true.
FLAG_QC = .true.
- FLAG_QS = .false.
+ FLAG_QS = .true.
FLAG_QNC= .false.
FLAG_QNWFA= .false.
FLAG_QNIFA= .false.
@@ -474,7 +477,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
sqv(i,k) = qgrs_water_vapor(i,k)
sqc(i,k) = qgrs_liquid_cloud(i,k)
sqi(i,k) = qgrs_ice(i,k)
- sqs(i,k) = 0. !qgrs_snow(i,k)
+ sqs(i,k) = qgrs_snow(i,k)
qnc(i,k) = 0.
qni(i,k) = qgrs_cloud_ice_num_conc(i,k)
ozone(i,k) = qgrs_ozone(i,k)
@@ -565,7 +568,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
call moisture_check2(levs, delt, &
delp(i,:), exner(i,:), &
sqv(i,:), sqc(i,:), &
- sqi(i,:), sqs(i,:), &
+ sqi(i,:), kzero(:), &
t3d(i,:) )
enddo
@@ -748,7 +751,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
& edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,& !output
& sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, &
& det_thl3D=det_thl,det_sqv3D=det_sqv, &
- & nupdraft=nupdraft,maxMF=maxMF, & !output
+ & maxwidth=maxwidth,maxMF=maxMF,ztop_plume=ztop_plume,& !output
& ktop_plume=ktop_plume, & !output
& spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input
& RTHRATEN=htrlw, & !input
@@ -834,7 +837,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k)
dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k))
dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k)
- dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k))
+ dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k))
!dqdt_ozone(i,k) = 0.0
dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k)
dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k)
@@ -869,7 +872,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k)
dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k))
dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k)
- dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k))
+ dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k))
enddo
enddo
if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then
@@ -887,7 +890,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k))
dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k))
dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k)
- dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k))
+ dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k))
!dqdt_ozone(i,k) = 0.0
enddo
enddo
@@ -917,7 +920,7 @@ SUBROUTINE mynnedmf_wrapper_run( &
dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k)
dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k))
dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k)
- !dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k))
+ dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k))
IF ( nssl_ccn_on ) THEN !
dqdt_cccn(i,k) = RQNWFABLTEN(i,k)
ENDIF
@@ -1005,8 +1008,8 @@ SUBROUTINE mynnedmf_wrapper_run( &
print*,"dudt:",dudt(1,1),dudt(1,2),dudt(1,levs)
print*,"dvdt:",dvdt(1,1),dvdt(1,2),dvdt(1,levs)
print*,"dqdt:",dqdt_water_vapor(1,1),dqdt_water_vapor(1,2),dqdt_water_vapor(1,levs)
- print*,"ktop_plume:",ktop_plume(1)," maxmf:",maxmf(1)
- print*,"nup:",nupdraft(1)
+ print*,"ztop_plume:",ztop_plume(1)," maxmf:",maxmf(1)
+ print*,"maxwidth:",maxwidth(1)
print*
endif
diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta
index ec4706aba..8614d3ba2 100644
--- a/physics/mynnedmf_wrapper.meta
+++ b/physics/mynnedmf_wrapper.meta
@@ -964,13 +964,14 @@
type = real
kind = kind_phys
intent = inout
-[nupdraft]
- standard_name = number_of_plumes
- long_name = number of plumes per grid column
- units = count
+[maxwidth]
+ standard_name = maximum_width_of_plumes
+ long_name = maximum width of plumes per grid column
+ units = m
dimensions = (horizontal_loop_extent)
- type = integer
- intent = inout
+ type = real
+ kind = kind_phys
+ intent = out
[maxMF]
standard_name = maximum_mass_flux
long_name = maximum mass flux within a column
@@ -979,6 +980,14 @@
type = real
kind = kind_phys
intent = out
+[ztop_plume]
+ standard_name = height_of_tallest_plume_in_a_column
+ long_name = height of tallest plume in a column
+ units = m
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = out
[ktop_plume]
standard_name = k_level_of_highest_plume
long_name = k-level of highest plume
diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90
index 4500d51a8..c2c03d0de 100644
--- a/physics/noahmpdrv.F90
+++ b/physics/noahmpdrv.F90
@@ -450,7 +450,7 @@ subroutine noahmpdrv_run &
integer :: iopt_pedo = 1 ! option for pedotransfer function
integer :: iopt_crop = 0 ! option for crop model
integer :: iopt_gla = 2 ! option for glacier treatment
- integer :: iopt_z0m = 2 ! option for z0m treatment
+ integer :: iopt_z0m = 1 ! option for z0m treatment
!
! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call
diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90
deleted file mode 100644
index 5b3149d61..000000000
--- a/physics/ozinterp.f90
+++ /dev/null
@@ -1,212 +0,0 @@
-!>\file ozinterp.f90
-!! This file contains ozone climatology interpolation subroutines.
-
-!>\ingroup mod_GFS_phys_time_vary
-!! This module contains subroutines of reading and interpolating ozone coefficients.
-module ozinterp
-
- implicit none
-
- private
-
- public :: read_o3data, setindxoz, ozinterpol
-
-contains
-
- SUBROUTINE read_o3data (ntoz, me, master)
- use machine, only: kind_phys
- use ozne_def
-!--- in/out
- integer, intent(in) :: ntoz
- integer, intent(in) :: me
- integer, intent(in) :: master
-!--- locals
- integer :: i, n, k
- real(kind=4), allocatable, dimension(:) :: oz_lat4, oz_pres4
- real(kind=4), allocatable, dimension(:) :: oz_time4, tempin
- real(kind=4) :: blatc4
-
- if (ntoz <= 0) then ! Diagnostic ozone
- rewind (kozc)
- read (kozc,end=101) latsozc, levozc, timeozc, blatc4
- 101 if (levozc < 10 .or. levozc > 100) then
- rewind (kozc)
- levozc = 17
- latsozc = 18
- blatc = -85.0
- else
- blatc = blatc4
- endif
- latsozp = 2
- levozp = 1
- timeoz = 1
- oz_coeff = 0
- dphiozc = -(blatc+blatc)/(latsozc-1)
- return
- endif
-
- open(unit=kozpl,file='global_o3prdlos.f77', form='unformatted', convert='big_endian')
-
-!--- read in indices
-!---
- read (kozpl) oz_coeff, latsozp, levozp, timeoz
- if (me == master) then
- write(*,*) 'Reading in o3data from global_o3prdlos.f77 '
- write(*,*) ' oz_coeff = ', oz_coeff
- write(*,*) ' latsozp = ', latsozp
- write(*,*) ' levozp = ', levozp
- write(*,*) ' timeoz = ', timeoz
- endif
-
-!--- read in data
-!--- oz_lat - latitude of data (-90 to 90)
-!--- oz_pres - vertical pressure level (mb)
-!--- oz_time - time coordinate (days)
-!---
- allocate (oz_lat(latsozp), oz_pres(levozp),oz_time(timeoz+1))
- allocate (oz_lat4(latsozp), oz_pres4(levozp),oz_time4(timeoz+1))
- rewind (kozpl)
- read (kozpl) oz_coeff, latsozp, levozp, timeoz, oz_lat4, oz_pres4, oz_time4
- oz_pres(:) = oz_pres4(:)
-!--- convert pressure levels from mb to ln(Pa)
- oz_pres(:) = log(100.0*oz_pres(:))
- oz_lat(:) = oz_lat4(:)
- oz_time(:) = oz_time4(:)
- deallocate (oz_lat4, oz_pres4, oz_time4)
-
-!--- read in ozplin which is in order of (lattitudes, ozone levels, coeff number, time)
-!--- assume latitudes is on a uniform gaussian grid
-!---
- allocate (tempin(latsozp))
- allocate (ozplin(latsozp,levozp,oz_coeff,timeoz))
- DO i=1,timeoz
- DO n=1,oz_coeff
- DO k=1,levozp
- READ(kozpl) tempin
- ozplin(:,k,n,i) = tempin(:)
- ENDDO
- ENDDO
- ENDDO
- deallocate (tempin)
-
- close(kozpl)
-
- END SUBROUTINE read_o3data
-!
-!**********************************************************************
-!
- SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy)
-!
- USE MACHINE, ONLY: kind_phys
- USE OZNE_DEF, ONLY: jo3 => latsozp, oz_lat
-!
- implicit none
-!
- integer npts, JINDX1(npts),JINDX2(npts)
- real(kind=kind_phys) dlat(npts),DDY(npts)
-!
- integer i,j,lat
-!
- DO J=1,npts
- jindx2(j) = jo3 + 1
- do i=1,jo3
- if (dlat(j) < oz_lat(i)) then
- jindx2(j) = i
- exit
- endif
- enddo
- jindx1(j) = max(jindx2(j)-1,1)
- jindx2(j) = min(jindx2(j),jo3)
- if (jindx2(j) .ne. jindx1(j)) then
- DDY(j) = (dlat(j) - oz_lat(jindx1(j))) &
- / (oz_lat(jindx2(j)) - oz_lat(jindx1(j)))
- else
- ddy(j) = 1.0
- endif
-! print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), &
-! jjindx2(j),' oz_lat=',oz_lat(jindx1(j)), &
-! oz_lat(jindx2(j)),' ddy=',ddy(j)
- ENDDO
-
- RETURN
- END SUBROUTINE setindxoz
-!
-!**********************************************************************
-!
- SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy)
-!
- USE MACHINE, ONLY : kind_phys
- USE OZNE_DEF
- implicit none
- integer iday,j,j1,j2,l,npts,nc,n1,n2
- real(kind=kind_phys) fhour,tem, tx1, tx2
-!
-
- integer JINDX1(npts), JINDX2(npts)
- integer me, idate(4), IDAT(8),JDAT(8)
-!
- real(kind=kind_phys) DDY(npts)
- real(kind=kind_phys) ozplout(npts,levozp,oz_coeff)
- real(kind=kind_phys) rjday
- integer jdow, jdoy, jday
- real(8) rinc(5)
- real(4) rinc4(5)
- integer w3kindreal,w3kindint
-!
- IDAT=0
- IDAT(1)=IDATE(4)
- IDAT(2)=IDATE(2)
- IDAT(3)=IDATE(3)
- IDAT(5)=IDATE(1)
- RINC=0.
- RINC(2)=FHOUR
- call w3kind(w3kindreal,w3kindint)
- if(w3kindreal==4) then
- rinc4=rinc
- CALL W3MOVDAT(RINC4,IDAT,JDAT)
- else
- CALL W3MOVDAT(RINC,IDAT,JDAT)
- endif
-!
- jdow = 0
- jdoy = 0
- jday = 0
- call w3doxdat(jdat,jdow,jdoy,jday)
- rjday = jdoy + jdat(5) / 24.
- IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365.
-!
- n2 = timeoz + 1
- do j=2,timeoz
- if (rjday < oz_time(j)) then
- n2 = j
- exit
- endif
- enddo
- n1 = n2 - 1
-!
-! if (me == 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday
-! &,'oz_time=',oz_time(n1),oz_time(n2)
-!
-
- tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1))
- tx2 = 1.0 - tx1
-
- if (n2 > timeoz) n2 = n2 - timeoz
-!
- do nc=1,oz_coeff
- DO L=1,levozp
- DO J=1,npts
- J1 = JINDX1(J)
- J2 = JINDX2(J)
- TEM = 1.0 - DDY(J)
- ozplout(j,L,nc) = &
- tx1*(TEM*ozplin(J1,L,nc,n1)+DDY(J)*ozplin(J2,L,nc,n1)) &
- + tx2*(TEM*ozplin(J1,L,nc,n2)+DDY(J)*ozplin(J2,L,nc,n2))
- ENDDO
- ENDDO
- enddo
-!
- RETURN
- END SUBROUTINE ozinterpol
-
-end module ozinterp
diff --git a/physics/ozne_def.f b/physics/ozne_def.f
deleted file mode 100644
index 8f3af6240..000000000
--- a/physics/ozne_def.f
+++ /dev/null
@@ -1,24 +0,0 @@
-!>\file ozne_def.f
-!! This file contains the ozone array definition used in ozone physics.
-
-!>\ingroup mod_GFS_phys_time_vary
-!! This module defines arrays in Ozone scheme.
- module ozne_def
-
-!> \section arg_table_ozne_def
-!! \htmlinclude ozne_def.html
-!!
-
- use machine , only : kind_phys
- implicit none
-
- integer, parameter :: kozpl=28, kozc=48
-
- integer latsozp, levozp, timeoz, latsozc, levozc, timeozc
- &, oz_coeff
- real (kind=kind_phys) blatc, dphiozc
- real (kind=kind_phys), allocatable :: oz_lat(:), oz_pres(:)
- &, oz_time(:)
- real (kind=kind_phys), allocatable :: ozplin(:,:,:,:)
-
- end module ozne_def
diff --git a/physics/ozne_def.meta b/physics/ozne_def.meta
deleted file mode 100644
index 3cad9c14d..000000000
--- a/physics/ozne_def.meta
+++ /dev/null
@@ -1,29 +0,0 @@
-[ccpp-table-properties]
- name = ozne_def
- type = module
- dependencies = machine.F
-
-[ccpp-arg-table]
- name = ozne_def
- type = module
-
-[levozp]
- standard_name = vertical_dimension_of_ozone_forcing_data
- long_name = number of vertical layers in ozone forcing data
- units = count
- dimensions = ()
- type = integer
-[oz_coeff]
- standard_name = number_of_coefficients_in_ozone_forcing_data
- long_name = number of coefficients in ozone forcing data
- units = index
- dimensions = ()
- type = integer
-[oz_pres]
- standard_name = natural_log_of_ozone_forcing_data_pressure_levels
- long_name = natural log of ozone forcing data pressure levels in Pa
- units = 1
- dimensions = (vertical_dimension_of_ozone_forcing_data)
- type = real
- kind = kind_phys
- active = (index_of_ozone_mixing_ratio_in_tracer_concentration_array>0)
diff --git a/physics/ozphys.f b/physics/ozphys.f
deleted file mode 100644
index 18a9ae46f..000000000
--- a/physics/ozphys.f
+++ /dev/null
@@ -1,211 +0,0 @@
-!> \file ozphys.f
-!! This file is ozone sources and sinks (previous version).
-
-
-!> This module contains the CCPP-compliant Ozone photochemistry scheme.
- module ozphys
-
- contains
-
-! \brief Brief description of the subroutine
-!
-!> \section arg_table_ozphys_init Argument Table
-!! \htmlinclude ozphys_init.html
-!!
- subroutine ozphys_init(oz_phys, errmsg, errflg)
-
- implicit none
- logical, intent(in) :: oz_phys
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if (.not.oz_phys) then
- write (errmsg,'(*(a))') 'Logic error: oz_phys == .false.'
- errflg = 1
- return
- endif
-
- end subroutine ozphys_init
-
-!>\defgroup GFS_ozphys GFS ozphys Main
-!! \brief The operational GFS currently parameterizes ozone production and
-!! destruction based on monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval
-!! Research Laboratory through CHEM2D chemistry model
-!! (McCormack et al. (2006) \cite mccormack_et_al_2006).
-!! \section arg_table_ozphys_run Argument Table
-!! \htmlinclude ozphys_run.html
-!!
-!> \section genal_ozphys GFS ozphys_run General Algorithm
-!> @{
- subroutine ozphys_run ( &
- & im, levs, ko3, dt, oz, tin, po3, &
- & prsl, prdout, oz_coeff, delp, ldiag3d, &
- & ntoz, dtend, dtidx, index_of_process_prod_loss, &
- & index_of_process_ozmix, index_of_process_temp, &
- & index_of_process_overhead_ozone, con_g, me, errmsg, errflg)
-!
-! this code assumes that both prsl and po3 are from bottom to top
-! as are all other variables
-!
- use machine , only : kind_phys
- implicit none
-!
- ! Interface variables
- integer, intent(in) :: im, levs, ko3, oz_coeff, me
- real(kind=kind_phys), intent(inout) :: oz(:,:)
- real(kind=kind_phys), intent(inout) :: dtend(:,:,:)
- integer, intent(in) :: dtidx(:,:), ntoz, &
- & index_of_process_prod_loss, index_of_process_ozmix, &
- & index_of_process_temp, index_of_process_overhead_ozone
- real(kind=kind_phys), intent(in) :: &
- & dt, po3(:), prdout(:,:,:), &
- & prsl(:,:), tin(:,:), delp(:,:), &
- & con_g
- real :: gravi
- logical, intent(in) :: ldiag3d
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-!
- ! Local variables
- integer k,kmax,kmin,l,i,j, idtend(4)
- logical flg(im)
- real(kind=kind_phys) pmax, pmin, tem, temp
- real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,oz_coeff),
- & ozib(im), colo3(im,levs+1), ozi(im,levs)
-!
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-!
-! save input oz in ozi
- ozi = oz
- gravi=1.0/con_g
-
-
- if(ldiag3d) then
- idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1
- idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2
- idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3
- idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4
- else
- idtend=0
- endif
-
-!
-!> - Calculate vertical integrated column ozone values.
- if (oz_coeff > 2) then
- colo3(:,levs+1) = 0.0
- do l=levs,1,-1
- do i=1,im
- colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi
- enddo
- enddo
- endif
-!
-!> - Apply vertically linear interpolation to the ozone coefficients.
- do l=1,levs
- pmin = 1.0e10
- pmax = -1.0e10
-!
- do i=1,im
- wk1(i) = log(prsl(i,l))
- pmin = min(wk1(i), pmin)
- pmax = max(wk1(i), pmax)
- prod(i,:) = 0.0
- enddo
- kmax = 1
- kmin = 1
- do k=1,ko3-1
- if (pmin < po3(k)) kmax = k
- if (pmax < po3(k)) kmin = k
- enddo
-!
- do k=kmin,kmax
- temp = 1.0 / (po3(k) - po3(k+1))
- do i=1,im
- flg(i) = .false.
- if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then
- flg(i) = .true.
- wk2(i) = (wk1(i) - po3(k+1)) * temp
- wk3(i) = 1.0 - wk2(i)
- endif
- enddo
- do j=1,oz_coeff
- do i=1,im
- if (flg(i)) then
- prod(i,j) = wk2(i) * prdout(i,k,j)
- & + wk3(i) * prdout(i,k+1,j)
- endif
- enddo
- enddo
- enddo
-!
- do j=1,oz_coeff
- do i=1,im
- if (wk1(i) < po3(ko3)) then
- prod(i,j) = prdout(i,ko3,j)
- endif
- if (wk1(i) >= po3(1)) then
- prod(i,j) = prdout(i,1,j)
- endif
- enddo
- enddo
-
- if (oz_coeff == 2) then
- do i=1,im
- ozib(i) = ozi(i,l) ! no filling
- oz(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt)
- enddo
-!
- if(idtend(1)>=1) then
- dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1
- & prod(:,1)*dt
- endif
- if(idtend(2)>=1) then
- dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2
- & (oz(:,l) - ozib(:))
- endif
- endif
-!> - Calculate the 4 terms of prognostic ozone change during time \a dt:
-!! - ozp1(:,:) - Ozone production from production/loss ratio
-!! - ozp2(:,:) - Ozone production from ozone mixing ratio
-!! - ozp3(:,:) - Ozone production from temperature term at model layers
-!! - ozp4(:,:) - Ozone production from column ozone term at model layers
- if (oz_coeff == 4) then
- do i=1,im
- ozib(i) = ozi(i,l) ! no filling
- tem = prod(i,1) + prod(i,3)*tin(i,l)
- & + prod(i,4)*colo3(i,l+1)
-! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:)
-! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1)
- oz(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt)
- enddo
- if(idtend(1)>=1) then
- dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1
- & prod(:,1)*dt
- endif
- if(idtend(2)>=1) then
- dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2
- & (oz(:,l)-ozib(:))
- endif
- if(idtend(3)>=1) then
- dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3
- & prod(:,3)*tin(:,l)*dt
- endif
- if(idtend(4)>=1) then
- dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4
- & prod(:,4)*colo3(:,l+1)*dt
- endif
- endif
- enddo ! vertical loop
-!
- return
- end subroutine ozphys_run
-!> @}
-
- end module ozphys
diff --git a/physics/ozphys.meta b/physics/ozphys.meta
deleted file mode 100644
index 485e2a491..000000000
--- a/physics/ozphys.meta
+++ /dev/null
@@ -1,208 +0,0 @@
-[ccpp-table-properties]
- name = ozphys
- type = scheme
- dependencies = machine.F
-
-########################################################################
-[ccpp-arg-table]
- name = ozphys_init
- type = scheme
-[oz_phys]
- standard_name = flag_for_nrl_2006_ozone_scheme
- long_name = flag for old (2006) ozone physics
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
-
-########################################################################
-[ccpp-arg-table]
- name = ozphys_run
- type = scheme
-[im]
- standard_name = horizontal_loop_extent
- long_name = horizontal loop extent
- units = count
- dimensions = ()
- type = integer
- intent = in
-[levs]
- standard_name = vertical_layer_dimension
- long_name = number of vertical layers
- units = count
- dimensions = ()
- type = integer
- intent = in
-[ko3]
- standard_name = vertical_dimension_of_ozone_forcing_data
- long_name = number of vertical layers in ozone forcing data
- units = count
- dimensions = ()
- type = integer
- intent = in
-[dt]
- standard_name = timestep_for_physics
- long_name = physics time step
- units = s
- dimensions = ()
- type = real
- kind = kind_phys
- intent = in
-[oz]
- standard_name = ozone_concentration_of_new_state
- long_name = ozone concentration updated by physics
- units = kg kg-1
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = inout
-[tin]
- standard_name = air_temperature_of_new_state
- long_name = updated air temperature
- units = K
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[po3]
- standard_name = natural_log_of_ozone_forcing_data_pressure_levels
- long_name = natural log of ozone forcing data pressure levels
- units = 1
- dimensions = (vertical_dimension_of_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
-[prsl]
- standard_name = air_pressure
- long_name = mid-layer pressure
- units = Pa
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[prdout]
- standard_name = ozone_forcing
- long_name = ozone forcing coefficients
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
-[oz_coeff]
- standard_name = number_of_coefficients_in_ozone_forcing_data
- long_name = number of coefficients in ozone forcing data
- units = index
- dimensions = ()
- type = integer
- intent = in
-[delp]
- standard_name = air_pressure_difference_between_midlayers
- long_name = difference between mid-layer pressures
- units = Pa
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[ldiag3d]
- standard_name = flag_for_diagnostics_3D
- long_name = flag for calculating 3-D diagnostic fields
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[dtend]
- standard_name = cumulative_change_of_state_variables
- long_name = diagnostic tendencies for state variables
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max)
- type = real
- kind = kind_phys
- active = (flag_for_diagnostics_3D)
- intent = inout
-[dtidx]
- standard_name = cumulative_change_of_state_variables_outer_index
- long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index
- units = index
- dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes)
- type = integer
- intent = in
-[ntoz]
- standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array
- long_name = tracer index for ozone mixing ratio
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_prod_loss]
- standard_name = index_of_production_and_loss_process_in_cumulative_change_index
- long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_ozmix]
- standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index
- long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_temp]
- standard_name = index_of_temperature_process_in_cumulative_change_index
- long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_overhead_ozone]
- standard_name = index_of_overhead_process_in_cumulative_change_index
- long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[con_g]
- standard_name = gravitational_acceleration
- long_name = gravitational acceleration
- units = m s-2
- dimensions = ()
- type = real
- kind = kind_phys
- intent = in
-[me]
- standard_name = mpi_rank
- long_name = rank of the current MPI task
- units = index
- dimensions = ()
- type = integer
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
diff --git a/physics/ozphys_2015.f b/physics/ozphys_2015.f
deleted file mode 100644
index 85c79f733..000000000
--- a/physics/ozphys_2015.f
+++ /dev/null
@@ -1,190 +0,0 @@
-!> \file ozphys_2015.f
-!! This file is ozone sources and sinks.
-
-
- module ozphys_2015
-
- contains
-
-!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module
-!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme.
-!> @{
-!> \section arg_table_ozphys_2015_init Argument Table
-!! \htmlinclude ozphys_2015_init.html
-!!
- subroutine ozphys_2015_init(oz_phys_2015, errmsg, errflg)
-
- implicit none
- logical, intent(in) :: oz_phys_2015
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if (.not.oz_phys_2015) then
- write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.'
- errflg = 1
- return
- endif
-
- end subroutine ozphys_2015_init
-
-!> The operational GFS currently parameterizes ozone production and
-!! destruction based on monthly mean coefficients (
-!! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval
-!! Research Laboratory through CHEM2D chemistry model
-!! (McCormack et al. (2006) \cite mccormack_et_al_2006).
-!! \section arg_table_ozphys_2015_run Argument Table
-!! \htmlinclude ozphys_2015_run.html
-!!
-!> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm
-!> - This code assumes that both prsl and po3 are from bottom to top
-!! as are all other variables.
-!> - This code is specifically for NRL parameterization and
-!! climatological T and O3 are in location 5 and 6 of prdout array
-!!\author June 2015 - Shrinivas Moorthi
- subroutine ozphys_2015_run ( &
- & im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, &
- & delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss&
- & , index_of_process_ozmix, index_of_process_temp, &
- & index_of_process_overhead_ozone, con_g, me, errmsg, errflg)
-!
-!
- use machine , only : kind_phys
- implicit none
-!
- real(kind=kind_phys),intent(in) :: con_g
- real :: gravi
- integer, intent(in) :: im, levs, ko3, pl_coeff,me
- real(kind=kind_phys), intent(in) :: po3(:), &
- & prsl(:,:), tin(:,:), &
- & delp(:,:), &
- & prdout(:,:,:), dt
- real(kind=kind_phys), intent(inout) :: dtend(:,:,:)
- integer, intent(in) :: dtidx(:,:), ntoz, &
- & index_of_process_prod_loss, index_of_process_ozmix, &
- & index_of_process_temp, index_of_process_overhead_ozone
- real(kind=kind_phys), intent(inout) :: oz(im,levs)
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- integer k,kmax,kmin,l,i,j, idtend(4)
- logical ldiag3d, flg(im), qdiag3d
- real(kind=kind_phys) pmax, pmin, tem, temp
- real(kind=kind_phys) wk1(im), wk2(im), wk3(im),prod(im,pl_coeff), &
- & ozib(im), colo3(im,levs+1), coloz(im,levs+1),&
- & ozi(im,levs)
-!
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if(ldiag3d) then
- idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1
- idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2
- idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3
- idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4
- else
- idtend=0
- endif
-
-!ccpp: save input oz in ozi
- ozi = oz
- gravi=1.0/con_g
-
- colo3(:,levs+1) = 0.0
- coloz(:,levs+1) = 0.0
-!
- do l=levs,1,-1
- pmin = 1.0e10
- pmax = -1.0e10
-!
- do i=1,im
- wk1(i) = log(prsl(i,l))
- pmin = min(wk1(i), pmin)
- pmax = max(wk1(i), pmax)
- prod(i,:) = 0.0
- enddo
- kmax = 1
- kmin = 1
- do k=1,ko3-1
- if (pmin < po3(k)) kmax = k
- if (pmax < po3(k)) kmin = k
- enddo
-!
- do k=kmin,kmax
- temp = 1.0 / (po3(k) - po3(k+1))
- do i=1,im
- flg(i) = .false.
- if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then
- flg(i) = .true.
- wk2(i) = (wk1(i) - po3(k+1)) * temp
- wk3(i) = 1.0 - wk2(i)
- endif
- enddo
- do j=1,pl_coeff
- do i=1,im
- if (flg(i)) then
- prod(i,j) = wk2(i) * prdout(i,k,j)
- & + wk3(i) * prdout(i,k+1,j)
- endif
- enddo
- enddo
- enddo
-!
- do j=1,pl_coeff
- do i=1,im
- if (wk1(i) < po3(ko3)) then
- prod(i,j) = prdout(i,ko3,j)
- endif
- if (wk1(i) >= po3(1)) then
- prod(i,j) = prdout(i,1,j)
- endif
- enddo
- enddo
- do i=1,im
- colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi
- coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi
- prod(i,2) = min(prod(i,2), 0.0)
- enddo
-! write(1000+me,*) ' colo3=',colo3(1,l),' coloz=',coloz(1,l)
-! &,' l=',l
- do i=1,im
- ozib(i) = ozi(i,l) ! no filling
- tem = prod(i,1) - prod(i,2) * prod(i,6)
- & + prod(i,3) * (tin(i,l) - prod(i,5))
- & + prod(i,4) * (colo3(i,l)-coloz(i,l))
-
-! if (me .eq. 0) print *,'ozphys_2015 tem=',tem,' prod=',prod(i,:)
-! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1)
-
-!ccpp ozo(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt)
- oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt)
- enddo
- if(idtend(1)>=1) then
- dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1
- & (prod(:,1)-prod(:,2)*prod(:,6))*dt
- endif
- if(idtend(2)>=1) then
- dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2
- & (oz(:,l) - ozib(:))
- endif
- if(idtend(3)>=1) then
- dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3
- & prod(:,3)*(tin(:,l)-prod(:,5))*dt
- endif
- if(idtend(4)>=1) then
- dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4
- & prod(:,4) * (colo3(:,l)-coloz(:,l))*dt
- endif
- enddo ! vertical loop
-!
- return
- end subroutine ozphys_2015_run
-
-!> @}
-
- end module ozphys_2015
diff --git a/physics/phys_tend.F90 b/physics/phys_tend.F90
deleted file mode 100644
index e63f44be5..000000000
--- a/physics/phys_tend.F90
+++ /dev/null
@@ -1,96 +0,0 @@
-!>\file phys_tend.F90
-!!
-module phys_tend
-
- use machine, only: kind_phys
-
- implicit none
-
- private
-
- public phys_tend_run
-
-contains
-
-!> \section arg_table_phys_tend_run Argument Table
-!! \htmlinclude phys_tend_run.html
-!!
- subroutine phys_tend_run(ldiag3d, dtend, dtidx, ntracp100, &
- index_of_process_physics, index_of_process_photochem, &
- nprocess, nprocess_summed, is_photochem, ntoz, errmsg, errflg)
-
- ! Interface variables
- logical, intent(in) :: ldiag3d, is_photochem(:)
- real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:)
- integer, intent(in) :: dtidx(:,:), index_of_process_physics, ntoz, &
- ntracp100, nprocess, nprocess_summed, index_of_process_photochem
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- integer :: ichem, iphys, itrac
- logical :: all_true(nprocess)
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if(.not.ldiag3d) then
- return
- endif
-
- all_true = .true.
-
- ! Total photochemical tendencies
- itrac=ntoz+100
- ichem = dtidx(itrac,index_of_process_photochem)
- if(ichem>=1) then
- call sum_it(ichem,itrac,is_photochem)
- endif
-
-
- do itrac=2,ntracp100
- ! Total physics tendencies
- iphys = dtidx(itrac,index_of_process_physics)
- if(iphys>=1) then
- call sum_it(iphys,itrac,all_true)
- endif
- enddo
-
- contains
-
- subroutine sum_it(isum,itrac,sum_me)
- implicit none
- integer, intent(in) :: isum ! third index of dtend of summary process
- integer, intent(in) :: itrac ! tracer or state variable being summed
- logical, intent(in) :: sum_me(nprocess) ! false = skip this process
- logical :: first
- integer :: idtend, iprocess
-
- first=.true.
- do iprocess=1,nprocess
- if(iprocess>nprocess_summed) then
- exit ! Don't sum up the sums.
- else if(.not.sum_me(iprocess)) then
- cycle ! We were asked to skip this one.
- endif
- idtend = dtidx(itrac,iprocess)
- if(idtend>=1) then
- ! This tendency was calculated for this tracer, so
- ! accumulate it into the total tendency.
- if(first) then
- dtend(:,:,isum) = dtend(:,:,idtend)
- first=.false.
- else
- dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend)
- endif
- endif
- enddo
- if(first) then
- ! No tendencies were calculated, so sum is 0:
- dtend(:,:,isum) = 0
- endif
- end subroutine sum_it
-
- end subroutine phys_tend_run
-
-end module phys_tend
diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta
deleted file mode 100644
index 0f78af20b..000000000
--- a/physics/phys_tend.meta
+++ /dev/null
@@ -1,95 +0,0 @@
-[ccpp-table-properties]
- name = phys_tend
- type = scheme
- dependencies = machine.F
-
-########################################################################
-[ccpp-arg-table]
- name = phys_tend_run
- type = scheme
-[ldiag3d]
- standard_name = flag_for_diagnostics_3D
- long_name = flag for 3d diagnostic fields
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[dtend]
- standard_name = cumulative_change_of_state_variables
- long_name = diagnostic tendencies for state variables
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max)
- type = real
- kind = kind_phys
- intent = inout
-[dtidx]
- standard_name = cumulative_change_of_state_variables_outer_index
- long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index
- units = index
- dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes)
- type = integer
- intent = in
-[ntracp100]
- standard_name = number_of_tracers_plus_one_hundred
- long_name = number of tracers plus one hundred
- units = count
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_physics]
- standard_name = index_of_all_physics_process_in_cumulative_change_index
- long_name = index of all physics transport process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_photochem]
- standard_name = index_of_photochemistry_process_in_cumulative_change_index
- long_name = index of photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[nprocess]
- standard_name = number_of_cumulative_change_processes
- long_name = number of processes that cause changes in state variables
- units = count
- dimensions = ()
- type = integer
- intent = in
-[nprocess_summed]
- standard_name = number_of_physics_causes_of_tracer_changes
- long_name = number of causes in dtidx per tracer summed for total physics tendency
- units = count
- dimensions = ()
- type = integer
- intent = in
-[is_photochem]
- standard_name = flags_for_photochemistry_processes_to_sum
- long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change
- units = flag
- dimensions = (number_of_cumulative_change_processes)
- type = logical
- intent = in
-[ntoz]
- standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array
- long_name = tracer index for ozone mixing ratio
- units = index
- dimensions = ()
- type = integer
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
diff --git a/physics/physcons.F90 b/physics/physcons.F90
index e7ec8fb77..4d86301e2 100644
--- a/physics/physcons.F90
+++ b/physics/physcons.F90
@@ -33,7 +33,7 @@
!> This module contains some of the most frequently used math and physics
!! constants for GCM models.
- module physcons
+ module physcons
!
use machine, only: kind_phys, kind_dyn
!
@@ -44,7 +44,7 @@ module physcons
!> \name Math constants
! real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 !< pi
real(kind=kind_phys),parameter:: con_pi =4.0d0*atan(1.0d0) !< pi
- real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2
+ real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2
real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0_kind_phys !< quare root of 3
!> \name Geophysics/Astronomy constants
@@ -97,6 +97,7 @@ module physcons
real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq
real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv
real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp)
+ real(kind=kind_phys),parameter:: con_1ovg = 1._kind_phys/con_g
!> \name Other Physics/Chemistry constants (source: 2002 CODATA)
real(kind=kind_phys),parameter:: con_c =2.99792458e+8_kind_phys !< speed of light (\f$m/s\f$)
diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90
index c87308602..469df49f6 100644
--- a/physics/progsigma_calc.f90
+++ b/physics/progsigma_calc.f90
@@ -19,10 +19,10 @@ module progsigma
!! This subroutine computes a prognostic updraft area fracftion
!! used in the closure computations in the samfshalcnv. scheme
!!\section gen_progsigma progsigma_calc General Algorithm
- subroutine progsigma_calc (im,km,flag_init,flag_restart, &
- flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, &
- delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, &
- sigmab)
+ subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_shallow,&
+ flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, &
+ delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, &
+ sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab)
!
!
use machine, only : kind_phys
@@ -32,11 +32,12 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, &
! intent in
integer, intent(in) :: im,km,kbcon1(im),ktcon(im)
- real(kind=kind_phys), intent(in) :: hvap,delt
+ real(kind=kind_phys), intent(in) :: hvap,delt,betascu,betamcu,betadcu, &
+ sigmind,sigminm,sigmins
real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), &
qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), &
omega_u(im,km),zeta(im,km)
- logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow
+ logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow,flag_mid
real(kind=kind_phys), intent(in) :: sigmain(im,km)
! intent out
@@ -53,15 +54,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, &
real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, &
fdqb,dtdyn,dxlim,rmulacvg,tem, &
- DEN,betascu,betadcu,dp1,invdelt
+ DEN,dp1,invdelt
!Parameters
gcvalmx = 0.1
rmulacvg=10.
epsilon=1.E-11
km1=km-1
- betadcu = 2.0
- betascu = 8.0
invdelt = 1./delt
!Initialization 2D
@@ -206,17 +205,27 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, &
do i= 1, im
if(cnvflg(i)) then
sigmab(i)=sigmab(i)/betascu
- sigmab(i)=MAX(0.03,sigmab(i))
+ sigmab(i)=MAX(sigmins,sigmab(i))
+ endif
+ enddo
+ elseif(flag_mid)then
+ do i= 1, im
+ if(cnvflg(i)) then
+ sigmab(i)=sigmab(i)/betamcu
+ sigmab(i)=MAX(sigminm,sigmab(i))
endif
enddo
else
do i= 1, im
if(cnvflg(i)) then
sigmab(i)=sigmab(i)/betadcu
- sigmab(i)=MAX(0.01,sigmab(i))
+ sigmab(i)=MAX(sigmind,sigmab(i))
endif
enddo
endif
+ do i= 1, im
+ sigmab(i) = MIN(0.95,sigmab(i))
+ enddo
end subroutine progsigma_calc
diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f
index ccc3b598a..4c626b348 100644
--- a/physics/radiation_gases.f
+++ b/physics/radiation_gases.f
@@ -1,17 +1,14 @@
!> \file radiation_gases.f
-!! This file contains routines that set up ozone climatological
-!! profiles and other constant gas profiles, such as co2, ch4, n2o,
-!! o2, and those of cfc gases. All data are entered as mixing ratio
-!! by volume, except ozone which is mass mixing ratio (g/g).
+!! This file contains routines that set up gas profiles, such as co2,
+!! ch4, n2o, o2, and those of cfc gases. All data are entered as mixing
+!! ratio by volume
! ========================================================== !!!!!
! 'module_radiation_gases' description !!!!!
! ========================================================== !!!!!
! !
-! set up ozone climatological profiles and other constant gas !
-! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All !
-! data are entered as mixing ratio by volume, except ozone which is !
-! mass mixing ratio (g/g). !
+! set up constant gas profiles, such as co2, ch4, n2o, o2, and those !
+! of cfc gases. All data are entered as mixing ratio by volume !
! !
! in the module, the externally callabe subroutines are : !
! !
@@ -23,16 +20,10 @@
! !
! 'gas_update' -- read in data and update with time !
! input: !
-! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) !
+! ( iyear, imon, iday, ihour, ldoco2, me ) !
! output: !
! ( errflg, errmsg ) !
! !
-! 'getozn' -- setup climatological ozone profile !
-! input: !
-! ( prslk,xlat, !
-! IMAX, LM ) !
-! output: !
-! ( o3mmr ) !
! !
! 'getgases' -- setup constant gas profiles for LW and SW !
! input: !
@@ -47,7 +38,6 @@
! 'module module_iounitdef' in 'iounitdef.f' !
! !
! unit used for radiative active gases: !
-! ozone : mass mixing ratio (g/g) !
! co2 : volume mixing ratio (p/p) !
! n2o : volume mixing ratio (p/p) !
! ch4 : volume mixing ratio (p/p) !
@@ -81,15 +71,6 @@
! seasonal cycle calculations !
! aug 2011 - y-t hou fix a bug in subr getgases doing vertical !
! co2 mapping. (for top_at_1 case, not affact opr). !
-! aug 2012 - y-t hou modified subr getozn. moved the if-first !
-! block to subr gas_init to ensure threading safe in !
-! climatology ozone applications. (not affect gfs) !
-! also changed the initialization subr into two parts:!
-! 'gas_init' is called at the start of run to set up !
-! module parameters; and 'gas_update' is called within!
-! the time loop to check and update data sets. defined!
-! the climatology ozone parameters k1oz,k2oz,facoz as !
-! module variables and are set in subr 'gas_update' !
! nov 2012 - y-t hou modified control parameters thru module !
! 'physparam'. !
! jan 2013 - z. janjic/y. hou modified ilon (longitude index) !
@@ -105,10 +86,8 @@
!> \defgroup module_radiation_gases_mod Radiation Gases Module
!> @{
-!> This module sets up ozone climatological profiles and other constant
-!! gas profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All
-!! data are entered as mixing ratio by volume, except ozone which is
-!! mass mixing ratio (g/g).
+!> This module sets up constant gas profiles, such as co2, ch4, n2o, o2,
+!! and those of cfc gases. All data are entered as mixing ratio by volume.
!!\image html rad_gas_AGGI.png "Figure 1: Atmospheric radiative forcing, relative to 1750, by long-lived greenhouse gases and the 2016 update of the NOAA Annual Greenhouse Gas Index (AGGI)"
!! NOAA Annual Greenhouse Gas Index (AGGI) shows that from 1990 to 2016,
!! radiative forcing by long-lived greenhouse gases (LLGHGs) increased by
@@ -121,10 +100,6 @@
!!\n ICO2=1: use observed global annual mean value
!!\n ICO2=2: use observed monthly 2-d data table in \f$15^o\f$ horizontal resolution
!!
-!! O3 Distribution (namelist control parameter -\b NTOZ):
-!!\n NTOZ=0: use seasonal and zonal averaged climatological ozone
-!!\n NTOZ>0: use 3-D prognostic ozone
-!!
!! Trace Gases (currently using the global mean climatology in unit of ppmv):
!! \f$CH_4-1.50\times10^{-6}\f$;
!! \f$N_2O-0.31\times10^{-6}\f$;
@@ -137,14 +112,11 @@
!!
!!\version NCEP-Radiation_gases v5.1 Nov 2012
-!> This module sets up ozone climatological profiles and other constant gas
-!! profiles, such as co2, ch4, n2o, o2, and those of cfc gases.
+!> This module sets up constant gas rofiles, such as co2, ch4, n2o, o2, and those
+!! of cfc gases.
module module_radiation_gases
use machine, only : kind_phys, kind_io4
use funcphys, only : fpkapx
- use ozne_def, only : JMR => latsozc, LOZ => levozc, &
- & blte => blatc, dlte=> dphiozc, &
- & timeozc => timeozc
use module_iounitdef, only : NIO3CLM, NICO2CN
!
implicit none
@@ -182,22 +154,8 @@ module module_radiation_gases
! gfdl 1999 value
real (kind=kind_phys), parameter :: f113vmr_def= 8.2000e-11
-! --- ozone seasonal climatology parameters defined in module ozne_def
-! - 4x5 ozone data parameter
-! integer, parameter :: JMR=45, LOZ=17
-! real (kind=kind_phys), parameter :: blte=-86.0, dlte=4.0
-! - geos ozone data
-! integer, parameter :: JMR=18, LOZ=17
-! real (kind=kind_phys), parameter :: blte=-85.0, dlte=10.0
-
! --- module variables to be set in subroutin gas_init and/or gas_update
-! variables for climatology ozone (ioznflg = 0)
-
- real (kind=kind_phys), allocatable :: pkstr(:), o3r(:,:,:)
- integer :: k1oz = 0, k2oz = 0
- real (kind=kind_phys) :: facoz = 0.0
-
! arrays for co2 2-d monthly data and global mean values from observed data
real (kind=kind_phys), allocatable :: co2vmr_sav(:,:,:)
@@ -212,33 +170,30 @@ module module_radiation_gases
! --- public interfaces
- public gas_init, gas_update, getgases, getozn
+ public gas_init, gas_update, getgases
! =================
contains
! =================
-!> This subroutine sets up ozone, co2, etc. parameters. If climatology
-!! ozone then read in monthly ozone data.
+!> This subroutine sets up co2, etc. parameters.
!!\param me print message control flag
!!\param co2usr_file co2 user defined data table
!!\param co2cyc_file co2 climotology monthly cycle data table
!!\param ictmflg data ic time/date control flag
!!\param ico2flg co2 data source control flag
-!!\param ioznflg ozone data control flag
!!\param con_pi physical constant Pi
!!\param errflg error flag
!!\param errmsg error message
!>\section gas_init_gen gas_init General Algorithm
!-----------------------------------
subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
- & ictmflg, ioznflg, con_pi, errflg, errmsg)
+ & ictmflg, con_pi, errflg, errmsg)
! =================================================================== !
! !
-! gas_init sets up ozone, co2, etc. parameters. if climatology ozone !
-! then read in monthly ozone data. !
+! gas_init sets up co2, etc. parameters. !
! !
! inputs: !
! me - print message control flag !
@@ -259,9 +214,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
! further data extrapolation. !
! =yyyy1: use yyyy data for the fcst. if needed, do !
! extrapolation to match the fcst time. !
-! ioznflg - ozone data control flag !
-! =0: use climatological ozone profile !
-! >0: use interactive ozone profile !
! co2usr_file - external co2 user defined data table !
! co2cyc_file - external co2 climotology monthly cycle data table !
! con_pi - physical constant Pi !
@@ -270,9 +222,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
! errflg - error flag !
! errmsg - error message !
! !
-! internal module variables: !
-! pkstr, o3r - arrays for climatology ozone data !
-! !
! usage: call gas_init !
! !
! subprograms called: none !
@@ -282,9 +231,10 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
implicit none
! --- inputs:
- integer, intent(in) :: me, ictmflg, ioznflg, ico2flg
+ integer, intent(in) :: me, ictmflg, ico2flg
character(len=26),intent(in) :: co2usr_file,co2cyc_file
real(kind=kind_phys), intent(in) :: con_pi
+
! --- output:
character(len=*), intent(out) :: errmsg
integer, intent(out) :: errflg
@@ -292,10 +242,7 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
! --- locals:
real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat
real (kind=kind_phys) :: co2g1, co2g2
- real (kind=kind_phys) :: pstr(LOZ)
- real (kind=kind_io4) :: o3clim4(JMR,LOZ,12), pstr4(LOZ)
- integer :: imond(12), ilat(JMR,12)
integer :: i, j, k, iyr, imo
logical :: file_exist, lextpl
character :: cline*100, cform*8
@@ -317,78 +264,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
kyrsav = 0
kmonsav = 1
-! --- ... climatology ozone data section
-
- if ( ioznflg > 0 ) then
- if ( me == 0 ) then
- print *,' - Using interactive ozone distribution'
- endif
- else
- if ( timeozc /= 12 ) then
- print *,' - Using climatology ozone distribution'
- print *,' timeozc=',timeozc, ' is not monthly mean', &
- & ' - job aborting in subroutin gas_init!!!'
- errflg = 1
- errmsg = 'ERROR(gas_init): Climatological o3 distribution '// &
- & 'is not monthly mean'
- return
- endif
-
- allocate (pkstr(LOZ), o3r(JMR,LOZ,12))
- rewind NIO3CLM
-
- if ( LOZ == 17 ) then ! For the operational ozone climatology
- do k = 1, LOZ
- read (NIO3CLM,15) pstr4(k)
- 15 format(f10.3)
- enddo
-
- do imo = 1, 12
- do j = 1, JMR
- read (NIO3CLM,16) imond(imo), ilat(j,imo), &
- & (o3clim4(j,k,imo),k=1,10)
- 16 format(i2,i4,10f6.2)
- read (NIO3CLM,20) (o3clim4(j,k,imo),k=11,LOZ)
- 20 format(6x,10f6.2)
- enddo
- enddo
- else ! For newer ozone climatology
- read (NIO3CLM)
- do k = 1, LOZ
- read (NIO3CLM) pstr4(k)
- enddo
-
- do imo = 1, 12
- do k = 1, LOZ
- read (NIO3CLM) (o3clim4(j,k,imo),j=1,JMR)
- enddo
- enddo
- endif ! end if_LOZ_block
-!
- do imo = 1, 12
- do k = 1, LOZ
- do j = 1, JMR
- o3r(j,k,imo) = o3clim4(j,k,imo) * 1.655e-6
- enddo
- enddo
- enddo
-
- do k = 1, LOZ
- pstr(k) = pstr4(k)
- enddo
-
- if ( me == 0 ) then
- print *,' - Using climatology ozone distribution'
- print *,' Found ozone data for levels pstr=', &
- & (pstr(k),k=1,LOZ)
-! print *,' O3=',(o3r(15,k,1),k=1,LOZ)
- endif
-
- do k = 1, LOZ
- pkstr(k) = fpkapx(pstr(k)*100.0)
- enddo
- endif ! end if_ioznflg_block
-
! --- ... co2 data section
co2_glb = co2vmr_def
@@ -542,20 +417,18 @@ end subroutine gas_init
!!\param imon month of the year
!!\param iday day of the month
!!\param ihour hour of the day
-!!\param loz1st clim ozone 1st time update control flag
!!\param ldoco2 co2 update control flag
!!\param me print message control flag
!!\param co2dat_file co2 2d monthly obsv data table
!!\param co2gbl_file co2 global annual mean data table
!!\param ictmflg data ic time/date control flag
!!\param ico2flg co2 data source control flag
-!!\param ioznflg ozone data control flag
!!\param errflg error flag
!!\param errmsg error message
!>\section gen_gas_update gas_update General Algorithm
!-----------------------------------
- subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
- & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, ioznflg, &
+ subroutine gas_update(iyear, imon, iday, ihour, ldoco2, &
+ & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, &
& errflg, errmsg )
! =================================================================== !
@@ -568,7 +441,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! imon - month of the year 1 !
! iday - day of the month 1 !
! ihour - hour of the day 1 !
-! loz1st - clim ozone 1st time update control flag 1 !
! ldoco2 - co2 update control flag 1 !
! me - print message control flag 1 !
! ico2flg - co2 data source control flag !
@@ -588,9 +460,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! further data extrapolation. !
! =yyyy1: use yyyy data for the fcst. if needed, do !
! extrapolation to match the fcst time. !
-! ioznflg - ozone data control flag !
-! =0: use climatological ozone profile !
-! >0: use interactive ozone profile !
! ivflip - vertical profile indexing flag !
! co2dat_file - external co2 2d monthly obsv data table !
! co2gbl_file - external co2 global annual mean data table !
@@ -604,8 +473,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 !
! co2_glb - global annual mean co2 mixing ratio !
! gco2cyc - global monthly mean co2 variation 12 !
-! k1oz,k2oz,facoz !
-! - climatology ozone parameters 1 !
! !
! usage: call gas_update !
! !
@@ -617,9 +484,8 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! --- inputs:
integer, intent(in) :: iyear,imon,iday,ihour,me,ictmflg,ico2flg
- integer, intent(in) :: ioznflg
character(len=26),intent(in) :: co2dat_file, co2gbl_file
- logical, intent(in) :: loz1st, ldoco2
+ logical, intent(in) :: ldoco2
! --- output:
character(len=*), intent(out) :: errmsg
@@ -644,35 +510,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
errmsg = ''
errflg = 0
-!> - Ozone data section
-
- if ( ioznflg == 0 ) then
- midmon = mdays(imon)/2 + 1
- change = loz1st .or. ( (iday==midmon) .and. (ihour==0) )
-!
- if ( change ) then
- if ( iday < midmon ) then
- k1oz = mod(imon+10, 12) + 1
- midm = mdays(k1oz)/2 + 1
- k2oz = imon
- midp = mdays(k1oz) + midmon
- else
- k1oz = imon
- midm = midmon
- k2oz = mod(imon, 12) + 1
- midp = mdays(k2oz)/2 + 1 + mdays(k1oz)
- endif
- endif
-!
- if (iday < midmon) then
- id = iday + mdays(k1oz)
- else
- id = iday
- endif
-
- facoz = float(id - midm) / float(midp - midm)
- endif
-
!> - co2 data section
if ( ico2flg == 0 ) return ! use prescribed global mean co2 data
@@ -1104,119 +941,6 @@ subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, &
end subroutine getgases
!-----------------------------------
-!> This subroutine sets up climatological ozone profile for radiation
-!! calculation. This code is originally written by Shrinivas Moorthi.
-!!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$
-!!\param xlat (IMAX), latitude in radians, default to pi/2 ->
-!! -pi/2 range, otherwise see in-line comment
-!!\param IMAX, LM (1), horizontal and vertical dimensions
-!!\param top_at_1 (1), vertical profile indexing flag
-!!\param o3mmr (IMAX,LM), output ozone profile in mass mixing
-!! ratio (g/g)
-!>\section getozn_gen getozn General Algorithm
-!-----------------------------------
- subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr)
-
-! =================================================================== !
-! !
-! getozn sets up climatological ozone profile for radiation calculation!
-! !
-! this code is originally written By Shrinivas Moorthi !
-! !
-! inputs: !
-! prslk (IMAX,LM) - exner function = (p/p0)**rocp !
-! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 !
-! range, otherwise see in-line comment !
-! IMAX, LM - horizontal and vertical dimensions !
-! top_at_1 - vertical profile indexing flag !
-! !
-! outputs: !
-! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)!
-! !
-! module variables: !
-! k1oz, k2oz - ozone data interpolation indices !
-! facoz - ozone data interpolation factor !
-! !
-! usage: call getozn !
-! !
-! =================================================================== !
-!
- implicit none
-
-! --- inputs:
- integer, intent(in) :: IMAX, LM
- logical, intent(in) :: top_at_1
- real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:)
-
-! --- outputs:
- real (kind=kind_phys), intent(out) :: o3mmr(:,:)
-
-! --- locals:
- real (kind=kind_phys) :: o3i(IMAX,LOZ), wk1(IMAX), deglat, elte, &
- & tem, tem1, tem2, tem3, tem4, temp
- integer :: i, j, k, l, j1, j2, ll
-!
-!===> ... begin here
-!
- elte = blte + (JMR-1)*dlte
-
- do i = 1, IMAX
- deglat = xlat(i) * raddeg ! if xlat in pi/2 -> -pi/2 range
-! deglat = 90.0 - xlat(i)*raddeg ! if xlat in 0 -> pi range
-
- if (deglat > blte .and. deglat < elte) then
- tem1 = (deglat - blte) / dlte + 1
- j1 = tem1
- j2 = j1 + 1
- tem1 = tem1 - j1
- elseif (deglat <= blte) then
- j1 = 1
- j2 = 1
- tem1 = 1.0
- elseif (deglat >= elte) then
- j1 = JMR
- j2 = JMR
- tem1 = 1.0
- endif
-
- tem2 = 1.0 - tem1
- do j = 1, LOZ
- tem3 = tem2*o3r(j1,j,k1oz) + tem1*o3r(j2,j,k1oz)
- tem4 = tem2*o3r(j1,j,k2oz) + tem1*o3r(j2,j,k2oz)
- o3i(i,j) = tem4*facoz + tem3*(1.0 - facoz)
- enddo
- enddo
-
- do l = 1, LM
- ll = l
- if (.not. top_at_1) ll = LM -l + 1
-
- do i = 1, IMAX
- wk1(i) = prslk(i,ll)
- enddo
-
- do k = 1, LOZ-1
- temp = 1.0 / (pkstr(k+1) - pkstr(k))
-
- do i = 1, IMAX
- if (wk1(i) > pkstr(k) .and. wk1(i) <= pkstr(k+1)) then
- tem = (pkstr(k+1) - wk1(i)) * temp
- o3mmr(I,ll) = tem * o3i(i,k) + (1.0 - tem) * o3i(i,k+1)
- endif
- enddo
- enddo
-
- do i = 1, IMAX
- if (wk1(i) > pkstr(LOZ)) o3mmr(i,ll) = o3i(i,LOZ)
- if (wk1(i) < pkstr(1)) o3mmr(i,ll) = o3i(i,1)
- enddo
- enddo
-!
- return
-!...................................
- end subroutine getozn
-!-----------------------------------
-
!
!........................................!
end module module_radiation_gases !
diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90
index 67f7f749a..01b25c925 100644
--- a/physics/rrtmgp_lw_main.F90
+++ b/physics/rrtmgp_lw_main.F90
@@ -19,7 +19,6 @@ module rrtmgp_lw_main
use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init
use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, &
abssnow1, absrain
- use module_radiation_gases, only: NF_VGAS, getgases, getozn
use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, &
iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, &
eps, oneminus, ftiny
diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f
index 8a36fe34c..5853254c0 100644
--- a/physics/samfdeepcnv.f
+++ b/physics/samfdeepcnv.f
@@ -83,7 +83,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, &
& CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,&
& clam,c0s,c1,betal,betas,evef,pgcon,asolfac, &
& do_ca, ca_closure, ca_entr, ca_trigger, nthresh,ca_deep, &
- & rainevap,sigmain, sigmaout, errmsg,errflg)
+ & rainevap,sigmain,sigmaout,betadcu,betamcu,betascu, &
+ & maxMF, do_mynnedmf,errmsg,errflg)
!
use machine , only : kind_phys
use funcphys , only : fpvs
@@ -99,15 +100,16 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, &
& prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:)
real(kind=kind_phys), dimension(:), intent(in) :: fscav
logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, &
- & progsigma
- real(kind=kind_phys), intent(in) :: nthresh
+ & progsigma,do_mynnedmf
+ real(kind=kind_phys), intent(in) :: nthresh,betadcu,betamcu, &
+ & betascu
real(kind=kind_phys), intent(in) :: ca_deep(:)
real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), &
& tmf(:,:,:),q(:,:), prevsq(:,:)
+ real(kind=kind_phys), dimension (:), intent(in) :: maxMF
real(kind=kind_phys), intent(out) :: rainevap(:)
real(kind=kind_phys), intent(out) :: sigmaout(:,:)
logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger
-
integer, intent(inout) :: kcnv(:)
! DH* TODO - check dimensions of qtr, ntr+2 correct? *DH
real(kind=kind_phys), intent(inout) :: qtr(:,:,:), &
@@ -213,8 +215,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, &
! parameters for prognostic sigma closure
real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km),
& omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km)
- real(kind=kind_phys) gravinv,invdelt
- logical flag_shallow
+ real(kind=kind_phys) gravinv,invdelt,sigmind,sigminm,sigmins
+ parameter(sigmind=0.01,sigmins=0.03,sigminm=0.01)
+ logical flag_shallow, flag_mid
c physical parameters
! parameter(grav=grav,asolfac=0.958)
! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp))
@@ -347,6 +350,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, &
!
do i=1,im
cnvflg(i) = .true.
+ if(do_mynnedmf) then
+ if(maxMF(i).gt.0.)cnvflg(i)=.false.
+ endif
sfcpbl(i) = sfclfac * hpbl(i)
rn(i)=0.
mbdt(i)=10.
@@ -2930,10 +2936,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, &
enddo
flag_shallow = .false.
+ flag_mid = .false.
call progsigma_calc(im,km,first_time_step,restart,flag_shallow,
- & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt,
- & qadv,kbcon1,ktcon,cnvflg,
- & sigmain,sigmaout,sigmab)
+ & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,
+ & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu,
+ & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab)
endif
!> - From Han et al.'s (2017) \cite han_et_al_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.
diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta
index bed4d655d..23a8ae079 100644
--- a/physics/samfdeepcnv.meta
+++ b/physics/samfdeepcnv.meta
@@ -450,6 +450,44 @@
type = real
kind = kind_phys
intent = out
+[betascu]
+ standard_name = tuning_param_for_shallow_cu
+ long_name = tuning param for shallow cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[betamcu]
+ standard_name = tuning_param_for_midlevel_cu
+ long_name = tuning param for midlevel cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[betadcu]
+ standard_name = tuning_param_for_deep_cu
+ long_name = tuning param for deep cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ intent = in
+[maxMF]
+ standard_name = maximum_mass_flux
+ long_name = maximum mass flux within a column
+ units = m s-1
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = in
+[do_mynnedmf]
+ standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme
+ long_name = flag to activate MYNN-EDMF
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[qlcn]
standard_name = mass_fraction_of_convective_cloud_liquid_water
long_name = mass fraction of convective cloud liquid water
diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f
index a7682342f..3869ea6ea 100644
--- a/physics/samfshalcnv.f
+++ b/physics/samfshalcnv.f
@@ -57,7 +57,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, &
& rn,kbot,ktop,kcnv,islimsk,garea, &
& dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, &
& clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, &
- & sigmain,sigmaout,errmsg,errflg)
+ & sigmain,sigmaout,betadcu,betamcu,betascu,errmsg,errflg)
!
use machine , only : kind_phys
use funcphys , only : fpvs
@@ -67,7 +67,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, &
integer, intent(in) :: im, km, itc, ntc, ntk, ntr, ncloud
integer, intent(in) :: islimsk(:)
real(kind=kind_phys), intent(in) :: cliq, cp, cvap, &
- & eps, epsm1, fv, grav, hvap, rd, rv, t0c
+ & eps, epsm1, fv, grav, hvap, rd, rv, t0c, betascu, betadcu, &
+ & betamcu
real(kind=kind_phys), intent(in) :: delt
real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), &
& prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), &
@@ -159,8 +160,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, &
real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km),
& omegac(im),zeta(im,km),dbyo1(im,km),
& sigmab(im),qadv(im,km)
- real(kind=kind_phys) gravinv,dxcrtas,invdelt
- logical flag_shallow
+ real(kind=kind_phys) gravinv,dxcrtas,invdelt,sigmind,sigmins,
+ & sigminm
+ logical flag_shallow,flag_mid
c physical parameters
! parameter(g=grav,asolfac=0.89)
! parameter(g=grav)
@@ -194,7 +196,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, &
parameter(betaw=.03,dxcrtc0=9.e3)
parameter(h1=0.33333333)
! progsigma
- parameter(dxcrtas=30.e3)
+ parameter(dxcrtas=30.e3,sigmind=0.01,sigmins=0.03,sigminm=0.01)
c local variables and arrays
real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km),
& uo(im,km), vo(im,km), qeso(im,km),
@@ -1974,10 +1976,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, &
enddo
flag_shallow = .true.
+ flag_mid = .false.
call progsigma_calc(im,km,first_time_step,restart,flag_shallow,
- & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt,
- & qadv,kbcon1,ktcon,cnvflg,
- & sigmain,sigmaout,sigmab)
+ & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,
+ & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu,
+ & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab)
endif
!> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity.
diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta
index c1fffef58..200e33707 100644
--- a/physics/samfshalcnv.meta
+++ b/physics/samfshalcnv.meta
@@ -482,6 +482,29 @@
type = real
kind = kind_phys
intent = out
+[betascu]
+ standard_name = tuning_param_for_shallow_cu
+ long_name = tuning param for shallow cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[betamcu]
+ standard_name = tuning_param_for_midlevel_cu
+ long_name = tuning param for midlevel cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ intent = in
+[betadcu]
+ standard_name = tuning_param_for_deep_cu
+ long_name = tuning param for deep cu in case prognostic closure is used
+ units = none
+ dimensions = ()
+ type = real
+ intent = in
[errmsg]
standard_name = ccpp_error_message
long_name = error message for error handling in CCPP
diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90
index c1a43f170..6945e48e9 100644
--- a/physics/sfc_diag_post.F90
+++ b/physics/sfc_diag_post.F90
@@ -14,16 +14,17 @@ module sfc_diag_post
!!
#endif
subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, con_eps, con_epsm1, pgr,&
- t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, &
+ vegtype,t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, &
wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg)
use machine, only: kind_phys, kind_dbl_prec
implicit none
- integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag
- logical, intent(in) :: lssav
- real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1
+ integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag
+ integer, dimension(:), intent(in) :: vegtype ! vegetation type (integer index)
+ logical, intent(in) :: lssav
+ real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1
logical , dimension(:), intent(in) :: dry
real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m
real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax
@@ -41,12 +42,23 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, co
errflg = 0
if (lsm == lsm_noahmp) then
- if (opt_diag == 2 .or. opt_diag == 3)then
+! over shrublands use opt_diag=2
+ do i=1, im
+ if(dry(i)) then
+ if (vegtype(i) == 6 .or. vegtype(i) == 7 &
+ .or. vegtype(i) == 16) then
+ t2m(i) = t2mmp(i)
+ q2m(i) = q2mp(i)
+ endif
+ endif
+ enddo
+
+ if (opt_diag == 2 .or. opt_diag == 3) then
do i=1,im
if(dry(i)) then
t2m(i) = t2mmp(i)
q2m(i) = q2mp(i)
- endif
+ endif
enddo
endif
endif
diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta
index c50d3c4dc..17648753a 100644
--- a/physics/sfc_diag_post.meta
+++ b/physics/sfc_diag_post.meta
@@ -81,6 +81,13 @@
type = real
kind = kind_phys
intent = in
+[vegtype]
+ standard_name = vegetation_type_classification
+ long_name = vegetation type at each grid cell
+ units = index
+ dimensions = (horizontal_loop_extent)
+ type = integer
+ intent= in
[t2mmp]
standard_name = temperature_at_2m_from_noahmp
long_name = 2 meter temperature from noahmp
diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f
index 6e834537a..c5ed8bfa6 100644
--- a/physics/sfc_diff.f
+++ b/physics/sfc_diff.f
@@ -60,6 +60,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in)
& sigmaf,vegtype,shdmax,ivegsrc, & !intent(in)
& z0pert,ztpert, & ! mg, sfc-perts !intent(in)
& flag_iter,redrag, & !intent(in)
+ & flag_lakefreeze, & !intent(in)
& u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in)
& wet,dry,icy, & !intent(in)
& thsfc_loc, & !intent(in)
@@ -90,6 +91,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in)
logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han)
logical, dimension(:), intent(in) :: flag_iter, dry, icy
+ logical, dimension(:), intent(in) :: flag_lakefreeze
logical, dimension(:), intent(inout) :: wet
logical, intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation
@@ -168,7 +170,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in)
! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type
do i=1,im
- if(flag_iter(i)) then
+ if(flag_iter(i) .or. flag_lakefreeze(i)) then
! Need to initialize ztmax arrays
ztmax_lnd(i) = 1. ! log(1) = 0
diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta
index eb30b8c50..1aaad7239 100644
--- a/physics/sfc_diff.meta
+++ b/physics/sfc_diff.meta
@@ -194,6 +194,13 @@
dimensions = ()
type = logical
intent = in
+[flag_lakefreeze]
+ standard_name = flag_for_lake_water_freeze
+ long_name = flag for lake water freeze
+ units = flag
+ dimensions = (horizontal_loop_extent)
+ type = logical
+ intent = in
[u10m]
standard_name = x_wind_at_10m
long_name = 10 meter u wind speed
diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f
deleted file mode 100644
index 2ca70666d..000000000
--- a/physics/sfc_nst.f
+++ /dev/null
@@ -1,696 +0,0 @@
-!>\file sfc_nst.f
-!! This file contains the GFS NSST model.
-
-!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme.
- module sfc_nst
-
- contains
-
-!>\defgroup gfs_nst_main_mod GFS Near-Surface Sea Temperature Module
-!! This module contains the CCPP-compliant GFS near-surface sea temperature scheme.
-!> @{
-!! This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile.
-!! \section arg_table_sfc_nst_run Argument Table
-!! \htmlinclude sfc_nst_run.html
-!!
-!> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm
- subroutine sfc_nst_run &
- & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs:
- & pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, &
- & lseaspray, fm, fm10, &
- & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, &
- & sinlat, stress, &
- & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, &
- & wind, flag_iter, flag_guess, nstf_name1, nstf_name4, &
- & nstf_name5, lprnt, ipr, thsfc_loc, &
- & tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & ! --- input/output:
- & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, &
- & qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! --- outputs:
- & )
-!
-! ===================================================================== !
-! description: !
-! !
-! !
-! usage: !
-! !
-! call sfc_nst !
-! inputs: !
-! ( im, ps, u1, v1, t1, q1, tref, cm, ch, !
-! lseaspray, fm, fm10, !
-! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, !
-! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, !
-! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, !
-! nstf_name5, lprnt, ipr, thsfc_loc, !
-! input/outputs: !
-! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, !
-! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, !
-! -- outputs:
-! qsurf, gflux, cmm, chh, evap, hflx, ep !
-! )
-! !
-! !
-! subprogram/functions called: w3movdat, iw3jdn, fpvs, density, !
-! rhocoef, cool_skin, warm_layer, jacobi_temp. !
-! !
-! program history log: !
-! 2007 -- xu li createad original code !
-! 2008 -- s. moorthi adapted to the parallel version !
-! may 2009 -- y.-t. hou modified to include input lw surface !
-! emissivity from radiation. also replaced the !
-! often comfusing combined sw and lw suface !
-! flux with separate sfc net sw flux (defined !
-! as dn-up) and lw flux. added a program doc block. !
-! sep 2009 -- s. moorthi removed rcl and additional reformatting !
-! and optimization + made pa as input pressure unit.!
-! 2009 -- xu li recreatead the code !
-! feb 2010 -- s. moorthi added some changes made to the previous !
-! version !
-! Jul 2016 -- X. Li, modify the diurnal warming event reset !
-! !
-! !
-! ==================== definition of variables ==================== !
-! !
-! inputs: size !
-! im - integer, horiz dimension 1 !
-! ps - real, surface pressure (pa) im !
-! u1, v1 - real, u/v component of surface layer wind (m/s) im !
-! t1 - real, surface layer mean temperature ( k ) im !
-! q1 - real, surface layer mean specific humidity im !
-! tref - real, reference/foundation temperature ( k ) im !
-! cm - real, surface exchange coeff for momentum (m/s) im !
-! ch - real, surface exchange coeff heat & moisture(m/s) im !
-! lseaspray- logical, .t. for parameterization for sea spray 1 !
-! fm - real, a stability profile function for momentum im !
-! fm10 - real, a stability profile function for momentum im !
-! at 10m !
-! prsl1 - real, surface layer mean pressure (pa) im !
-! prslki - real, im !
-! prsik1 - real, im !
-! prslk1 - real, im !
-! wet - logical, =T if any ocn/lake water (F otherwise) im !
-! use_lake_model- logical, =T if flake model is used for lake im !
-! icy - logical, =T if any ice im !
-! xlon - real, longitude (radians) im !
-! sinlat - real, sin of latitude im !
-! stress - real, wind stress (n/m**2) im !
-! 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 ocean (w/m**2) im !
-! rain - real, rainfall rate (kg/m**2/s) im !
-! timestep - real, timestep interval (second) 1 !
-! kdt - integer, time step counter 1 !
-! solhr - real, fcst hour at the end of prev time step 1 !
-! xcosz - real, consine of solar zenith angle 1 !
-! wind - real, wind speed (m/s) im !
-! flag_iter- logical, execution or not im !
-! when iter = 1, flag_iter = .true. for all grids im !
-! when iter = 2, flag_iter = .true. when wind < 2 im !
-! for both land and ocean (when nstf_name1 > 0) im !
-! flag_guess-logical, .true.= guess step to get CD et al im !
-! when iter = 1, flag_guess = .true. when wind < 2 im !
-! when iter = 2, flag_guess = .false. for all grids im !
-! nstf_name - integers , NSST related flag parameters 1 !
-! nstf_name1 : 0 = NSSTM off 1 !
-! 1 = NSSTM on but uncoupled 1 !
-! 2 = NSSTM on and coupled 1 !
-! nstf_name4 : zsea1 in mm 1 !
-! nstf_name5 : zsea2 in mm 1 !
-! lprnt - logical, control flag for check print out 1 !
-! ipr - integer, grid index for check print out 1 !
-! thsfc_loc- logical, flag for reference pressure in theta 1 !
-! !
-! input/outputs:
-! li added for oceanic components
-! tskin - real, ocean surface skin temperature ( k ) im !
-! tsurf - real, the same as tskin ( k ) but for guess run im !
-! xt - real, heat content in dtl im !
-! xs - real, salinity content in dtl im !
-! xu - real, u-current content in dtl im !
-! xv - real, v-current content in dtl im !
-! xz - real, dtl thickness im !
-! zm - real, mxl thickness im !
-! xtts - real, d(xt)/d(ts) im !
-! xzts - real, d(xz)/d(ts) im !
-! dt_cool - real, sub-layer cooling amount im !
-! d_conv - real, thickness of free convection layer (fcl) im !
-! z_c - sub-layer cooling thickness im !
-! c_0 - coefficient1 to calculate d(tz)/d(ts) im !
-! c_d - coefficient2 to calculate d(tz)/d(ts) im !
-! w_0 - coefficient3 to calculate d(tz)/d(ts) im !
-! w_d - coefficient4 to calculate d(tz)/d(ts) im !
-! ifd - real, index to start dtlm run or not im !
-! qrain - real, sensible heat flux due to rainfall (watts) im !
-
-! outputs: !
-
-! qsurf - real, surface air saturation specific humidity 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 !
-! ep - real, potential evaporation im !
-! !
-! ===================================================================== !
- use machine , only : kind_phys
- use funcphys, only : fpvs
- use date_def, only : idate
- use module_nst_water_prop, only: get_dtzm_point
- use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh, &
- & sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max, &
- & rad2deg,const_rot,tau_min,tw_max,sst_max
- use module_nst_water_prop, only: solar_time_from_julian, &
- & density,rhocoef,compjd,grv &
- &, sw_ps_9b
- use nst_module, only : cool_skin,dtm_1p,cal_w,cal_ttop, &
- & convdepth,dtm_1p_fca,dtm_1p_tla, &
- & dtm_1p_mwa,dtm_1p_mda,dtm_1p_mta, &
- & dtl_reset
-!
- implicit none
-
- integer, parameter :: kp = kind_phys
-!
-! --- constant parameters:
- real (kind=kind_phys), parameter :: f24 = 24.0_kp ! hours/day
- real (kind=kind_phys), parameter :: f1440 = 1440.0_kp ! minutes/day
- real (kind=kind_phys), parameter :: czmin = 0.0001_kp ! cos(89.994)
- real (kind=kind_phys), parameter :: zero = 0.0_kp, one = 1.0_kp
-
-
-! --- inputs:
- integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, &
- & nstf_name5
- real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, &
- & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice
- real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, &
- & t1, q1, tref, cm, ch, fm, fm10, &
- & prsl1, prslki, prsik1, prslk1, xlon, xcosz, &
- & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind
- real (kind=kind_phys), intent(in) :: timestep
- real (kind=kind_phys), intent(in) :: solhr
-
-! For sea spray effect
- logical, intent(in) :: lseaspray
-!
- logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet
- integer, dimension(:), intent(in) :: use_lake_model
-! &, icy
- logical, intent(in) :: lprnt
- logical, intent(in) :: thsfc_loc
-
-! --- input/outputs:
-! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation
- real (kind=kind_phys), dimension(:), intent(inout) :: tskin, &
- & tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, &
- & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain
-
-! --- outputs:
- real (kind=kind_phys), dimension(:), intent(inout) :: &
- & qsurf, gflux, cmm, chh, evap, hflx, ep
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
-!
-! locals
-!
- integer :: k,i
-!
- real (kind=kind_phys), dimension(im) :: q0, qss, rch,
- & rho_a, theta1, tv1, wndmag
-
- real(kind=kind_phys) elocp,tem,cpinv,hvapi
-!
-! nstm related prognostic fields
-!
- logical flag(im)
- real (kind=kind_phys), dimension(im) ::
- & xt_old, xs_old, xu_old, xv_old, xz_old,zm_old,xtts_old,
- & xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old
-
- real(kind=kind_phys) ulwflx(im), nswsfc(im)
-! real(kind=kind_phys) rig(im),
-! & ulwflx(im),dlwflx(im),
-! & slrad(im),nswsfc(im)
- real(kind=kind_phys) alpha,beta,rho_w,f_nsol,sss,sep,
- & cosa,sina,taux,tauy,grav,dz,t0,ttop0,ttop
-
- real(kind=kind_phys) le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich
- real(kind=kind_phys) rnl_ts,hs_ts,hl_ts,rf_ts,q_ts
- real(kind=kind_phys) fw,q_warm
- real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz
- real(kind=kind_phys) zsea1,zsea2,soltim
- logical do_nst
-
-! external functions called: iw3jdn
- integer :: iw3jdn
-!
-! parameters for sea spray effect
-!
- real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1,
- & bb1, hflxs, evaps, ptem
-!
-! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1,
-! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0,
-! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2,
- real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15,
- & ws10cr=30., conlf=7.2e-9, consf=6.4e-8
-!
-!======================================================================================================
-cc
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if (nstf_name1 == 0) return ! No NSST model used
-
- cpinv = one/cp
- hvapi = one/hvap
- elocp = hvap/cp
-
- sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready
-!
-! flag for open water and where the iteration is on
-!
- do_nst = .false.
- do i = 1, im
-! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i)
- flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1
- do_nst = do_nst .or. flag(i)
- enddo
- if (.not. do_nst) return
-!
-! save nst-related prognostic fields for guess run
-!
- do i=1, im
-! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then
- if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then
- xt_old(i) = xt(i)
- xs_old(i) = xs(i)
- xu_old(i) = xu(i)
- xv_old(i) = xv(i)
- xz_old(i) = xz(i)
- zm_old(i) = zm(i)
- xtts_old(i) = xtts(i)
- xzts_old(i) = xzts(i)
- ifd_old(i) = ifd(i)
- tskin_old(i) = tskin(i)
- dt_cool_old(i) = dt_cool(i)
- z_c_old(i) = z_c(i)
- endif
- enddo
-
-
-! --- ... initialize variables. all units are m.k.s. unless specified.
-! ps is in pascals, wind is wind speed, theta1 is surface air
-! estimated from level 1 temperature, rho_a is air density and
-! qss is saturation specific humidity at the water surface
-!!
- do i = 1, im
- if ( flag(i) ) then
-
- nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward)
- wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i))
-
- q0(i) = max(q1(i), 1.0e-8_kp)
-
- if(thsfc_loc) then ! Use local potential temperature
- theta1(i) = t1(i) * prslki(i)
- else ! Use potential temperature referenced to 1000 hPa
- theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer
- endif
-
- tv1(i) = t1(i) * (one + rvrdm1*q0(i))
- rho_a(i) = prsl1(i) / (rd*tv1(i))
- qss(i) = fpvs(tsurf(i)) ! pa
- qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa
-!
- evap(i) = zero
- hflx(i) = zero
- gflux(i) = zero
- ep(i) = zero
-
-! --- ... rcp = rho cp ch v
-
- rch(i) = rho_a(i) * cp * ch(i) * wind(i)
- cmm(i) = cm (i) * wind(i)
- chh(i) = rho_a(i) * ch(i) * wind(i)
-
-!> - Calculate latent and sensible heat flux over open water with tskin.
-! at previous time step
- evap(i) = elocp * rch(i) * (qss(i) - q0(i))
- qsurf(i) = qss(i)
-
- if(thsfc_loc) then ! Use local potential temperature
- hflx(i) = rch(i) * (tsurf(i) - theta1(i))
- else ! Use potential temperature referenced to 1000 hPa
- hflx(i) = rch(i) * (tsurf(i)/prsik1(i) - theta1(i))
- endif
-
-! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=',
-! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i)
-! &,' tsurf=',tsurf(i)
- endif
- enddo
-
-! run nst model: dtm + slm
-!
- zsea1 = 0.001_kp*real(nstf_name4)
- zsea2 = 0.001_kp*real(nstf_name5)
-
-!> - Call module_nst_water_prop::density() to compute sea water density.
-!> - Call module_nst_water_prop::rhocoef() to compute thermal expansion
-!! coefficient (\a alpha) and saline contraction coefficient (\a beta).
- do i = 1, im
- if ( flag(i) ) then
- tsea = tsurf(i)
- t12 = tsea*tsea
- ulwflx(i) = sfcemis(i) * sbc * t12 * t12
- alon = xlon(i)*rad2deg
- grav = grv(sinlat(i))
- soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp
- call density(tsea,sss,rho_w) ! sea water density
- call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta
-!
-!> - Calculate sensible heat flux (\a qrain) due to rainfall.
-!
- le = (2.501_kp-0.00237_kp*tsea)*1e6_kp
- dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity
- dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k)
- & * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity
- wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i))
- alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor
- tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w
- qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp)
-
-!> - Calculate input non solar heat flux as upward = positive to models here
-
- f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i)
- & + omg_sh*qrain(i)
-
-! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=',
-! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i)
-! &,' omg_sh=',omg_sh,' qrain=',qrain(i)
-
- sep = sss*(evap(i)/le-rain(i))/rho_w
- ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity
-!
-! sensitivities of heat flux components to ts
-!
- rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts)
- hs_ts = rch(i)
- hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12)
- rf_ts = tem * (one+rch(i)*hl_ts)
- q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts
-!
-!> - Call cool_skin(), which is the sub-layer cooling parameterization
-!! (Fairfall et al. (1996) \cite fairall_et_al_1996).
-! & calculate c_0, c_d
-!
- call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta
- &, rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le
- &, dt_cool(i),z_c(i),c_0(i),c_d(i))
-
- tem = one / wndmag(i)
- cosa = u1(i)*tem
- sina = v1(i)*tem
- taux = max(stress(i),tau_min)*cosa
- tauy = max(stress(i),tau_min)*sina
- fc = const_rot*sinlat(i)
-!
-! Run DTM-1p system.
-!
- if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then
- else
- ifd(i) = one
-!
-! calculate fcl thickness with current forcing and previous time's profile
-!
-! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i)
-
-!> - Call convdepth() to calculate depth for convective adjustments.
- if ( f_nsol > zero .and. xt(i) > zero ) then
- call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w
- &, alpha,beta,xt(i),xs(i),xz(i),d_conv(i))
- else
- d_conv(i) = zero
- endif
-
-! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i)
-!
-! determine rich: wind speed dependent (right now)
-!
-! if ( wind(i) < 1.0 ) then
-! rich = 0.25 + 0.03*wind(i)
-! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then
-! rich = 0.25 + 0.1*wind(i)
-! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then
-! rich = 0.25 + 0.6*wind(i)
-! elseif ( wind(i) >= 6.0 ) then
-! rich = 0.25 + min(0.8*wind(i),0.50)
-! endif
-
- rich = ri_c
-
-!> - Call the diurnal thermocline layer model dtm_1p().
- call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i),
- & f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon,
- & sinlat(i),soltim,grav,le,d_conv(i),
- & xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
-
-! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i)
-
-! apply mda
- if ( xt(i) > zero ) then
-!> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply
-!! minimum depth adjustment (mda).
- call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i))
- if ( xz(i) >= z_w_max ) then
-!> - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset()
-!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max.
- call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i),
- & xzts(i))
-
-! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max='
-! &,z_w_max
- endif
-
-! apply fca
- if ( d_conv(i) > zero ) then
-!> - If thickness of free convection layer > 0.0, call dtm_1p_fca()
-!! to apply free convection adjustment.
-!> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset()
-!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max().
- call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i))
- if ( xz(i) >= z_w_max ) then
- call dtl_reset
- & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
- endif
- endif
-
-! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i)
-
-! apply tla
- dz = min(xz(i),max(d_conv(i),delz))
-!
-!> - Call sw_ps_9b() to compute the fraction of the solar radiation
-!! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981).
-!! And calculate the total heat absorbed in warm layer.
- call sw_ps_9b(delz,fw)
- q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer
-
-!> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with
-!! thickness of \a dz.
- if ( q_warm > zero ) then
- call cal_ttop(kdt,timestep,q_warm,rho_w,dz,
- & xt(i),xz(i),ttop0)
-
-! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=',
-! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i),
-! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i),
-! &' xz=',xz(i),' qrain=',qrain(i)
-
- ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i))))
-
-! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i)
-! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz
-! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0
-
-!> - Call dtm_1p_tla() to apply top layer adjustment.
- if ( ttop > ttop0 ) then
- call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i))
-
-! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=',
-! &z_w_max
- if ( xz(i) >= z_w_max ) then
- call dtl_reset
- & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
- endif
- endif
- endif ! if ( q_warm > 0.0 ) then
-
-! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i)
-
-! apply mwa
-!> - Call dt_1p_mwa() to apply maximum warming adjustment.
- t0 = (xt(i)+xt(i))/xz(i)
- if ( t0 > tw_max ) then
- call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i))
- if ( xz(i) >= z_w_max ) then
- call dtl_reset
- & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
- endif
- endif
-
-! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i)
-
-! apply mta
-!> - Call dtm_1p_mta() to apply maximum temperature adjustment.
- sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i)
-
- if ( sstc > sst_max ) then
- dta = sstc - sst_max
- call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i))
-! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i),
-! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i)
- if ( xz(i) >= z_w_max ) then
- call dtl_reset
- & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
- endif
- endif
-!
- endif ! if ( xt(i) > 0.0 ) then
-! reset dtl at midnight and when solar zenith angle > 89.994 degree
- if ( abs(soltim) < 2.0_kp*timestep ) then
- call dtl_reset
- & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
- endif
-
- endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day
-
-! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i)
-
-! update tsurf (when flag(i) .eqv. .true. )
-!> - Call get_dtzm_point() to computes \a dtz and \a tsurf.
- call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i),
- & zsea1,zsea2,dtz)
- tsurf(i) = max(tgice, tref(i) + dtz )
-
-! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=',
-! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i)
-
-!> - Call cal_w() to calculate \a w_0 and \a w_d.
- if ( xt(i) > zero ) then
- call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i))
- else
- w_0(i) = zero
- w_d(i) = zero
- endif
-
-! if ( xt(i) > 0.0 ) then
-! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i))
-! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i)))
-! else
-! rig(i) = 0.25
-! endif
-
-! qrain(i) = rig(i)
- zm(i) = wind(i)
-
- endif
- enddo
-
-! restore nst-related prognostic fields for guess run
- do i=1, im
-! if (wet(i) .and. .not.icy(i)) then
- if (wet(i) .and. use_lake_model(i)/=1) then
- if (flag_guess(i)) then ! when it is guess of
- xt(i) = xt_old(i)
- xs(i) = xs_old(i)
- xu(i) = xu_old(i)
- xv(i) = xv_old(i)
- xz(i) = xz_old(i)
- zm(i) = zm_old(i)
- xtts(i) = xtts_old(i)
- xzts(i) = xzts_old(i)
- ifd(i) = ifd_old(i)
- tskin(i) = tskin_old(i)
- dt_cool(i) = dt_cool_old(i)
- z_c(i) = z_c_old(i)
- else
-!
-! update tskin when coupled and not guess run
-! (all other NSST variables have been updated in this case)
-!
- if ( nstf_name1 > 1 ) then
- tskin(i) = tsurf(i)
- endif ! if nstf_name1 > 1 then
- endif ! if flag_guess(i) then
- endif ! if wet(i) .and. .not.icy(i) then
- enddo
-
-! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i)
-
- if ( nstf_name1 > 1 ) then
-!> - Calculate latent and sensible heat flux over open water with updated tskin
-!! for the grids of open water and the iteration is on.
- do i = 1, im
- if ( flag(i) ) then
- qss(i) = fpvs( tskin(i) )
- qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i))
- qsurf(i) = qss(i)
- evap(i) = elocp*rch(i) * (qss(i) - q0(i))
-
- if(thsfc_loc) then ! Use local potential temperature
- hflx(i) = rch(i) * (tskin(i) - theta1(i))
- else ! Use potential temperature referenced to 1000 hPa
- hflx(i) = rch(i) * (tskin(i)/prsik1(i) - theta1(i))
- endif
-
- endif
- enddo
- endif ! if ( nstf_name1 > 1 ) then
-!
-!> - Include sea spray effects
-!
- do i=1,im
- if(lseaspray .and. flag(i)) then
- f10m = fm10(i) / fm(i)
- u10m = f10m * u1(i)
- v10m = f10m * v1(i)
- ws10 = sqrt(u10m*u10m + v10m*v10m)
- ws10 = max(ws10,1.)
- ws10 = min(ws10,ws10cr)
- tem = .015 * ws10 * ws10
- ru10 = 1. - .087 * log(10./tem)
- qss1 = fpvs(t1(i))
- qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1)
- tem = rd * cp * t1(i) * t1(i)
- tem = 1. + eps * hvap * hvap * qss1 / tem
- bb1 = 1. / tem
- evaps = conlf * (ws10**5.4) * ru10 * bb1
- evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i))
- evap(i) = evap(i) + alps * evaps
- hflxs = consf * (ws10**3.4) * ru10
- hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i))
- ptem = alps - gams
- hflx(i) = hflx(i) + bets * hflxs - ptem * evaps
- endif
- enddo
-!
- do i=1,im
- if ( flag(i) ) then
- tem = one / rho_a(i)
- hflx(i) = hflx(i) * tem * cpinv
- evap(i) = evap(i) * tem * hvapi
- endif
- enddo
-!
-! if (lprnt) print *,' tskin=',tskin(ipr)
-
- return
- end subroutine sfc_nst_run
-!> @}
- end module sfc_nst
diff --git a/physics/sfc_nst.f90 b/physics/sfc_nst.f90
new file mode 100644
index 000000000..08b1b48e4
--- /dev/null
+++ b/physics/sfc_nst.f90
@@ -0,0 +1,664 @@
+!>\file sfc_nst.f90
+!! This file contains the GFS NSST model.
+
+!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme.
+module sfc_nst
+
+ use machine , only : kind_phys, kp => kind_phys
+ use funcphys , only : fpvs
+ use module_nst_parameters , only : one, zero, half
+ use module_nst_parameters , only : t0k, cp_w, omg_m, omg_sh, sigma_r, solar_time_6am, sst_max
+ use module_nst_parameters , only : ri_c, z_w_max, delz, wd_max, rad2deg, const_rot, tau_min, tw_max
+ use module_nst_water_prop , only : get_dtzm_point, density, rhocoef, grv, sw_ps_9b
+ use nst_module , only : cool_skin, dtm_1p, cal_w, cal_ttop, convdepth, dtm_1p_fca
+ use nst_module , only : dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, dtl_reset
+ !
+ implicit none
+contains
+
+ !>\defgroup gfs_nst_main_mod GFS Near-Surface Sea Temperature Module
+ !! This module contains the CCPP-compliant GFS near-surface sea temperature scheme.
+ !> @{
+ !! This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile.
+ !! \section arg_table_sfc_nst_run Argument Table
+ !! \htmlinclude sfc_nst_run.html
+ !!
+ !> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm
+ subroutine sfc_nst_run &
+ ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs:
+ pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, &
+ lseaspray, fm, fm10, &
+ prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, &
+ sinlat, stress, &
+ sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, &
+ wind, flag_iter, flag_guess, nstf_name1, nstf_name4, &
+ nstf_name5, lprnt, ipr, thsfc_loc, &
+ tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & ! --- input/output:
+ z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, &
+ qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! --- outputs:
+ )
+ !
+ ! ===================================================================== !
+ ! description: !
+ ! !
+ ! !
+ ! usage: !
+ ! !
+ ! call sfc_nst !
+ ! inputs: !
+ ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, !
+ ! lseaspray, fm, fm10, !
+ ! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, !
+ ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, !
+ ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, !
+ ! nstf_name5, lprnt, ipr, thsfc_loc, !
+ ! input/outputs: !
+ ! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, !
+ ! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, !
+ ! -- outputs:
+ ! qsurf, gflux, cmm, chh, evap, hflx, ep !
+ ! )
+ ! !
+ ! !
+ ! subprogram/functions called: fpvs, density, rhocoef, cool_skin !
+ ! !
+ ! program history log: !
+ ! 2007 -- xu li createad original code !
+ ! 2008 -- s. moorthi adapted to the parallel version !
+ ! may 2009 -- y.-t. hou modified to include input lw surface !
+ ! emissivity from radiation. also replaced the !
+ ! often comfusing combined sw and lw suface !
+ ! flux with separate sfc net sw flux (defined !
+ ! as dn-up) and lw flux. added a program doc block. !
+ ! sep 2009 -- s. moorthi removed rcl and additional reformatting !
+ ! and optimization + made pa as input pressure unit.!
+ ! 2009 -- xu li recreatead the code !
+ ! feb 2010 -- s. moorthi added some changes made to the previous !
+ ! version !
+ ! Jul 2016 -- X. Li, modify the diurnal warming event reset !
+ ! !
+ ! !
+ ! ==================== definition of variables ==================== !
+ ! !
+ ! inputs: size !
+ ! im - integer, horiz dimension 1 !
+ ! ps - real, surface pressure (pa) im !
+ ! u1, v1 - real, u/v component of surface layer wind (m/s) im !
+ ! t1 - real, surface layer mean temperature ( k ) im !
+ ! q1 - real, surface layer mean specific humidity im !
+ ! tref - real, reference/foundation temperature ( k ) im !
+ ! cm - real, surface exchange coeff for momentum (m/s) im !
+ ! ch - real, surface exchange coeff heat & moisture(m/s) im !
+ ! lseaspray- logical, .t. for parameterization for sea spray 1 !
+ ! fm - real, a stability profile function for momentum im !
+ ! fm10 - real, a stability profile function for momentum im !
+ ! at 10m !
+ ! prsl1 - real, surface layer mean pressure (pa) im !
+ ! prslki - real, im !
+ ! prsik1 - real, im !
+ ! prslk1 - real, im !
+ ! wet - logical, =T if any ocn/lake water (F otherwise) im !
+ ! use_lake_model- logical, =T if flake model is used for lake im !
+ ! icy - logical, =T if any ice im !
+ ! xlon - real, longitude (radians) im !
+ ! sinlat - real, sin of latitude im !
+ ! stress - real, wind stress (n/m**2) im !
+ ! 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 ocean (w/m**2) im !
+ ! rain - real, rainfall rate (kg/m**2/s) im !
+ ! timestep - real, timestep interval (second) 1 !
+ ! kdt - integer, time step counter 1 !
+ ! solhr - real, fcst hour at the end of prev time step 1 !
+ ! xcosz - real, consine of solar zenith angle 1 !
+ ! wind - real, wind speed (m/s) im !
+ ! flag_iter- logical, execution or not im !
+ ! when iter = 1, flag_iter = .true. for all grids im !
+ ! when iter = 2, flag_iter = .true. when wind < 2 im !
+ ! for both land and ocean (when nstf_name1 > 0) im !
+ ! flag_guess-logical, .true.= guess step to get CD et al im !
+ ! when iter = 1, flag_guess = .true. when wind < 2 im !
+ ! when iter = 2, flag_guess = .false. for all grids im !
+ ! nstf_name - integers , NSST related flag parameters 1 !
+ ! nstf_name1 : 0 = NSSTM off 1 !
+ ! 1 = NSSTM on but uncoupled 1 !
+ ! 2 = NSSTM on and coupled 1 !
+ ! nstf_name4 : zsea1 in mm 1 !
+ ! nstf_name5 : zsea2 in mm 1 !
+ ! lprnt - logical, control flag for check print out 1 !
+ ! ipr - integer, grid index for check print out 1 !
+ ! thsfc_loc- logical, flag for reference pressure in theta 1 !
+ ! !
+ ! input/outputs:
+ ! li added for oceanic components
+ ! tskin - real, ocean surface skin temperature ( k ) im !
+ ! tsurf - real, the same as tskin ( k ) but for guess run im !
+ ! xt - real, heat content in dtl im !
+ ! xs - real, salinity content in dtl im !
+ ! xu - real, u-current content in dtl im !
+ ! xv - real, v-current content in dtl im !
+ ! xz - real, dtl thickness im !
+ ! zm - real, mxl thickness im !
+ ! xtts - real, d(xt)/d(ts) im !
+ ! xzts - real, d(xz)/d(ts) im !
+ ! dt_cool - real, sub-layer cooling amount im !
+ ! d_conv - real, thickness of free convection layer (fcl) im !
+ ! z_c - sub-layer cooling thickness im !
+ ! c_0 - coefficient1 to calculate d(tz)/d(ts) im !
+ ! c_d - coefficient2 to calculate d(tz)/d(ts) im !
+ ! w_0 - coefficient3 to calculate d(tz)/d(ts) im !
+ ! w_d - coefficient4 to calculate d(tz)/d(ts) im !
+ ! ifd - real, index to start dtlm run or not im !
+ ! qrain - real, sensible heat flux due to rainfall (watts) im !
+
+ ! outputs: !
+
+ ! qsurf - real, surface air saturation specific humidity 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 !
+ ! ep - real, potential evaporation im !
+ ! !
+ ! ===================================================================== !
+
+
+
+ ! --- inputs:
+ integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, nstf_name5
+ real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, &
+ epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice
+ real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, &
+ t1, q1, tref, cm, ch, fm, fm10, &
+ prsl1, prslki, prsik1, prslk1, xlon, xcosz, &
+ sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind
+ real (kind=kind_phys), intent(in) :: timestep
+ real (kind=kind_phys), intent(in) :: solhr
+
+ ! For sea spray effect
+ logical, intent(in) :: lseaspray
+ !
+ logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet
+ integer, dimension(:), intent(in) :: use_lake_model
+ logical, intent(in) :: lprnt
+ logical, intent(in) :: thsfc_loc
+
+ ! --- input/outputs:
+ ! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation
+ real (kind=kind_phys), dimension(:), intent(inout) :: tskin, &
+ tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, &
+ z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain
+
+ ! --- outputs:
+ real (kind=kind_phys), dimension(:), intent(inout) :: qsurf, gflux, cmm, chh, evap, hflx, ep
+
+ character(len=*), intent(out) :: errmsg
+ integer, intent(out) :: errflg
+
+ !
+ ! locals
+ !
+ integer :: k,i
+ !
+ real (kind=kind_phys), dimension(im) :: q0, qss, rch, rho_a, theta1, tv1, wndmag
+
+ real(kind=kind_phys) :: elocp,tem,cpinv,hvapi
+ !
+ ! nstm related prognostic fields
+ !
+ logical :: flag(im)
+ real (kind=kind_phys), dimension(im) :: xt_old, xs_old, xu_old, xv_old, xz_old, &
+ zm_old,xtts_old, xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old
+
+ real(kind=kind_phys) :: ulwflx(im), nswsfc(im)
+ ! real(kind=kind_phys) rig(im),
+ ! & ulwflx(im),dlwflx(im),
+ ! & slrad(im),nswsfc(im)
+ real(kind=kind_phys) :: alpha,beta,rho_w,f_nsol,sss,sep, cosa,sina,taux,tauy, &
+ grav,dz,t0,ttop0,ttop
+
+ real(kind=kind_phys) :: le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich
+ real(kind=kind_phys) :: rnl_ts,hs_ts,hl_ts,rf_ts,q_ts
+ real(kind=kind_phys) :: fw,q_warm
+ real(kind=kind_phys) :: t12,alon,tsea,sstc,dta,dtz
+ real(kind=kind_phys) :: zsea1,zsea2,soltim
+ logical :: do_nst
+ !
+ ! parameters for sea spray effect
+ !
+ real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, &
+ bb1, hflxs, evaps, ptem
+ !
+ ! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1,
+ ! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0,
+ ! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2,
+ real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, &
+ ws10cr=30., conlf=7.2e-9, consf=6.4e-8
+ !
+ !======================================================================================================
+ ! Initialize CCPP error handling variables
+ errmsg = ''
+ errflg = 0
+
+ if (nstf_name1 == 0) return ! No NSST model used
+
+ cpinv = one/cp
+ hvapi = one/hvap
+ elocp = hvap/cp
+
+ sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready
+ !
+ ! flag for open water and where the iteration is on
+ !
+ do_nst = .false.
+ do i = 1, im
+ ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i)
+ flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1
+ do_nst = do_nst .or. flag(i)
+ enddo
+ if (.not. do_nst) return
+ !
+ ! save nst-related prognostic fields for guess run
+ !
+ do i=1, im
+ ! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then
+ if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then
+ xt_old(i) = xt(i)
+ xs_old(i) = xs(i)
+ xu_old(i) = xu(i)
+ xv_old(i) = xv(i)
+ xz_old(i) = xz(i)
+ zm_old(i) = zm(i)
+ xtts_old(i) = xtts(i)
+ xzts_old(i) = xzts(i)
+ ifd_old(i) = ifd(i)
+ tskin_old(i) = tskin(i)
+ dt_cool_old(i) = dt_cool(i)
+ z_c_old(i) = z_c(i)
+ endif
+ enddo
+
+
+ ! --- ... initialize variables. all units are m.k.s. unless specified.
+ ! ps is in pascals, wind is wind speed, theta1 is surface air
+ ! estimated from level 1 temperature, rho_a is air density and
+ ! qss is saturation specific humidity at the water surface
+ !!
+ do i = 1, im
+ if ( flag(i) ) then
+
+ nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward)
+ wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i))
+
+ q0(i) = max(q1(i), 1.0e-8_kp)
+
+ if(thsfc_loc) then ! Use local potential temperature
+ theta1(i) = t1(i) * prslki(i)
+ else ! Use potential temperature referenced to 1000 hPa
+ theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer
+ endif
+
+ tv1(i) = t1(i) * (one + rvrdm1*q0(i))
+ rho_a(i) = prsl1(i) / (rd*tv1(i))
+ qss(i) = fpvs(tsurf(i)) ! pa
+ qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa
+ !
+ evap(i) = zero
+ hflx(i) = zero
+ gflux(i) = zero
+ ep(i) = zero
+
+ ! --- ... rcp = rho cp ch v
+
+ rch(i) = rho_a(i) * cp * ch(i) * wind(i)
+ cmm(i) = cm (i) * wind(i)
+ chh(i) = rho_a(i) * ch(i) * wind(i)
+
+ !> - Calculate latent and sensible heat flux over open water with tskin.
+ ! at previous time step
+ evap(i) = elocp * rch(i) * (qss(i) - q0(i))
+ qsurf(i) = qss(i)
+
+ if(thsfc_loc) then ! Use local potential temperature
+ hflx(i) = rch(i) * (tsurf(i) - theta1(i))
+ else ! Use potential temperature referenced to 1000 hPa
+ hflx(i) = rch(i) * (tsurf(i)/prsik1(i) - theta1(i))
+ endif
+
+ ! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=',
+ ! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i)
+ ! &,' tsurf=',tsurf(i)
+ endif
+ enddo
+
+ ! run nst model: dtm + slm
+ !
+ zsea1 = 0.001_kp*real(nstf_name4)
+ zsea2 = 0.001_kp*real(nstf_name5)
+
+ !> - Call module_nst_water_prop::density() to compute sea water density.
+ !> - Call module_nst_water_prop::rhocoef() to compute thermal expansion
+ !! coefficient (\a alpha) and saline contraction coefficient (\a beta).
+ do i = 1, im
+ if ( flag(i) ) then
+ tsea = tsurf(i)
+ t12 = tsea*tsea
+ ulwflx(i) = sfcemis(i) * sbc * t12 * t12
+ alon = xlon(i)*rad2deg
+ grav = grv(sinlat(i))
+ soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp
+ call density(tsea,sss,rho_w) ! sea water density
+ call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta
+ !
+ !> - Calculate sensible heat flux (\a qrain) due to rainfall.
+ !
+ le = (2.501_kp-0.00237_kp*tsea)*1.0e6_kp
+ dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity
+ dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k) &
+ * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity
+ wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i))
+ alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor
+ tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w
+ qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp)
+
+ !> - Calculate input non solar heat flux as upward = positive to models here
+
+ f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i) + omg_sh*qrain(i)
+
+ ! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=',
+ ! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i)
+ ! &,' omg_sh=',omg_sh,' qrain=',qrain(i)
+
+ sep = sss*(evap(i)/le-rain(i))/rho_w
+ ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity
+ !
+ ! sensitivities of heat flux components to ts
+ !
+ rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts)
+ hs_ts = rch(i)
+ hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12)
+ rf_ts = tem * (one+rch(i)*hl_ts)
+ q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts
+ !
+ !> - Call cool_skin(), which is the sub-layer cooling parameterization
+ !! (Fairfall et al. (1996) \cite fairall_et_al_1996).
+ ! & calculate c_0, c_d
+ !
+ call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta, &
+ rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le, &
+ dt_cool(i),z_c(i),c_0(i),c_d(i))
+
+ tem = one / wndmag(i)
+ cosa = u1(i)*tem
+ sina = v1(i)*tem
+ taux = max(stress(i),tau_min)*cosa
+ tauy = max(stress(i),tau_min)*sina
+ fc = const_rot*sinlat(i)
+ !
+ ! Run DTM-1p system.
+ !
+ if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then
+ else
+ ifd(i) = one
+ !
+ ! calculate fcl thickness with current forcing and previous time's profile
+ !
+ ! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i)
+
+ !> - Call convdepth() to calculate depth for convective adjustments.
+ if ( f_nsol > zero .and. xt(i) > zero ) then
+ call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w, &
+ alpha,beta,xt(i),xs(i),xz(i),d_conv(i))
+ else
+ d_conv(i) = zero
+ endif
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i)
+ !
+ ! determine rich: wind speed dependent (right now)
+ !
+ ! if ( wind(i) < 1.0 ) then
+ ! rich = 0.25 + 0.03*wind(i)
+ ! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then
+ ! rich = 0.25 + 0.1*wind(i)
+ ! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then
+ ! rich = 0.25 + 0.6*wind(i)
+ ! elseif ( wind(i) >= 6.0 ) then
+ ! rich = 0.25 + min(0.8*wind(i),0.50)
+ ! endif
+
+ rich = ri_c
+
+ !> - Call the diurnal thermocline layer model dtm_1p().
+ call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), &
+ f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, &
+ sinlat(i),soltim,grav,le,d_conv(i), &
+ xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i)
+
+ ! apply mda
+ if ( xt(i) > zero ) then
+ !> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply
+ !! minimum depth adjustment (mda).
+ call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i))
+ if ( xz(i) >= z_w_max ) then
+ !> - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset()
+ !! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max.
+ call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i), xzts(i))
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max='
+ ! &,z_w_max
+ endif
+
+ ! apply fca
+ if ( d_conv(i) > zero ) then
+ !> - If thickness of free convection layer > 0.0, call dtm_1p_fca()
+ !! to apply free convection adjustment.
+ !> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset()
+ !! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max().
+ call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i))
+ if ( xz(i) >= z_w_max ) then
+ call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
+ endif
+ endif
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i)
+
+ ! apply tla
+ dz = min(xz(i),max(d_conv(i),delz))
+ !
+ !> - Call sw_ps_9b() to compute the fraction of the solar radiation
+ !! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981).
+ !! And calculate the total heat absorbed in warm layer.
+ call sw_ps_9b(delz,fw)
+ q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer
+
+ !> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with
+ !! thickness of \a dz.
+ if ( q_warm > zero ) then
+ call cal_ttop(kdt,timestep,q_warm,rho_w,dz, xt(i),xz(i),ttop0)
+
+ ! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=',
+ ! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i),
+ ! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i),
+ ! &' xz=',xz(i),' qrain=',qrain(i)
+
+ ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i))))
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i)
+ ! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz
+ ! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0
+
+ !> - Call dtm_1p_tla() to apply top layer adjustment.
+ if ( ttop > ttop0 ) then
+ call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i))
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=',
+ ! &z_w_max
+ if ( xz(i) >= z_w_max ) then
+ call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
+ endif
+ endif
+ endif ! if ( q_warm > 0.0 ) then
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i)
+
+ ! apply mwa
+ !> - Call dt_1p_mwa() to apply maximum warming adjustment.
+ t0 = (xt(i)+xt(i))/xz(i)
+ if ( t0 > tw_max ) then
+ call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i))
+ if ( xz(i) >= z_w_max ) then
+ call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
+ endif
+ endif
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i)
+
+ ! apply mta
+ !> - Call dtm_1p_mta() to apply maximum temperature adjustment.
+ sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i)
+
+ if ( sstc > sst_max ) then
+ dta = sstc - sst_max
+ call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i))
+ ! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i),
+ ! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i)
+ if ( xz(i) >= z_w_max ) then
+ call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
+ endif
+ endif
+ !
+ endif ! if ( xt(i) > 0.0 ) then
+ ! reset dtl at midnight and when solar zenith angle > 89.994 degree
+ if ( abs(soltim) < 2.0_kp*timestep ) then
+ call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
+ endif
+
+ endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i)
+
+ ! update tsurf (when flag(i) .eqv. .true. )
+ !> - Call get_dtzm_point() to computes \a dtz and \a tsurf.
+ call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), zsea1,zsea2,dtz)
+ tsurf(i) = max(tgice, tref(i) + dtz )
+
+ ! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=',
+ ! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i)
+
+ !> - Call cal_w() to calculate \a w_0 and \a w_d.
+ if ( xt(i) > zero ) then
+ call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i))
+ else
+ w_0(i) = zero
+ w_d(i) = zero
+ endif
+
+ ! if ( xt(i) > 0.0 ) then
+ ! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i))
+ ! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i)))
+ ! else
+ ! rig(i) = 0.25
+ ! endif
+
+ ! qrain(i) = rig(i)
+ zm(i) = wind(i)
+
+ endif
+ enddo
+
+ ! restore nst-related prognostic fields for guess run
+ do i=1, im
+ ! if (wet(i) .and. .not.icy(i)) then
+ if (wet(i) .and. use_lake_model(i)/=1) then
+ if (flag_guess(i)) then ! when it is guess of
+ xt(i) = xt_old(i)
+ xs(i) = xs_old(i)
+ xu(i) = xu_old(i)
+ xv(i) = xv_old(i)
+ xz(i) = xz_old(i)
+ zm(i) = zm_old(i)
+ xtts(i) = xtts_old(i)
+ xzts(i) = xzts_old(i)
+ ifd(i) = ifd_old(i)
+ tskin(i) = tskin_old(i)
+ dt_cool(i) = dt_cool_old(i)
+ z_c(i) = z_c_old(i)
+ else
+ !
+ ! update tskin when coupled and not guess run
+ ! (all other NSST variables have been updated in this case)
+ !
+ if ( nstf_name1 > 1 ) then
+ tskin(i) = tsurf(i)
+ endif ! if nstf_name1 > 1 then
+ endif ! if flag_guess(i) then
+ endif ! if wet(i) .and. .not.icy(i) then
+ enddo
+
+ ! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i)
+
+ if ( nstf_name1 > 1 ) then
+ !> - Calculate latent and sensible heat flux over open water with updated tskin
+ !! for the grids of open water and the iteration is on.
+ do i = 1, im
+ if ( flag(i) ) then
+ qss(i) = fpvs( tskin(i) )
+ qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i))
+ qsurf(i) = qss(i)
+ evap(i) = elocp*rch(i) * (qss(i) - q0(i))
+
+ if(thsfc_loc) then ! Use local potential temperature
+ hflx(i) = rch(i) * (tskin(i) - theta1(i))
+ else ! Use potential temperature referenced to 1000 hPa
+ hflx(i) = rch(i) * (tskin(i)/prsik1(i) - theta1(i))
+ endif
+
+ endif
+ enddo
+ endif ! if ( nstf_name1 > 1 ) then
+ !
+ !> - Include sea spray effects
+ !
+ do i=1,im
+ if(lseaspray .and. flag(i)) then
+ f10m = fm10(i) / fm(i)
+ u10m = f10m * u1(i)
+ v10m = f10m * v1(i)
+ ws10 = sqrt(u10m*u10m + v10m*v10m)
+ ws10 = max(ws10,1.)
+ ws10 = min(ws10,ws10cr)
+ tem = .015 * ws10 * ws10
+ ru10 = 1. - .087 * log(10./tem)
+ qss1 = fpvs(t1(i))
+ qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1)
+ tem = rd * cp * t1(i) * t1(i)
+ tem = 1. + eps * hvap * hvap * qss1 / tem
+ bb1 = 1. / tem
+ evaps = conlf * (ws10**5.4) * ru10 * bb1
+ evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i))
+ evap(i) = evap(i) + alps * evaps
+ hflxs = consf * (ws10**3.4) * ru10
+ hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i))
+ ptem = alps - gams
+ hflx(i) = hflx(i) + bets * hflxs - ptem * evaps
+ endif
+ enddo
+ !
+ do i=1,im
+ if ( flag(i) ) then
+ tem = one / rho_a(i)
+ hflx(i) = hflx(i) * tem * cpinv
+ evap(i) = evap(i) * tem * hvapi
+ endif
+ enddo
+ !
+ ! if (lprnt) print *,' tskin=',tskin(ipr)
+
+ return
+ end subroutine sfc_nst_run
+ !> @}
+end module sfc_nst
diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f
deleted file mode 100644
index 83bc2f273..000000000
--- a/physics/sfc_nst_post.f
+++ /dev/null
@@ -1,93 +0,0 @@
-!> \file sfc_nst_post.f
-!! This file contains code to be executed after the GFS NSST model.
-
- module sfc_nst_post
-
- contains
-
-! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post
-
-!> \section arg_table_sfc_nst_post_run Argument Table
-!! \htmlinclude sfc_nst_post_run.html
-!!
-! \section NSST_general_post_algorithm General Algorithm
-!
-! \section NSST_detailed_post_algorithm Detailed Algorithm
-! @{
- subroutine sfc_nst_post_run &
- & ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, &
- & oro_uf, nstf_name1, &
- & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, &
- & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg &
- & )
-
- use machine , only : kind_phys
- use module_nst_water_prop, only: get_dtzm_2d
-
- implicit none
-
- integer, parameter :: kp = kind_phys
-
-! --- inputs:
- integer, intent(in) :: im, kdt, nthreads
- logical, dimension(:), intent(in) :: wet, icy
- integer, dimension(:), intent(in) :: use_lake_model
- real (kind=kind_phys), intent(in) :: rlapse, tgice
- real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf
- integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5
- real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, &
- & dt_cool, z_c, tref, xlon
-
-! --- input/outputs:
- real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, &
- & tsfc_wat
-
-! --- outputs:
- real (kind=kind_phys), dimension(:), intent(out) :: dtzm
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
-! --- locals
- integer :: i
- real(kind=kind_phys) :: zsea1, zsea2
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
-! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr),
-! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr),
-! & ' kdt=',kdt
-
-! do i = 1, im
-! if (wet(i) .and. .not. icy(i)) then
-! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse
-! endif
-! enddo
-
-! --- ... run nsst model ... ---
-
- if (nstf_name1 > 1) then
- zsea1 = 0.001_kp*real(nstf_name4)
- zsea2 = 0.001_kp*real(nstf_name5)
- call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, &
- & im, 1, nthreads, dtzm)
- do i = 1, im
-! if (wet(i) .and. .not.icy(i)) then
-! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then
- if (wet(i) .and. use_lake_model(i) /=1) then
- tsfc_wat(i) = max(tgice, tref(i) + dtzm(i))
-! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - &
-! (oro(i)-oro_uf(i))*rlapse
- endif
- enddo
- endif
-
-! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), &
-! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt
-
- return
- end subroutine sfc_nst_post_run
-
- end module sfc_nst_post
diff --git a/physics/sfc_nst_post.f90 b/physics/sfc_nst_post.f90
new file mode 100644
index 000000000..174d5df76
--- /dev/null
+++ b/physics/sfc_nst_post.f90
@@ -0,0 +1,87 @@
+!> \file sfc_nst_post.f90
+!! This file contains code to be executed after the GFS NSST model.
+
+module sfc_nst_post
+
+ use machine , only : kind_phys, kp => kind_phys
+ use module_nst_water_prop , only : get_dtzm_2d
+
+ implicit none
+
+contains
+
+ ! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post
+
+ !> \section arg_table_sfc_nst_post_run Argument Table
+ !! \htmlinclude sfc_nst_post_run.html
+ !!
+ ! \section NSST_general_post_algorithm General Algorithm
+ !
+ ! \section NSST_detailed_post_algorithm Detailed Algorithm
+ ! @{
+ subroutine sfc_nst_post_run &
+ ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, &
+ oro_uf, nstf_name1, &
+ nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, &
+ tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg &
+ )
+ ! --- inputs:
+ integer, intent(in) :: im, kdt, nthreads
+ logical, dimension(:), intent(in) :: wet, icy
+ integer, dimension(:), intent(in) :: use_lake_model
+ real (kind=kind_phys), intent(in) :: rlapse, tgice
+ real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf
+ integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5
+ real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, dt_cool, z_c, tref, xlon
+
+ ! --- input/outputs:
+ real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, tsfc_wat
+
+ ! --- outputs:
+ real (kind=kind_phys), dimension(:), intent(out) :: dtzm
+
+ character(len=*), intent(out) :: errmsg
+ integer, intent(out) :: errflg
+
+ ! --- locals
+ integer :: i
+ real(kind=kind_phys) :: zsea1, zsea2
+
+ ! Initialize CCPP error handling variables
+ errmsg = ''
+ errflg = 0
+
+ ! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr),
+ ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr),
+ ! & ' kdt=',kdt
+
+ ! do i = 1, im
+ ! if (wet(i) .and. .not. icy(i)) then
+ ! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse
+ ! endif
+ ! enddo
+
+ ! --- ... run nsst model ... ---
+
+ if (nstf_name1 > 1) then
+ zsea1 = 0.001_kp*real(nstf_name4)
+ zsea2 = 0.001_kp*real(nstf_name5)
+ call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, im, 1, nthreads, dtzm)
+ do i = 1, im
+ ! if (wet(i) .and. .not.icy(i)) then
+ ! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then
+ if (wet(i) .and. use_lake_model(i) /=1) then
+ tsfc_wat(i) = max(tgice, tref(i) + dtzm(i))
+ ! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - &
+ ! (oro(i)-oro_uf(i))*rlapse
+ endif
+ enddo
+ endif
+
+ ! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), &
+ ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt
+
+ return
+ end subroutine sfc_nst_post_run
+
+end module sfc_nst_post
diff --git a/physics/sfc_nst_pre.f b/physics/sfc_nst_pre.f
deleted file mode 100644
index 77ff61f00..000000000
--- a/physics/sfc_nst_pre.f
+++ /dev/null
@@ -1,96 +0,0 @@
-!> \file sfc_nst_pre.f
-!! This file contains preparation for the GFS NSST model.
-
- module sfc_nst_pre
-
- contains
-
-!> \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre
-!!
-!! The NSST scheme is one of the three schemes used to represent the
-!! surface in the GFS physics suite. The other two are the Noah land
-!! surface model and the sice simplified ice model.
-!!
-!! \section arg_table_sfc_nst_pre_run Argument Table
-!! \htmlinclude sfc_nst_pre_run.html
-!!
-!> \section NSST_general_pre_algorithm General Algorithm
- subroutine sfc_nst_pre_run
- & (im, wet, tgice, tsfco, tsurf_wat,
- & tseal, xt, xz, dt_cool, z_c, tref, cplflx,
- & oceanfrac, nthreads, errmsg, errflg)
-
- use machine , only : kind_phys
- use module_nst_water_prop, only: get_dtzm_2d
-
- implicit none
-
- integer, parameter :: kp = kind_phys
-
-! --- inputs:
- integer, intent(in) :: im, nthreads
- logical, dimension(:), intent(in) :: wet
- real (kind=kind_phys), intent(in) :: tgice
- real (kind=kind_phys), dimension(:), intent(in) ::
- & tsfco, xt, xz, dt_cool, z_c, oceanfrac
- logical, intent(in) :: cplflx
-
-! --- input/outputs:
- real (kind=kind_phys), dimension(:), intent(inout) ::
- & tsurf_wat, tseal, tref
-
-! --- outputs:
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
-! --- locals
- integer :: i
- real(kind=kind_phys), parameter :: zero = 0.0_kp,
- & one = 1.0_kp,
- & half = 0.5_kp,
- & omz1 = 2.0_kp
- real(kind=kind_phys) :: tem1, tem2, dnsst
- real(kind=kind_phys), dimension(im) :: dtzm, z_c_0
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- do i=1,im
- if (wet(i) .and. oceanfrac(i) > 0.0) then
-! tem = (oro(i)-oro_uf(i)) * rlapse
- ! DH* 20190927 simplyfing this code because tem is zero
- !tem = zero
- !tseal(i) = tsfco(i) + tem
- tseal(i) = tsfco(i)
- !tsurf_wat(i) = tsurf_wat(i) + tem
- ! *DH
- endif
- enddo
-!
-! update tsfc & tref with T1 from OGCM & NSST Profile if coupled
-!
- if (cplflx) then
- z_c_0 = zero
- call get_dtzm_2d (xt, xz, dt_cool, &
- & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm)
- do i=1,im
- if (wet(i) .and. oceanfrac(i) > zero ) then
-! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf
- tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile
-! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update
-! tseal(i) = tsfc_wat(i)
- if (abs(xz(i)) > zero) then
- tem2 = one / xz(i)
- else
- tem2 = zero
- endif
- tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i)
- tsurf_wat(i) = tseal(i)
- endif
- enddo
- endif
-
- return
- end subroutine sfc_nst_pre_run
- end module sfc_nst_pre
diff --git a/physics/sfc_nst_pre.f90 b/physics/sfc_nst_pre.f90
new file mode 100644
index 000000000..3e77f2d6b
--- /dev/null
+++ b/physics/sfc_nst_pre.f90
@@ -0,0 +1,89 @@
+!> \file sfc_nst_pre.f90
+!! This file contains preparation for the GFS NSST model.
+
+module sfc_nst_pre
+
+ use machine , only : kind_phys
+ use module_nst_water_prop , only : get_dtzm_2d
+ use module_nst_parameters , only : zero, one
+
+ implicit none
+
+contains
+
+ !> \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre
+ !!
+ !! The NSST scheme is one of the three schemes used to represent the
+ !! surface in the GFS physics suite. The other two are the Noah land
+ !! surface model and the sice simplified ice model.
+ !!
+ !! \section arg_table_sfc_nst_pre_run Argument Table
+ !! \htmlinclude sfc_nst_pre_run.html
+ !!
+ !> \section NSST_general_pre_algorithm General Algorithm
+ subroutine sfc_nst_pre_run &
+ (im, wet, tgice, tsfco, tsurf_wat, &
+ tseal, xt, xz, dt_cool, z_c, tref, cplflx, &
+ oceanfrac, nthreads, errmsg, errflg)
+
+ ! --- inputs:
+ integer, intent(in) :: im, nthreads
+ logical, dimension(:), intent(in) :: wet
+ real (kind=kind_phys), intent(in) :: tgice
+ real (kind=kind_phys), dimension(:), intent(in) :: tsfco, xt, xz, dt_cool, z_c, oceanfrac
+ logical, intent(in) :: cplflx
+
+ ! --- input/outputs:
+ real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, tseal, tref
+
+ ! --- outputs:
+ character(len=*), intent(out) :: errmsg
+ integer, intent(out) :: errflg
+
+ ! --- locals
+ integer :: i
+ real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys
+ real(kind=kind_phys) :: tem2, dnsst
+ real(kind=kind_phys), dimension(im) :: dtzm, z_c_0
+
+ ! Initialize CCPP error handling variables
+ errmsg = ''
+ errflg = 0
+
+ do i=1,im
+ if (wet(i) .and. oceanfrac(i) > 0.0) then
+ ! tem = (oro(i)-oro_uf(i)) * rlapse
+ ! DH* 20190927 simplyfing this code because tem is zero
+ !tem = zero
+ !tseal(i) = tsfco(i) + tem
+ tseal(i) = tsfco(i)
+ !tsurf_wat(i) = tsurf_wat(i) + tem
+ ! *DH
+ endif
+ enddo
+ !
+ ! update tsfc & tref with T1 from OGCM & NSST Profile if coupled
+ !
+ if (cplflx) then
+ z_c_0 = zero
+ call get_dtzm_2d (xt, xz, dt_cool, z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm)
+ do i=1,im
+ if (wet(i) .and. oceanfrac(i) > zero ) then
+ ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf
+ tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile
+ ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update
+ ! tseal(i) = tsfc_wat(i)
+ if (abs(xz(i)) > zero) then
+ tem2 = one / xz(i)
+ else
+ tem2 = zero
+ endif
+ tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i)
+ tsurf_wat(i) = tseal(i)
+ endif
+ enddo
+ endif
+
+ return
+ end subroutine sfc_nst_pre_run
+end module sfc_nst_pre
diff --git a/physics/sfcsub.F b/physics/sfcsub.F
index 7be07b39c..494b8f7dc 100644
--- a/physics/sfcsub.F
+++ b/physics/sfcsub.F
@@ -7491,9 +7491,6 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, &
endif
call abort
endif
-!
-! soil type
- print *,'in FIXREAD fnsotc =',fnsotc
!
if(fnsotc(1:8).ne.' ') then
if ( index(fnsotc, "tileX.nc") == 0) then ! grib file
diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90
index 44ab87bcc..936393d5b 100644
--- a/physics/sgscloud_radpre.F90
+++ b/physics/sgscloud_radpre.F90
@@ -216,10 +216,10 @@ subroutine sgscloud_radpre_run( &
qi(i,k) = ice_frac*qi_bl(i,k)
!eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b)
- if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.)
+ clouds5(i,k)=max(173.45 + 2.14*Tc, 20.)
!eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 8b)
!iwc = qi(i,k)*1.0e6*rho(i,k)
- !IF(qi(i,k)>1.E-8)clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.)
+ !clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.)
!calculate the ice water path using additional BL clouds
clouds4(i,k) = max(0.0, qi(i,k) * gfac * delp(i,k))
@@ -229,7 +229,7 @@ subroutine sgscloud_radpre_run( &
qs(i,k) = snow_frac*qi_bl(i,k)
!eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b)
- if(qs(i,k)>1.E-8)clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.)
+ clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.)
!calculate the snow water path using additional BL clouds
clouds8(i,k) = max(0.0, qs(i,k) * gfac * delp(i,k))
diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90
index 7b69fc9e3..c9a6344b8 100755
--- a/physics/smoke_dust/rrfs_smoke_wrapper.F90
+++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90
@@ -54,7 +54,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
dust_alpha_in, dust_gamma_in, fire_in, &
seas_opt_in, dust_opt_in, drydep_opt_in, coarsepm_settling_in, &
do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, &
- wetdep_ls_opt_in,wetdep_ls_alpha_in, &
+ wetdep_ls_opt_in,wetdep_ls_alpha_in, fire_heat_flux_out, &
+ frac_grid_burned_out, &
smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg)
implicit none
@@ -88,6 +89,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist
real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke
real(kind_phys), dimension(:,:), intent(inout) :: fire_in
+ real(kind_phys), dimension(:), intent(out) :: fire_heat_flux_out
+ real(kind_phys), dimension(:), intent(out) :: frac_grid_burned_out
real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume
real(kind_phys), dimension(:), intent( out) :: hwp
real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext
@@ -339,7 +342,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
! the plumerise is controlled by the namelist option of plumerise_flag
if (call_fire) then
call ebu_driver ( &
- flam_frac,ebu_in,ebu, &
+ flam_frac,ebu_in,ebu, &
t_phy,moist(:,:,:,p_qv), &
rho_phy,vvel,u_phy,v_phy,p_phy, &
z_at_w,zmid,g,con_cp,con_rd, &
@@ -348,8 +351,16 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, errmsg, errflg )
if(errflg/=0) return
+ do i = its,ite
+ if ( plume_frp(i,1,p_frp_hr) .ge. 1.E7 ) then
+ fire_heat_flux_out(i) = min(max(0.,0.88*plume_frp(i,1,p_frp_hr)/0.55/dxy(i,1)) ,50000.) ! JLS - W m-2 [0 - 10,000]
+ frac_grid_burned_out(i) = min(max(0., 1.3*0.0006*plume_frp(i,1,p_frp_hr)/dxy(i,1) ),1.)
+ else
+ fire_heat_flux_out(i) = 0.0
+ frac_grid_burned_out(i) = 0.0
+ endif
+ enddo
end if
-
! -- add biomass burning emissions at every timestep
if (addsmoke_flag == 1) then
call add_emis_burn(dt,dz8w,rho_phy,rel_hum,chem, &
diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta
index cddc20fbc..7b22b9799 100755
--- a/physics/smoke_dust/rrfs_smoke_wrapper.meta
+++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta
@@ -740,6 +740,22 @@
dimensions = ()
type = logical
intent = in
+[fire_heat_flux_out]
+ standard_name = surface_fire_heat_flux
+ long_name = heat flux of fire at the surface
+ units = W m-2
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = out
+[frac_grid_burned_out]
+ standard_name = fraction_of_grid_cell_burning
+ long_name = ration of the burnt area to the grid cell area
+ units = frac
+ dimensions = (horizontal_loop_extent)
+ type = real
+ kind = kind_phys
+ intent = out
[dbg_opt_in]
standard_name = do_smoke_debug
long_name = flag for rrfs smoke plumerise debug