From a5ad17689446c6a92e571dc508ab732ac96e4498 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 5 May 2021 23:01:56 +0000 Subject: [PATCH 01/50] Merge radar_tten support --- physics/GFS_MP_generic.F90 | 74 ++++++++++++++++++++++++++++++------- physics/GFS_MP_generic.meta | 69 ++++++++++++++++++++++++++++++++++ physics/cu_gf_deep.F90 | 24 ++++++------ physics/cu_gf_driver.F90 | 31 +++++++++++++--- physics/cu_gf_driver.meta | 43 +++++++++++++++++++++ physics/phys_tend.F90 | 6 ++- physics/phys_tend.meta | 9 +++++ 7 files changed, 223 insertions(+), 33 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 435a80509b..856441d6cc 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -12,12 +12,12 @@ end subroutine GFS_MP_generic_pre_init !> \section arg_table_GFS_MP_generic_pre_run Argument Table !! \htmlinclude GFS_MP_generic_pre_run.html !! - subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, ntrac, gt0, gq0, save_t, save_qv, save_q, errmsg, errflg) + subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, ntrac, gt0, gq0, save_t, save_qv, save_q, num_dfi_radar, errmsg, errflg) ! use machine, only: kind_phys implicit none - integer, intent(in) :: im, levs, ntcw, nncl, ntrac + integer, intent(in) :: im, levs, ntcw, nncl, ntrac, num_dfi_radar logical, intent(in) :: ldiag3d, qdiag3d, do_aw real(kind=kind_phys), dimension(im, levs), intent(in) :: gt0 real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 @@ -34,12 +34,14 @@ subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, errmsg = '' errflg = 0 - if (ldiag3d .or. do_aw) then + if (ldiag3d .or. do_aw .or. num_dfi_radar>0) then do k=1,levs do i=1,im save_t(i,k) = gt0(i,k) enddo enddo + endif + if (ldiag3d .or. do_aw) then if(qdiag3d) then do k=1,levs do i=1,im @@ -90,32 +92,38 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, dt3dt, dq3dt, rain_cpl, rainc_cpl, snow_cpl, pwat, & do_sppt, ca_global, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & - graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, errmsg, errflg) + graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, num_dfi_radar, fh_dfi_radar, ix_dfi_radar,& + dfi_radar_tten, radar_tten_limits, dt3dt_dfi_radar, fhour, errmsg, errflg) ! use machine, only: kind_phys implicit none - integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac + integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, num_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm + integer, intent(in) :: ix_dfi_radar(4) real(kind=kind_phys), intent(in) :: dtf, frain, con_g + real(kind=kind_phys), intent(in) :: radar_tten_limits(2), fh_dfi_radar(5), fhour real(kind=kind_phys), dimension(im), intent(in) :: rain1, xlat, xlon, tsfc real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel, rainc real(kind=kind_phys), dimension(im), intent(in) :: rain0, ice0, snow0, graupel0 real(kind=kind_phys), dimension(im,nrcm), intent(in) :: rann - real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, prsl, save_t, save_qv, del + real(kind=kind_phys), dimension(im,levs), intent(inout) :: gt0 + real(kind=kind_phys), dimension(im,levs), intent(in) :: prsl, save_t, save_qv, del real(kind=kind_phys), dimension(im,levs+1), intent(in) :: prsi, phii real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: gq0 + real(kind=kind_phys), dimension(:,:,:), optional, intent(in) :: dfi_radar_tten + real(kind=kind_phys), dimension(im), intent(in ) :: sr real(kind=kind_phys), dimension(im), intent(inout) :: rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, & srflag, cnvprcp, totprcp, totice, totsnw, totgrp, cnvprcpb, & totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, & snow_cpl, pwat - real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt ! only if ldiag3d + real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, dt3dt_dfi_radar ! only if ldiag3d real(kind=kind_phys), dimension(:,:), intent(inout) :: dq3dt ! only if ldiag3d and qdiag3d ! Stochastic physics / surface perturbations @@ -151,10 +159,10 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys ! *DH - integer :: i, k, ic + integer :: i, k, ic, itime real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 + real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2, ttend real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 ! Initialize CCPP error handling variables @@ -245,6 +253,44 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, endif + do itime=1,num_dfi_radar + if(ix_dfi_radar(itime)<1) cycle + if(fhour=fh_dfi_radar(itime+1)) cycle + exit + enddo + if_radar: if(itime<=num_dfi_radar) then + radar_k: do k=3,levs-2 + radar_i: do i=1,im + ! if(dfi_radar_tten(i,k,itime)>-19) then + ! gt0(i,k) = save_t(i,k) + dfi_radar_tten(i,k,itime) + ! endif + ttend = dfi_radar_tten(i,k,itime) + if_active: if (ttend>-19) then + ttend = max(ttend,radar_tten_limits(1)) + ttend = min(ttend,radar_tten_limits(2)) + ! add radar temp tendency + ! there is radar coverage + gt0(i,k) = save_t(i,k) + ttend*dtp + endif if_active + enddo radar_i + enddo radar_k + if(ldiag3d) then + dt3dt(:,1:2) = dt3dt(:,1:2) + (gt0(:,1:2)-save_t(:,1:2))*frain + do k=3,levs-2 + do i=1,im + ttend = dfi_radar_tten(i,k,itime) + if(ttend>-19) then + dt3dt_dfi_radar(i,k) = dt3dt_dfi_radar(i,k) + (gt0(i,k)-save_t(i,k)) * frain + else + dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain + endif + enddo + enddo + dt3dt(:,levs-1:levs) = dt3dt(:,levs-1:levs) + (gt0(:,levs-1:levs)-save_t(:,levs-1:levs))*frain + endif + endif if_radar + t850(1:im) = gt0(1:im,1) do k = 1, levs-1 @@ -341,11 +387,13 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, enddo if (ldiag3d) then - do k=1,levs - do i=1,im - dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain + if(itime>num_dfi_radar) then + do k=1,levs + do i=1,im + dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain + enddo enddo - enddo + endif if (qdiag3d) then do k=1,levs do i=1,im diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 981f5478d2..fd10fc6c3f 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -116,6 +116,14 @@ kind = kind_phys intent = inout optional = F +[num_dfi_radar] + standard_name = num_dfi_radar + long_name = number of time ranges with dfi radar tendencies + units = count + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -903,6 +911,67 @@ kind = kind_phys intent = in optional = F +[num_dfi_radar] + standard_name = num_dfi_radar + long_name = number of time ranges with dfi radar tendencies + units = count + dimensions = () + type = integer + intent = in + optional = F +[fh_dfi_radar] + standard_name = times_at_which_dfi_radar_tten_is_available + long_name = times at which dfi_radar_tten is available + units = h + dimensions = (5) + type = real + kind = kind_phys + intent = in + optional = F +[ix_dfi_radar] + standard_name = time_indices_in_dfi_radar_tten + long_name = time indices in dfi radar tten + units = index + dimensions = (4) + type = integer + intent = in + optional = F +[dfi_radar_tten] + standard_name = dfi_radar_tten + long_name = prescribed microphysics temperature tendency from radar data + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension,num_dfi_radar) + type = real + kind = kind_phys + intent = in + optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[radar_tten_limits] + standard_name = allowed_bounds_of_radar_prescribed_tendencies + long_name = allowed bounds of prescribed microphysics temperature tendencies + units = K + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[dt3dt_dfi_radar] + standard_name = cumulative_change_in_temperature_due_to_dfi_radar + long_name = cumulative change in temperature due to dfi radar + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index a075233420..fde028dbaa 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -109,9 +109,7 @@ subroutine cu_gf_deep_run( & !! more is possible, talk to developer or !! implement yourself. pattern is expected to be !! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) ,do_capsuppress,cap_suppress_j & ! -#endif ,k22 & ! ,jmin,tropics) ! @@ -127,16 +125,8 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: rand_mom,rand_vmas -#if ( wrf_dfi_radar == 1 ) -! -! option of cap suppress: -! do_capsuppress = 1 do -! do_capsuppress = other don't -! -! - integer, intent(in ) ,optional :: do_capsuppress - real(kind=kind_phys), dimension( its:ite ) :: cap_suppress_j -#endif + integer, intent(in) :: do_capsuppress + real(kind=kind_phys), intent(in), optional, dimension(:) :: cap_suppress_j ! ! ! @@ -448,6 +438,16 @@ subroutine cu_gf_deep_run( & ztexec(:)=0 zqexec(:)=0 endif + if(do_capsuppress == 1) then + do i=its,itf + cap_max(i)=cap_maxs + if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then + cap_max(i)=cap_maxs+75. + elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then + cap_max(i)=10.0 + endif + enddo + endif ! !--- initial entrainment rate (these may be changed later on in the !--- program diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index dcf0d183b1..de9f6c5d9a 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -71,6 +71,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & du3dt_SCNV,dv3dt_SCNV,dt3dt_SCNV,dq3dt_SCNV, & du3dt_DCNV,dv3dt_DCNV,dt3dt_DCNV,dq3dt_DCNV, & + fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,dfi_radar_tten, & ldiag3d,qdiag3d,qci_conv,errmsg,errflg) !------------------------------------------------------------- implicit none @@ -109,6 +110,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & du3dt_SCNV,dv3dt_SCNV,dt3dt_SCNV,dq3dt_SCNV, & du3dt_DCNV,dv3dt_DCNV,dt3dt_DCNV,dq3dt_DCNV + real(kind=kind_phys), intent(in) :: fhour, fh_dfi_radar(5) + integer, intent(in) :: num_dfi_radar, ix_dfi_radar(4) + real(kind=kind_phys), intent(in), pointer :: dfi_radar_tten(:,:,:) + integer, dimension (im), intent(inout) :: hbot,htop,kcnv integer, dimension (im), intent(in) :: xland real(kind=kind_phys), dimension (im), intent(in) :: pbl @@ -185,6 +190,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & real(kind=kind_phys), dimension (im) :: hfx,qfx real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) :: cap_suppress_j(im) + integer :: itime, do_cap_suppress + !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) @@ -192,6 +200,21 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! initialize ccpp error handling variables errmsg = '' errflg = 0 + + do itime=1,num_dfi_radar + if(ix_dfi_radar(itime)<1) cycle + if(fhour=fh_dfi_radar(itime+1)) cycle + exit + enddo + if_radar: if(itime<=num_dfi_radar) then + do_cap_suppress = 1 + cap_suppress_j = dfi_radar_tten(:,1,itime) + else + do_cap_suppress = 0 + cap_suppress_j = 0 + endif if_radar + ! ! Scale specific humidity to dry mixing ratio ! @@ -571,9 +594,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! more is possible, talk to developer or ! implement yourself. pattern is expected to be ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif + ,do_cap_suppress,cap_suppress_j & ,k22m & ,jminm,tropics) @@ -652,9 +673,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! more is possible, talk to developer or ! implement yourself. pattern is expected to be ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif + ,do_cap_suppress,cap_suppress_j & ,k22 & ,jmin,tropics) jpr=0 diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index f27b2cc91a..dc957463d8 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -464,6 +464,49 @@ kind = kind_phys intent = inout optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fh_dfi_radar] + standard_name = times_at_which_dfi_radar_tten_is_available + long_name = times at which dfi_radar_tten is available + units = h + dimensions = (5) + type = real + kind = kind_phys + intent = in + optional = F +[ix_dfi_radar] + standard_name = time_indices_in_dfi_radar_tten + long_name = time indices in dfi radar tten + units = index + dimensions = (4) + type = integer + intent = in + optional = F +[num_dfi_radar] + standard_name = num_dfi_radar + long_name = number of time ranges with dfi radar tendencies + units = count + dimensions = () + type = integer + intent = in + optional = F +[dfi_radar_tten] + standard_name = dfi_radar_tten + long_name = prescribed microphysics temperature tendency from radar data + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension,num_dfi_radar) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/phys_tend.F90 b/physics/phys_tend.F90 index 333c22e2a4..ebd0bb25ec 100644 --- a/physics/phys_tend.F90 +++ b/physics/phys_tend.F90 @@ -26,7 +26,7 @@ subroutine phys_tend_run(ldiag3d, qdiag3d, & dv3dt_rdamp, dv3dt_shalcnv, dv3dt_phys, & dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_deepcnv, & dt3dt_shalcnv, dt3dt_mp, dt3dt_orogwd, dt3dt_rdamp, & - dt3dt_congwd, dt3dt_phys, & + dt3dt_congwd, dt3dt_radar_tten, dt3dt_phys, & dq3dt_pbl, dq3dt_deepcnv, dq3dt_shalcnv, dq3dt_mp, & dq3dt_o3pbl, dq3dt_o3prodloss, dq3dt_o3mix, & dq3dt_o3tmp, dq3dt_o3column, dq3dt_phys, dq3dt_o3phys, & @@ -38,6 +38,7 @@ subroutine phys_tend_run(ldiag3d, qdiag3d, & real(kind=kind_phys), intent(in ) :: du3dt_orogwd(:,:) real(kind=kind_phys), intent(in ) :: du3dt_deepcnv(:,:) real(kind=kind_phys), intent(in ) :: du3dt_congwd(:,:) + real(kind=kind_phys), intent(in ) :: dt3dt_radar_tten(:,:) real(kind=kind_phys), intent(in ) :: du3dt_rdamp(:,:) real(kind=kind_phys), intent(in ) :: du3dt_shalcnv(:,:) real(kind=kind_phys), intent( out) :: du3dt_phys(:,:) @@ -86,7 +87,8 @@ subroutine phys_tend_run(ldiag3d, qdiag3d, & dt3dt_phys = dt3dt_lw + dt3dt_sw + dt3dt_pbl + & dt3dt_deepcnv + dt3dt_shalcnv + dt3dt_mp + & - dt3dt_orogwd + dt3dt_rdamp + dt3dt_congwd + dt3dt_orogwd + dt3dt_rdamp + dt3dt_congwd+ & + dt3dt_radar_tten dq3dt_phys = dq3dt_pbl + dq3dt_deepcnv + & dq3dt_shalcnv + dq3dt_mp diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta index 3af255148f..1d49af4dc0 100644 --- a/physics/phys_tend.meta +++ b/physics/phys_tend.meta @@ -230,6 +230,15 @@ kind = kind_phys intent = in optional = F +[dt3dt_radar_tten] + standard_name = cumulative_change_in_temperature_due_to_dfi_radar + long_name = cumulative change in temperature due to dfi radar + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F [dt3dt_phys] standard_name = cumulative_change_in_temperature_due_to_physics long_name = cumulative change in temperature due to physics From 7135b5da106538c7514b028e633fe5b7b6cea93e Mon Sep 17 00:00:00 2001 From: "Ming.Hu" Date: Fri, 21 May 2021 17:31:32 +0000 Subject: [PATCH 02/50] 1) Roll back "y-intercept, slope values for graupel" to old version for Spring Experiment. 2) Set allow_wet_snow = .true. allow_wet_graupel = .false. melti=.true. for all steps. --- physics/module_mp_thompson.F90 | 85 +++++++++++++++++++++++++++++----- 1 file changed, 73 insertions(+), 12 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index dfe31f375e..3e10c3e962 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2048,11 +2048,27 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ +! Ming Hu: go back to old version for Spring experiment 2021 + N0_min = gonv_max + k_0 = kts + do k = kte, kts, -1 + if (temp(k).ge.270.65) k_0 = MAX(k_0, k) + enddo do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r(k)) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) + zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 + if (rand1 .ne. 0.0) then + zans1 = MAX(2., MIN(zans1, 7.)) + endif N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -3124,11 +3140,28 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ +! Ming Hu: go back to old version for Spring experiment 2021 + + N0_min = gonv_max + k_0 = kts do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + if (temp(k).ge.270.65) k_0 = MAX(k_0, k) + enddo + do k = kte, kts, -1 + if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r(k)) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) + zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 + if (rand1 .ne. 0.0) then + zans1 = MAX(2., MIN(zans1, 7.)) + endif N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -3483,10 +3516,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) if (temp(k).gt. (T_0+0.1)) then -! vtsk(k) = MAX(vts*vts_boost(k), & -! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) - SR = rs(k)/(rs(k)+rr(k)) - vtsk(k) = vts*SR + (1.-SR)*vtrk(k) +!Ming Hu: go back to old version for Spring experiment 2021 + vtsk(k) = MAX(vts*vts_boost(k), & + & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) ! +! DH* The version below is supposed to be a better formulation, +! but gave worse results in RAPv5/HRRRv4 than the line above. + ! this formulation for RAPv5/HRRRv4, reverted 20 Feb 2020 +! SR = rs(k)/(rs(k)+rr(k)) +! vtsk(k) = vts*SR + (1.-SR)*vtrk(k) else vtsk(k) = vts*vts_boost(k) endif @@ -5295,7 +5332,7 @@ end subroutine calc_effectRad !! of frozen species remaining from what initially existed at the !! melting level interface. subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, & + t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti_org, & vt_dBZ, first_time_step) IMPLICIT NONE @@ -5330,7 +5367,8 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & DOUBLE PRECISION:: fmelt_s, fmelt_g INTEGER:: i, k, k_0, kbot, n - LOGICAL, INTENT(IN):: melti + LOGICAL, INTENT(IN):: melti_org + LOGICAL :: melti LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg DOUBLE PRECISION:: cback, x, eta, f_d @@ -5352,6 +5390,11 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & allow_wet_graupel = .true. endif +!Ming Hu hardwired for Spring Experiment testing + allow_wet_snow = .true. + allow_wet_graupel = .false. + melti=.true. + do k = kts, kte dBZ(k) = -35.0 enddo @@ -5463,16 +5506,34 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then +! Ming Hu: go back to old version for Spring experiment 2021 + + N0_min = gonv_max + k_0 = kts do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + if (temp(k).ge.270.65) k_0 = MAX(k_0, k) + enddo + do k = kte, kts, -1 + if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r(k)) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) + zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 + if (rand1 .ne. 0.0) then + zans1 = MAX(2., MIN(zans1, 7.)) + endif N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min 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 + endif !+---+-----------------------------------------------------------------+ From 52df88831e32d8f996a906478d63f4f9735b9895 Mon Sep 17 00:00:00 2001 From: "Ming.Hu" Date: Fri, 18 Feb 2022 19:01:38 +0000 Subject: [PATCH 03/50] In thompson file: Roll back "y-intercept, slope values for graupel" to old version In ruclsm: a tuning In module_sf_mynn.F90: remove NSST. --- physics/module_mp_thompson.F90 | 88 ++++++++++++++++++++++++++++------ physics/module_sf_mynn.F90 | 2 +- physics/module_sf_ruclsm.F90 | 3 +- physics/sfc_drv_ruc.F90 | 4 +- 4 files changed, 79 insertions(+), 18 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 3183ca4bfd..67561521ae 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2400,11 +2400,27 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ +! Ming Hu: go back to old version for Spring experiment 2021 + N0_min = gonv_max + k_0 = kts + do k = kte, kts, -1 + if (temp(k).ge.270.65) k_0 = MAX(k_0, k) + enddo do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r(k)) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) + zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 + if (rand1 .ne. 0.0) then + zans1 = MAX(2., MIN(zans1, 7.)) + endif N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -3476,11 +3492,28 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ +! Ming Hu: go back to old version for Spring experiment 2021 + + N0_min = gonv_max + k_0 = kts + do k = kte, kts, -1 + if (temp(k).ge.270.65) k_0 = MAX(k_0, k) + enddo do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r(k)) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) + zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 + if (rand1 .ne. 0.0) then + zans1 = MAX(2., MIN(zans1, 7.)) + endif N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -3835,12 +3868,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t3_vts = Kap0*csg(1)*ils1**cse(1) t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (prr_sml(k) .gt. 0.0) then -! vtsk(k) = MAX(vts*vts_boost(k), & -! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) - SR = rs(k)/(rs(k)+rr(k)) - vtsk(k) = vts*SR + (1.-SR)*vtrk(k) - !vtsk1(k)=vtsk(k) + if (temp(k).gt. (T_0+0.1)) then +!Ming Hu: go back to old version for Spring experiment 2021 + vtsk(k) = MAX(vts*vts_boost(k), & + & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) ! +! DH* The version below is supposed to be a better formulation, +! but gave worse results in RAPv5/HRRRv4 than the line above. + ! this formulation for RAPv5/HRRRv4, reverted 20 Feb 2020 +! SR = rs(k)/(rs(k)+rr(k)) +! vtsk(k) = vts*SR + (1.-SR)*vtrk(k) else vtsk(k) = vts*vts_boost(k) !vtsk1(k)=vtsk(k) @@ -5811,7 +5847,7 @@ end subroutine calc_effectRad !! of frozen species remaining from what initially existed at the !! melting level interface. subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, & + t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti_org, & vt_dBZ, first_time_step) IMPLICIT NONE @@ -5846,7 +5882,8 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & DOUBLE PRECISION:: fmelt_s, fmelt_g INTEGER:: i, k, k_0, kbot, n - LOGICAL, INTENT(IN):: melti + LOGICAL, INTENT(IN):: melti_org + LOGICAL :: melti LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg DOUBLE PRECISION:: cback, x, eta, f_d @@ -5868,6 +5905,11 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & allow_wet_graupel = .true. endif +!Ming Hu hardwired for Spring Experiment testing + allow_wet_snow = .true. + allow_wet_graupel = .false. + melti=.true. + do k = kts, kte dBZ(k) = -35.0 enddo @@ -5979,16 +6021,34 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then +! Ming Hu: go back to old version for Spring experiment 2021 + + N0_min = gonv_max + k_0 = kts do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + if (temp(k).ge.270.65) k_0 = MAX(k_0, k) + enddo + do k = kte, kts, -1 + if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r(k)) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) + zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 + if (rand1 .ne. 0.0) then + zans1 = MAX(2., MIN(zans1, 7.)) + endif N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min 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 + endif !+---+-----------------------------------------------------------------+ diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index c98dc21693..d6b72ec98c 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -112,7 +112,7 @@ MODULE module_sf_mynn !1: check input !2: everything - heavy I/O LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .false. !shouldn't need compute + LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute ! these in FV3. They will be written over anyway. ! Computing the fluxes here is leftover from the WRF world. diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index a2b0f398ab..85fb889bef 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2595,7 +2595,8 @@ SUBROUTINE SOIL (debug_print, & ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. !fc=max(qmin,ref*0.5) - fc=max(qmin,ref*0.7) + !fc=max(qmin,ref*0.7) + fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then soilres = 1. diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index ecea7a6701..b698950c86 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -1018,8 +1018,8 @@ subroutine lsm_ruc_run & ! inputs cmm_lnd(i) = cm_lnd(i) * wind(i) chh_lnd(i) = chs_lnd(i,j) * rho(i) ! - snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - sneqv_lnd(i,j) = weasd_lnd(i) ! [mm] + snowh_lnd(i,j) = max(1.e-7,snwdph_lnd(i) * 0.001) ! convert from mm to m + sneqv_lnd(i,j) = max(1.e-4,weasd_lnd(i)) ! [mm] snfallac_lnd(i,j) = snowfallac_lnd(i) !> -- sanity checks on sneqv and snowh if (sneqv_lnd(i,j) /= 0.0 .and. snowh_lnd(i,j) == 0.0) then From 18c65ff7fbe7c7c2d9f5b28889e579d0cd508330 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 8 Mar 2022 19:20:38 +0000 Subject: [PATCH 04/50] Modified physics/drag_suite.F90 to remove topographic limitations on small-scale GWD and TOFD --- physics/drag_suite.F90 | 61 +++++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 24 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index d2d435e4cb..8b03faf95b 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -583,17 +583,20 @@ subroutine drag_suite_run( & endif enddo -do i=1,im - if ( dx(i) .ge. dxmax_ss ) then - ss_taper(i) = 1. - else - if ( dx(i) .le. dxmin_ss) then - ss_taper(i) = 0. - else - ss_taper(i) = dxmax_ss * (1. - dxmin_ss/dx(i))/(dxmax_ss-dxmin_ss) - endif - endif -enddo +! Temporary changes +! do i=1,im +! if ( dx(i) .ge. dxmax_ss ) then +! ss_taper(i) = 1. +! else +! if ( dx(i) .le. dxmin_ss) then +! ss_taper(i) = 0. +! else +! ss_taper(i) = dxmax_ss * (1. - dxmin_ss/dx(i))/(dxmax_ss-dxmin_ss) +! endif +! endif +! enddo +! Temporary line +ss_taper(:) = 1. !--- calculate length of grid for flow-blocking drag ! @@ -963,13 +966,15 @@ subroutine drag_suite_run( & enddo if((xland(i)-1.5).le.0. .and. 2.*varss(i).le.hpbl(i))then if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then - cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) ! WRF + ! Temporary changes denoted by "!!" + !! cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) ! WRF ! cleff_ss = 3. * max(dx(i),cleff_ss) ! cleff_ss = 10. * max(dxmax_ss,cleff_ss) - cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) ! WRF + !! cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) ! WRF ! cleff_ss = 0.1 * 12000. - coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) - xlinv(i) = coefm_ss(i) / cleff_ss + !! coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) + !!xlinv(i) = coefm_ss(i) / cleff_ss + xlinv(i) = 0.001*pi ! 2km horizontal wavelength !govrth(i)=g/(0.5*(thvx(i,kpbl(i))+thvx(i,kts))) govrth(i)=g/(0.5*(thvx(i,kpbl2)+thvx(i,kts))) !XNBV=sqrt(govrth(i)*(thvx(i,kpbl(i))-thvx(i,kts))/hpbl(i)) @@ -980,8 +985,10 @@ subroutine drag_suite_run( & !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) - var_temp = MIN(varss(i),varmax_ss) + & - MAX(0.,beta_ss*(varss(i)-varmax_ss)) + ! Temporary change + var_temp = varss(i) + !var_temp = MIN(varss(i),varmax_ss) + & + ! MAX(0.,beta_ss*(varss(i)-varmax_ss)) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavex0=var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) @@ -995,8 +1002,10 @@ subroutine drag_suite_run( & !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) - var_temp = MIN(varss(i),varmax_ss) + & - MAX(0.,beta_ss*(varss(i)-varmax_ss)) + ! Temporary change + var_temp = varss(i) + ! var_temp = MIN(varss(i),varmax_ss) + & + ! MAX(0.,beta_ss*(varss(i)-varmax_ss)) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavey0=var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) @@ -1060,17 +1069,21 @@ subroutine drag_suite_run( & IF ((xland(i)-1.5) .le. 0.) then !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 - var_temp = MIN(varss(i),varmax_fd) + & - MAX(0.,beta_fd*(varss(i)-varmax_fd)) - var_temp = MIN(var_temp, 250.) + ! Temporary changes + var_temp = varss(i) + ! var_temp = MIN(varss(i),varmax_fd) + & + ! MAX(0.,beta_fd*(varss(i)-varmax_fd)) + ! var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 ! a1=0.00026615161*(0.5*varss(i))**2 ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 a2=a1*0.005363 ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 - H_efold = max(2*varss(i),hpbl(i)) - H_efold = min(H_efold,1500.) + ! Temporary changes + ! H_efold = max(2*varss(i),hpbl(i)) + ! H_efold = min(H_efold,1500.) + H_efold = 1500. DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 From d8db18ba90b807f729d0b03ff9d49bc6b7fc437d Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Tue, 15 Mar 2022 15:21:28 +0000 Subject: [PATCH 05/50] Put a comment back in. --- physics/cu_gf_driver.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index a9cecb5ce3..79bede1a32 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -331,6 +331,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! these should be coming in from outside ! ! cactiv(:) = 0 +! cactiv_m(:) = 0 rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. From 9624299c76d4711623100b9e812338b6f5257c55 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Wed, 16 Mar 2022 22:35:01 +0000 Subject: [PATCH 06/50] There are a few changed in GFS_surface_composites.F90 1. Added lat/lon to the parameter list for debugging purposes. 2. Flag_restart is replaced with lsm_cold_start. 3. Removed snow initialization with the use of RUC LSM. In case of cold start snow on land andice is initialized in io/FV3GFS_io.F90. In case of warm start, these variables are carried along. 3. Corresponding changes in GFS_surface_composites.meta. --- physics/GFS_surface_composites.F90 | 29 +++++++++++++++++------ physics/GFS_surface_composites.meta | 36 ++++++++++++++++++++++++++--- 2 files changed, 55 insertions(+), 10 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 510b3f4273..260eda9610 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -27,8 +27,9 @@ end subroutine GFS_surface_composites_pre_finalize !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, frac_grid, & - flag_cice, cplflx, cplice, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & + subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_cold_start, lkm, frac_grid, & + flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & @@ -40,10 +41,11 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra implicit none ! Interface variables - integer, intent(in ) :: im, lkm, kdt - logical, intent(in ) :: flag_init, flag_restart, frac_grid, cplflx, cplice, cplwav2atm + integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc + logical, intent(in ) :: flag_init, lsm_cold_start, frac_grid, cplflx, cplice, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet + real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -201,12 +203,13 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif endif enddo - endif + endif ! frac_grid do i=1,im tprcp_wat(i) = tprcp(i) tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) + if (wet(i)) then ! Water uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) @@ -219,7 +222,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) - weasd_lnd(i) = weasd(i) tsurf_lnd(i) = tsfcl(i) ! DH* else @@ -230,7 +232,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) - weasd_ice(i) = weasd(i) tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero @@ -258,6 +259,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif enddo ! + if(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm if (frac_grid) then do i=1,im if (dry(i)) then @@ -280,6 +282,15 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra enddo else do i=1,im + !-- print ice point + !if ( (xlon_d(i) > 298.6) .and. (xlon_d(i) < 298.7) .and. & + ! (xlat_d(i) > 68.6 ) .and. (xlat_d(i) < 68.7 )) then + ! print *,'Composit weasd_ice(i),snowd_ice',kdt,i,xlat_d(i),xlon_d(i),weasd_ice(i),snowd_ice(i) + !endif + !if ( (xlon_d(i) > 284.35) .and. (xlon_d(i) < 284.6) .and. & + ! (xlat_d(i) > 41.0 ) .and. (xlat_d(i) < 41.2 )) then + ! print *,'Composit2 weasd_lnd(i),snowd_lnd',kdt,i,xlat_d(i),xlon_d(i),weasd_lnd(i),snowd_lnd(i) + !endif if (icy(i)) then if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then snowd_lnd(i) = zero @@ -291,6 +302,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif enddo endif + endif ! lsm/=lsm_ruc ! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) @@ -644,6 +656,7 @@ subroutine GFS_surface_composites_post_run ( do i=1,im if (islmsk(i) == 1) then + !-- land zorl(i) = zorll(i) cd(i) = cd_lnd(i) cdq(i) = cdq_lnd(i) @@ -669,6 +682,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero elseif (islmsk(i) == 0) then + !-- water zorl(i) = zorlo(i) cd(i) = cd_wat(i) cdq(i) = cdq_wat(i) @@ -695,6 +709,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero else ! islmsk(i) == 2 + !-- ice zorl(i) = zorli(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 89048e4879..40f0c940c5 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -14,6 +14,22 @@ dimensions = () type = integer intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [flag_init] standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop @@ -21,9 +37,9 @@ dimensions = () type = logical intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -70,6 +86,20 @@ dimensions = () type = logical intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [landfrac] standard_name = land_area_fraction long_name = fraction of horizontal grid area occupied by land From 3e06ba4842ac5d3e62eb31c7ec0d8b185d05286b Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Fri, 18 Mar 2022 23:50:44 +0000 Subject: [PATCH 07/50] Bug fixes to drag_suite.F90 and GFS_surface_composites.F90 --- physics/GFS_surface_composites.F90 | 6 +++-- physics/drag_suite.F90 | 43 +++++++----------------------- 2 files changed, 13 insertions(+), 36 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 260eda9610..f44df58900 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -222,6 +222,7 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) + if(lsm /= lsm_ruc) weasd_lnd(i) = weasd(i) tsurf_lnd(i) = tsfcl(i) ! DH* else @@ -232,6 +233,7 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) + if(lsm /= lsm_ruc) weasd_ice(i) = weasd(i) tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero @@ -259,7 +261,6 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co endif enddo ! - if(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm if (frac_grid) then do i=1,im if (dry(i)) then @@ -281,6 +282,7 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co endif enddo else + if(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm do i=1,im !-- print ice point !if ( (xlon_d(i) > 298.6) .and. (xlon_d(i) < 298.7) .and. & @@ -301,8 +303,8 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co endif endif enddo + endif ! lsm/=lsm_ruc endif - endif ! lsm/=lsm_ruc ! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 2f465489ae..fe90952107 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -589,19 +589,7 @@ subroutine drag_suite_run( & endif enddo -! Temporary changes -! do i=1,im -! if ( dx(i) .ge. dxmax_ss ) then -! ss_taper(i) = 1. -! else -! if ( dx(i) .le. dxmin_ss) then -! ss_taper(i) = 0. -! else -! ss_taper(i) = dxmax_ss * (1. - dxmin_ss/dx(i))/(dxmax_ss-dxmin_ss) -! endif -! endif -! enddo -! Temporary line +! Remove ss_tapering ss_taper(:) = 1. ! SPP, if spp_gwd is 0, no perturbations are applied. @@ -989,14 +977,10 @@ subroutine drag_suite_run( & enddo if((xland(i)-1.5).le.0. .and. 2.*varss_stoch(i).le.hpbl(i))then if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then - ! Temporary changes denoted by "!!" - !! cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) ! WRF + ! Modify xlinv to represent wave number of "typical" small-scale topography ! cleff_ss = 3. * max(dx(i),cleff_ss) ! cleff_ss = 10. * max(dxmax_ss,cleff_ss) - !! cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) ! WRF ! cleff_ss = 0.1 * 12000. - !! coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) - !!xlinv(i) = coefm_ss(i) / cleff_ss xlinv(i) = 0.001*pi ! 2km horizontal wavelength !govrth(i)=g/(0.5*(thvx(i,kpbl(i))+thvx(i,kts))) govrth(i)=g/(0.5*(thvx(i,kpbl2)+thvx(i,kts))) @@ -1008,10 +992,8 @@ subroutine drag_suite_run( & !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) - ! Temporary change - var_temp = varss(i) - !var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & - ! MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavex0=var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) @@ -1025,10 +1007,8 @@ subroutine drag_suite_run( & !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) - ! Temporary change - var_temp = varss(i) - !var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & - ! MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavey0=var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) @@ -1092,20 +1072,15 @@ subroutine drag_suite_run( & IF ((xland(i)-1.5) .le. 0.) then !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 - ! Temporary changes - var_temp = varss(i) - !var_temp = MIN(varss_stoch(i),varmax_fd_stoch(i)) + & - ! MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) !var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 ! a1=0.00026615161*(0.5*varss(i))**2 ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 a2=a1*0.005363 - ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 - ! Temporary changes - !H_efold = max(2*varss_stoch(i),hpbl(i)) - !H_efold = min(H_efold,1500.) + ! Beljaars H_efold H_efold = 1500. DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) From 99bd5b57c026738973ee36f40f630125872efc2b Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 29 Mar 2022 02:56:29 +0000 Subject: [PATCH 08/50] Updating MYNN and SGS clouds from gsl/develop --- physics/GFS_rrtmg_pre.F90 | 17 +- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 11 +- physics/module_MYNNPBL_wrapper.F90 | 74 ++-- physics/module_MYNNPBL_wrapper.meta | 8 + physics/module_bl_mynn.F90 | 501 +++++++++++----------------- 5 files changed, 247 insertions(+), 364 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 15845d4b33..db818c3b8d 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -744,21 +744,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then - if (do_mynnedmf) then - do k=1,lm - k1 = k + kd - do i=1,im - if (tracer1(i,k1,ntrw)>1.0e-7 .OR. tracer1(i,k1,ntsw)>1.0e-7) then - ! GFDL cloud fraction - cldcov(i,k1) = tracer1(i,k1,ntclamt) - else - ! MYNN sub-grid cloud fraction - cldcov(i,k1) = clouds1(i,k1) - endif - enddo - enddo - else ! imfdeepcnv==imfdeepcnv_gf + if ((imfdeepcnv==imfdeepcnv_gf) .and. kdt>1) then do k=1,lm k1 = k + kd do i=1,im @@ -770,7 +756,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif enddo enddo - endif else ! GFDL cloud fraction cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,ntclamt) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index c6afd6ac0b..d9d7c37f64 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -165,16 +165,9 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld where(cld_reice .gt. radice_upr) cld_reice = radice_upr endif - ! Cloud-fraction. For mynnedmf, cld_frac is adjusted for precipitation here, otherwise - ! it passes through this interface. It is adjusted prior in sgscloudradpre. + ! Cloud-fraction. For mynnedmf, cld_frac is already defined in sgscloudradpre. if (do_mynnedmf .and. kdt .gt. 1) then - do iLay = 1, nLev - do iCol = 1, nCol - if (tracer(iCol,iLay,i_cldrain) > 1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - enddo - enddo + !already set in sgscloudradpre else cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) endif diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 9d720b9f8d..d9e53f9d37 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -132,7 +132,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dtsfc_cpl,dqsfc_cpl, & & recmol, & & qke,qke_adv,Tsq,Qsq,Cov, & - & el_pbl,sh3d,exch_h,exch_m, & + & el_pbl,sh3d,sm3d,exch_h,exch_m, & & dqke,qwt,qshear,qbuoy,qdiss, & & Pblh,kpbl, & & qc_bl,qi_bl,cldfra_bl, & @@ -179,10 +179,10 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: rrfs_smoke, rrfs_smoke, fire_turb + !logical, intent(in) :: mix_chem, fire_turb !integer, intent(in) :: nchem, ndvel, kdvel !for testing only: - logical, parameter :: rrfs_smoke=.false., mix_chem=.false., fire_turb=.false. + logical, parameter :: mix_chem=.false., fire_turb=.false. integer, parameter :: nchem=2, ndvel=2, kdvel=1 ! NAMELIST OPTIONS (INPUT): @@ -248,7 +248,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc real(kind=kind_phys), dimension(:,:), intent(inout) :: & - & qke, qke_adv, EL_PBL, Sh3D, & + & qke, qke_adv, EL_PBL, Sh3D, Sm3D, & & qc_bl, qi_bl, cldfra_bl !These 10 arrays are only allocated when bl_mynn_output > 0 real(kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -366,7 +366,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FRP = 0. EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (rrfs_smoke) then + if (mix_chem) then allocate ( chem3d(im,levs,nchem) ) do k=1,levs do i=1,im @@ -697,11 +697,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol, & & wspd=wspd,uoce=uoce,voce=voce,vdfg=vdfg, & !input & qke=QKE,qke_adv=qke_adv, & !output - & bl_mynn_tkeadvect=bl_mynn_tkeadvect,sh3d=Sh3d, & + & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & & Chem3d=chem3d,Vdep=vdep, & - & rrfs_smoke=rrfs_smoke, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & & mix_chem=mix_chem,fire_turb=fire_turb, & !----- @@ -712,36 +711,37 @@ SUBROUTINE mynnedmf_wrapper_run( & & RQNIBLTEN=rqniblten,RQNWFABLTEN=RQNWFABLTEN, & !output & RQNIFABLTEN=RQNIFABLTEN,dozone=dqdt_ozone, & !output & EXCH_H=exch_h,EXCH_M=exch_m, & !output - & pblh=pblh,KPBL=KPBL & !output - & ,el_pbl=el_pbl & !output - & ,dqke=dqke & !output - & ,qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS & !output - & ,bl_mynn_tkebudget=bl_mynn_tkebudget & !input parameter - & ,bl_mynn_cloudpdf=bl_mynn_cloudpdf & !input parameter - & ,bl_mynn_mixlength=bl_mynn_mixlength & !input parameter - & ,icloud_bl=icloud_bl & !input parameter - & ,qc_bl=qc_bl,qi_bl=qi_bl,cldfra_bl=cldfra_bl & !output - & ,closure=bl_mynn_closure,bl_mynn_edmf=bl_mynn_edmf & !input parameter - & ,bl_mynn_edmf_mom=bl_mynn_edmf_mom & !input parameter - & ,bl_mynn_edmf_tke=bl_mynn_edmf_tke & !input parameter - & ,bl_mynn_mixscalars=bl_mynn_mixscalars & !input parameter - & ,bl_mynn_output=bl_mynn_output & !input parameter - & ,bl_mynn_cloudmix=bl_mynn_cloudmix & !input parameter - & ,bl_mynn_mixqt=bl_mynn_mixqt & !input parameter - & ,edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt & !output - & ,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 - & ,ktop_plume=ktop_plume & !output - & ,spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl & !input - & ,RTHRATEN=htrlw & !input - & ,FLAG_QI=flag_qi,FLAG_QNI=flag_qni & !input - & ,FLAG_QC=flag_qc,FLAG_QNC=flag_qnc & !input - & ,FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA & !input - & ,IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs & !input - & ,IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs & !input - & ,ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input + & pblh=pblh,KPBL=KPBL, & !output + & el_pbl=el_pbl, & !output + & dqke=dqke, & !output + & qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS, & !output + & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & + & bl_mynn_tkebudget=bl_mynn_tkebudget, & !input parameter + & bl_mynn_cloudpdf=bl_mynn_cloudpdf, & !input parameter + & bl_mynn_mixlength=bl_mynn_mixlength, & !input parameter + & icloud_bl=icloud_bl, & !input parameter + & qc_bl=qc_bl,qi_bl=qi_bl,cldfra_bl=cldfra_bl, & !output + & closure=bl_mynn_closure,bl_mynn_edmf=bl_mynn_edmf, & !input parameter + & bl_mynn_edmf_mom=bl_mynn_edmf_mom, & !input parameter + & bl_mynn_edmf_tke=bl_mynn_edmf_tke, & !input parameter + & bl_mynn_mixscalars=bl_mynn_mixscalars, & !input parameter + & bl_mynn_output=bl_mynn_output, & !input parameter + & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter + & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter + & edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt, & !output + & 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 + & ktop_plume=ktop_plume, & !output + & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input + & RTHRATEN=htrlw, & !input + & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input + & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input + & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input + & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input + & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input + & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input ! POST MYNN (INTERSTITIAL) WORK: diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 60668ba887..658c801002 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -764,6 +764,14 @@ type = real kind = kind_phys intent = inout +[Sm3D] + standard_name = stability_function_for_momentum + long_name = stability function for momentum + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [exch_h] standard_name = atmosphere_heat_diffusivity_for_mynnpbl long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 36ff3ebf7a..292d5aa18f 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -216,7 +216,7 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.3.2 / CCPP +! v4.4 / CCPP ! This version includes many modifications that proved valuable in the global ! framework and removes some key lingering bugs in the mixing of chemical species. ! TKE Budget output fixed (Puhales, 2020-12) @@ -228,9 +228,8 @@ ! Important bug fixes for mixing of chemical species. ! Addition of pressure-gradient effects on updraft momentum transport. ! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0 -! Addition of sig_order to regulate the use of higher-order moments -! for sigma when using bl_mynn_cloudpdf = 2 (Chab-Becht). This -! new option is set in the subroutine mym_condensation. +! Addition of higher-order moments for sigma when using +! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. ! @@ -322,7 +321,7 @@ MODULE module_bl_mynn IMPLICIT NONE - +!get rid INTEGER , PARAMETER :: param_first_scalar = 1, & & p_qc = 2, & & p_qr = 0, & @@ -332,23 +331,8 @@ MODULE module_bl_mynn & p_qnc= 0, & & p_qni= 0 -!END FV3 CONSTANTS -!==================================================================== -!WRF CONSTANTS -! USE module_model_constants, only: & -! &karman, grav, p1000mb, & -! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, p608, ep_2, rvovrd, & -! &cpv, cliq, cice -! -! USE module_state_description, only: param_first_scalar, & -! &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni -! -! IMPLICIT NONE -! -!END WRF CONSTANTS !=================================================================== -! From here on, these are used for any model +! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & cphh_st=5.0, cphh_unst=16.0 @@ -476,11 +460,10 @@ SUBROUTINE mynn_bl_driver( & &uoce,voce, & !ocean current &vdfg, & !Katata-added for fog dep &Qke,qke_adv, & - &bl_mynn_tkeadvect,sh3d, & + &sh3d,sm3d, & &nchem,kdvel,ndvel, & !Smoke/Chem variables &chem3d, vdep, & - &rrfs_smoke, & ! flag for Smoke &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs &mix_chem,fire_turb, & ! end smoke/chem variables @@ -488,15 +471,18 @@ SUBROUTINE mynn_bl_driver( & &RUBLTEN,RVBLTEN,RTHBLTEN, & &RQVBLTEN,RQCBLTEN,RQIBLTEN, & &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN,DOZONE, & + &RQNWFABLTEN,RQNIFABLTEN, & + &DOZONE, & &exch_h,exch_m, & &Pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & !TKE BUDGET + &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &qc_bl,qi_bl,cldfra_bl, & + &bl_mynn_tkeadvect, & &bl_mynn_tkebudget, & &bl_mynn_cloudpdf, & &bl_mynn_mixlength, & - &icloud_bl,qc_bl,qi_bl,cldfra_bl,& + &icloud_bl, & &closure, & &bl_mynn_edmf, & &bl_mynn_edmf_mom, & @@ -541,7 +527,7 @@ SUBROUTINE mynn_bl_driver( & LOGICAL, INTENT(IN) :: mix_chem,fire_turb - INTEGER,INTENT(in) :: & + INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE @@ -558,37 +544,32 @@ SUBROUTINE mynn_bl_driver( & ! = 3; Level 3 REAL, INTENT(in) :: delt -!WRF -! REAL, INTENT(in) :: dx -!END WRF -!FV3 REAL, DIMENSION(IMS:IME), INTENT(in) :: dx -!END FV3 - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz,& + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in)::& + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust,& + REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, & &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &Qke,Tsq,Qsq,Cov,qke_adv !ACF for QKE advection + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &Qke,Tsq,Qsq,Cov,qke_adv - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & + &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & &RQNWFABLTEN,RQNIFABLTEN REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & &exch_h,exch_m !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), OPTIONAL, INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, 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) :: & @@ -607,13 +588,13 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat + REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D + REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl @@ -622,40 +603,42 @@ SUBROUTINE mynn_bl_driver( & ! smoke/chemical arrays INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel - LOGICAL, OPTIONAL, INTENT(IN ) :: rrfs_smoke ! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION( :,:,: ), INTENT(INOUT), optional :: chem3d - REAL, DIMENSION( :,: ), INTENT(IN), optional :: vdep - REAL, DIMENSION( : ), INTENT(IN), optional :: frp,EMIS_ANT_NO - - REAL, DIMENSION(KTS:KTE ,nchem) :: chem1 - REAL, DIMENSION(KTS:KTE+1,nchem) :: s_awchem1 - REAL, DIMENSION(its:ite) :: vd1 + REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d + REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep + REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + !local + REAL, DIMENSION(kts:kte ,nchem) :: chem1 + REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 + REAL, DIMENSION(ndvel) :: vd1 INTEGER :: ic !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD INTEGER :: i,j,k REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & &Vt, Vq, sgm, thlsg, sqwsg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& - &qke1,tsq1,qsq1,cov1,sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1,dozone1 + REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & + &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & + &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & + &dqnwfa1,dqnifa1,dozone1 !mass-flux variables REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& - edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,& - edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & + &edmf_thl1,edmf_ent1,edmf_qc1 + REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & + &edmf_qt_dd1,edmf_thl_dd1, & + &edmf_ent_dd1,edmf_qc_dd1 + REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,& det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& + REAL,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 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1,& + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw @@ -670,10 +653,9 @@ SUBROUTINE mynn_bl_driver( & LOGICAL :: INITIALIZE_QKE ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - !GJF: this array must be assumed-shape since it's conditionally-allocated - REAL, DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) ::rstoch_col ! Substepping TKE INTEGER :: nsub @@ -702,11 +684,6 @@ SUBROUTINE mynn_bl_driver( & JMD=(JMS+JME)/2 !*** End debugging -!WRF -! JTF=MIN0(JTE,JDE-1) -! ITF=MIN0(ITE,IDE-1) -! KTF=MIN0(KTE,KDE-1) -!FV3 JTF=JTE ITF=ITE KTF=KTE @@ -758,6 +735,7 @@ SUBROUTINE mynn_bl_driver( & if (.not.restart .or. .not.cycling) THEN Sh3D(its:ite,kts:kte)=0. + Sm3D(its:ite,kts:kte)=0. el_pbl(its:ite,kts:kte)=0. tsq(its:ite,kts:kte)=0. qsq(its:ite,kts:kte)=0. @@ -882,6 +860,7 @@ SUBROUTINE mynn_bl_driver( & ENDIF el(k)=el_pbl(i,k) sh(k)=Sh3D(i,k) + sm(k)=Sm3D(i,k) tsq1(k)=tsq(i,k) qsq1(k)=qsq(i,k) cov1(k)=cov(i,k) @@ -933,6 +912,7 @@ SUBROUTINE mynn_bl_driver( & DO k=KTS,KTE !KTF el_pbl(i,k)=el(k) sh3d(i,k)=sh(k) + sm3d(i,k)=sm(k) qke(i,k)=qke1(k) tsq(i,k)=tsq1(k) qsq(i,k)=qsq1(k) @@ -1078,7 +1058,8 @@ SUBROUTINE mynn_bl_driver( & ENDIF el(k) = el_pbl(i,k) qke1(k)=qke(i,k) - sh(k) = sh3d(i,k) + sh(k) =sh3d(i,k) + sm(k) =sm3d(i,k) tsq1(k)=tsq(i,k) qsq1(k)=qsq(i,k) cov1(k)=cov(i,k) @@ -1134,7 +1115,6 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF (rrfs_smoke .or. mix_chem) then IF (mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) !is this correct???? @@ -1160,7 +1140,6 @@ SUBROUTINE mynn_bl_driver( & enddo enddo ENDIF - ENDIF zw(kte+1)=zw(kte)+dz(i,kte) !EDMF @@ -1383,8 +1362,9 @@ SUBROUTINE mynn_bl_driver( & if (dheat_opt > 0) then DO k=kts,kte-1 ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(0.75*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + ! Limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) ENDDO diss_heat(kte) = 0. else @@ -1517,7 +1497,7 @@ SUBROUTINE mynn_bl_driver( & qsq(i,k)=qsq1(k) cov(i,k)=cov1(k) sh3d(i,k)=sh(k) - + sm3d(i,k)=sm(k) ENDDO !end-k IF ( bl_mynn_tkebudget ) THEN @@ -2108,11 +2088,11 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.23 + alp1 = 0.21 alp2 = 1.0 alp3 = 5.0 alp4 = 100. - alp5 = 0.2 + alp5 = 0.3 ! Impose limits on the height integration for elt and the transition layer depth zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. @@ -2194,7 +2174,7 @@ SUBROUTINE mym_length ( & alp2 = 0.3 alp3 = 1.5 alp4 = 5.0 - alp5 = 0.2 + alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth @@ -2246,6 +2226,7 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN + alp2 = 0.3 + 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) bv = SQRT( gtr*dtv(k) ) !elb = alp2*qkw(k) / bv & ! formulation, ! & *( 1.0 + alp3/alp2*& ! except keep @@ -2876,7 +2857,7 @@ SUBROUTINE mym_turbulence ( & REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& - sm_pbl,sh_pbl,zi2,wt + sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv @@ -2885,7 +2866,7 @@ SUBROUTINE mym_turbulence ( & ! Stochastic INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum + REAL :: Prnum, Prlim REAL, PARAMETER :: Prlimit = 5.0 @@ -2972,11 +2953,10 @@ SUBROUTINE mym_turbulence ( & ! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** -!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! new stability criteria in level 2.5 (as well as level 3) - little/no impact ! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -!JOE-end + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) IF ( q3sq .LT. q2sq ) THEN !Apply Helfand & Labraga mod @@ -3084,6 +3064,9 @@ SUBROUTINE mym_turbulence ( & !IF ( sm(k) > sm25max ) sm(k) = sm25max !IF ( sm(k) < sm25min ) sm(k) = sm25min !sm(k) = Prnum*sh(k) + slht = zi*0.1 + wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer + Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit sm(k) = MIN(sm(k), Prlimit*Sh(k)) ! ** Level 3 : start ** @@ -3236,10 +3219,9 @@ SUBROUTINE mym_turbulence ( & END IF ! ! Add min background stability function (diffusivity) within model levels -! with active plumes and low cloud fractions. +! with active plumes and clouds. cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & @@ -3249,8 +3231,8 @@ SUBROUTINE mym_turbulence ( & sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) ! for clouds - sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) ) ENDIF ! elq = el(k)*qkw(k) @@ -3625,7 +3607,7 @@ SUBROUTINE mym_predict (kts,kte, & DO k=kts,kte !qsq(k)=d(k-kts+1) - qsq(k)=MAX(x(k),1e-12) + qsq(k)=MAX(x(k),1e-17) ENDDO ELSE !level 2.5 - use level 2 diagnostic @@ -3781,8 +3763,8 @@ END SUBROUTINE mym_predict ! Output variables: see subroutine mym_initialize ! cld(nx,nz,ny) : Cloud fraction ! -! Work arrays: -! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation +! Work arrays/variables: +! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation ! specific humidity at T=Tl ! alp(nx,nz,ny) : Functions in the condensation process ! bet(nx,nz,ny) : ditto @@ -3830,15 +3812,15 @@ SUBROUTINE mym_condensation (kts,kte, & REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,RH + REAL, DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq - REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,qlk,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,& - &ls_min,ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &low_weight + REAL :: 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 INTEGER :: i,j,k REAL :: erf @@ -3850,7 +3832,6 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 REAL :: lfac - INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3917,11 +3898,11 @@ SUBROUTINE mym_condensation (kts,kte, & c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl + qmq = qw(k) -qsl !ORIGINAL STANDARD DEVIATION sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq(k) / sgm(k) + q1(k) = qmq / sgm(k) !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) @@ -3979,8 +3960,8 @@ SUBROUTINE mym_condensation (kts,kte, & sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & b2 * MAX(Sh(k),0.03))/4. * & (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq(k) = qw(k) -qsl - q1(k) = qmq(k) / sgm(k) + qmq = qw(k) -qsl + q1(k) = qmq / sgm(k) cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) !now compute estimated lwc for PBL scheme's use @@ -4016,144 +3997,54 @@ SUBROUTINE mym_condensation (kts,kte, & CASE (2, -2) - if (sig_order == 1) then - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !using the first-order version of sigma (their eq. 5). - !JAYMES- this added 27 Apr 2015 - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*xlv/( r_d*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 - qmq(k) = a(k) * (qw_pert - qsat_tl) - b(k) = a(k)*rsl ! CB02 variable "b" + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !but with use of higher-order moments to estimate sigma + PBLH2=MAX(10.,PBLH1) + zagl = 0. + DO k = kts,kte-1 + zagl = zagl + dz(k) + 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(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001) + + !dqw/dT: Clausius-Clapeyron + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) - dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & - & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + 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" - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - cdhdz = dtl/dzk + (grav/cpm)*(1.+qw(k)) ! expression below Eq. 9 - ! in CB02 - zagl = zagl + dz(k) - !Use analog to surface layer length scale to make the cloud mixing length scale - !become less than z in stable conditions. - els = zagl !save for more testing: /(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) - - !ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = 300. + MIN(2.*MAX(HFX1,0.),150.) - ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: - if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) - ! 25 m < ls_min(=zagl) < 300 m - lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: - ! lfac(750 m) = 4.4 - ! lfac(3 km) = 5.0 - ! lfac(13 km) = 6.0 - ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m - ! Note: CB02 use 900 m as a constant free-atmosphere length scale. - - ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the - ! MYNN master length scale (el) must exceed 60 m before ls - ! becomes responsive to el, otherwise ls = ls_min = 300 m. - - sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: - & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, - & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, - & +b(k)**2 * cdhdz**2))) ! < 3rd term - ! CB02 use a multiplier of 0.2, but 0.225 is chosen - ! based on tests - - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - END DO + !This form of qmq (the numerator of Q1) no longer uses the a(k) factor + qmq = qw_pert - qsat_tk ! saturation deficit/excess; - else + !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) + !except neglect all but the first term for sig_r + 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 + sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) + sgm(k) = MAX( sgm(k), qsat_tk*0.040 ) !Note: 0.02 results in SWDOWN similar + !to the first-order version of sigma + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + !This form only allows cloud fractions out to q1 = -1.8 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) + !This form only allows cloud fractions out to q1 = -1 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !but with use of higher-order moments to estimate sigma - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*xlv/( r_d*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! 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" - - !SPP - 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(k) = qw_pert - qsat_tl ! saturation deficit/excess; - - !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) - !except neglect all but the first term for sig_r - 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 - sgm(k) = MIN( sgm(k), qsat_tl*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tl*0.050 ) !Note: 0.02 results in SWDOWN similar - !to the first-order version of sigma - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - !This form only allows cloud fractions out to q1 = -1.8 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) - !This form only allows cloud fractions out to q1 = -1 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - - END DO - - endif !end sig_order option + END DO ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 @@ -4172,10 +4063,6 @@ SUBROUTINE mym_condensation (kts,kte, & IF (q1k < 0.) THEN !unsaturated ql_water = sgm(k)*EXP(1.2*q1k-1) ql_ice = sgm(k)*EXP(1.2*q1k-1.) - !Reduce ice mixing ratios in the upper troposphere -! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 -! ql_ice = low_weight * sgm(k)*EXP(1.1*q1k-1.6) & !low-lev -! + (1.-low_weight) * sgm(k)*EXP(1.1*q1k-2.8)!upper-lev ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k ql_ice = sgm(k)*q1k @@ -4276,11 +4163,14 @@ SUBROUTINE mym_condensation (kts,kte, & ! dampen the amplification factor (cld_factor) with height in order ! to limit excessively large cloud fractions aloft - fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & + !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) + fac_damp = min(zagl * 0.01, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 - cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 - cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.21 )**2 + !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 + !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.22 )**2 + cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 + !cld_factor = 1.0 cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) ENDDO @@ -5300,25 +5190,27 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! sqv, sqc, sqi, thl, & ! dqv, dqc, dqi, dth ) - problem = .false. - do k=kts,kte - wsp = sqrt(u(k)**2 + v(k)**2) - wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - if (wsp2 > 200.) then - problem = .true. - print*,"Problem: i=",i," k=",k," wsp=",wsp2 - print*," du=",du(k)*delt," dv=",dv(k)*delt - print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) - print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc - print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(k) - kproblem = k + if (debug_code) then + problem = .false. + do k=kts,kte + wsp = sqrt(u(k)**2 + v(k)**2) + wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) + if (wsp2 > 200.) then + problem = .true. + print*,"Huge wind speed: i=",i," k=",k," wsp=",wsp2 + print*," du=",du(k)*delt," dv=",dv(k)*delt + print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) + print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) + kproblem = k + endif + enddo + if (problem) then + print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) endif - enddo - if (problem) then - print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) endif #ifdef HARDCODE_VERTICAL @@ -6025,7 +5917,7 @@ SUBROUTINE DMP_mf( & REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters REAL,PARAMETER :: & @@ -6066,7 +5958,7 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf @@ -6250,13 +6142,14 @@ SUBROUTINE DMP_mf( & !Criteria (2) maxwidth = 1.1*PBLH ! Criteria (3) - maxwidth = MIN(maxwidth,0.333*cloud_base) + maxwidth = MIN(maxwidth,0.5*cloud_base) ! Criteria (4) wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) !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.050)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) else !water width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) endif @@ -6264,7 +6157,7 @@ SUBROUTINE DMP_mf( & ! Convert maxwidth to number of plumes NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - !Initialize values: + !Initialize values for 2d output fields: ktop = 0 ztop = 0.0 maxmf= 0.0 @@ -6286,7 +6179,8 @@ SUBROUTINE DMP_mf( & ! 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.09) + .5 + acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 else !water acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 endif @@ -6404,16 +6298,17 @@ SUBROUTINE DMP_mf( & 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 - !ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) + wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh + ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) !Entrainment from Negggers (2015, JAMES) !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+" !Minimum background entrainment 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 + !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. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN @@ -6425,18 +6320,19 @@ SUBROUTINE DMP_mf( & ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - ! Define environment U & V at the model interface levels - Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + ! Define environment U & V at the model interface levels + Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) ! Linear entrainment: EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + EntExm= EntExp*0.3333 !reduce entrainment for momentum QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + dxsa*pgfac*(Uk - Ukm1) - Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + dxsa*pgfac*(Vk - Vkm1) + Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1) + Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1) QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp @@ -6876,11 +6772,10 @@ SUBROUTINE DMP_mf( & ENDIF !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(tk(k)) ! obtain blended heat capacity - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + xl = xl_blend(tk(k)) ! obtain blended heat capacity + qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio + ! at t and p + rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp) ! CB02, Eqn. 4 cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" @@ -6896,8 +6791,7 @@ SUBROUTINE DMP_mf( & ! conversion is neglected here. qww = 1.+0.61*qt(k) alpha = 0.61*pt - t = TH(k)*exner(k) - beta = pt*xl/(t*cp) - 1.61*pt + beta = pt*xl/(tk(k)*cp) - 1.61*pt !Buoyancy flux terms have been moved to the end of this section... !Now calculate convective component of the cloud fraction: @@ -6907,20 +6801,24 @@ SUBROUTINE DMP_mf( & f = 1.0 endif - sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - sigq = MAX(sigq, 1.0E-6) + !CB form: + !sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + ! & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + !Per S.DeRoode 2009? + sigq = 10. * edmf_a(k) * (edmf_qt(k)-qt(k)) + + sigq = MAX(sigq, 1.0E-6) - qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; + qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; ! the numerator of Q1 mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" - ! print*," CB: env qt=",qt(k)," qsat=",qsat_tl - ! print*," k=",k," satdef=",QTp - qsat_tl," sgm=",sgm(k) - ! print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk + ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk + ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k) + ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k) ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) !ENDIF @@ -6941,7 +6839,7 @@ SUBROUTINE DMP_mf( & !The mixing ratios from the stratus component are not well !estimated in shallow-cumulus regimes. Ensure stratus clouds !have mixing ratio similar to cumulus - QCs = MIN(MAX(qc_bl1d(k), 0.5*qc_mf), 5E-4) + QCs = MAX(qc_bl1d(k), 0.5*qc_mf) qc_bl1d(k) = (qc_mf*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ELSE !cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) @@ -6951,7 +6849,7 @@ SUBROUTINE DMP_mf( & cldfra_bl1d(k)=Ac_mf + Ac_strat qc_mf = QCp !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MIN(MAX(qc_bl1d(k), 0.5*qc_mf), 5E-4) + QCs = MAX(qc_bl1d(k), 0.5*qc_mf) qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ENDIF ELSE @@ -7197,7 +7095,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& + REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters @@ -7669,7 +7567,6 @@ FUNCTION xl_blend(t) IF (t .GE. t0c) THEN xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation -! ELSE IF (t .LE. 253.) THEN ELSE IF (t .LE. tice) THEN xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition ELSE From c5d747141f85c24a783056e2d16d918afe36ff58 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Thu, 31 Mar 2022 20:42:42 +0000 Subject: [PATCH 09/50] 1. Added 2-m diagnostics to sfc_diag.f that is used in the HRRR. It is a flux-based diagnostics. This diagnostics will be enabled when MYNN surface layer scheme and RUC LSM are used in the physics suite, for example FV3_HRRR suite. 2. In sfc_drv_ruc.F90 several variables are added to the output. They include such variables as variable-density snow accumulation, accumulated snow melt, latent heat flux due to snow phase changes, sublimation, direct evaporation, canopy evaporation and transpiration fluxes. Fixed units of runoff variables. 3. Cleaned-up print statements. Introduced a test point with lat/lon for debugging in sfc_diag.f, sfc_drv_ruc.F90 and module_sf_ruclsm.F90. 4. Several modifications to the snow model in module_sf_ruclsm.F90. Introduced two options to compute snow fraction and thermal conductivity in snow. The new options are disabled until their impact is evaluated in the retrospective experiments. --- physics/module_sf_ruclsm.F90 | 733 ++++++++++++++++++++++------------- physics/sfc_diag.f | 174 +++++++-- physics/sfc_diag.meta | 113 +++++- physics/sfc_drv_ruc.F90 | 453 ++++++++++++---------- 4 files changed, 972 insertions(+), 501 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 01e9c1100d..2a55561232 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -59,11 +59,11 @@ MODULE module_sf_ruclsm !! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 !>\section gen_lsmruc GSD RUC LSM General Algorithm !! @{ - SUBROUTINE LSMRUC( & + SUBROUTINE LSMRUC(xlat,xlon, & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - rhosnf,precipfr, & + rhosnf,precipfr, hgt,stdev, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & @@ -75,7 +75,8 @@ SUBROUTINE LSMRUC( & ISWATER,ISICE,XICE,XICE_THRESHOLD, & CP,RV,RD,G0,PI,LV,STBOLT, & SOILMOIS,SH2O,SMAVAIL,SMMAX, & - TSO,SOILT,HFX,QFX,LH,INFILTR, & + TSO,SOILT,EDIR,EC,ETT,SUBLIM,SNOH, & + HFX,QFX,LH,INFILTR, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & @@ -133,7 +134,7 @@ SUBROUTINE LSMRUC( & !-- XLAND land mask (1 for land, 2 for water) !-- CP heat capacity at constant pressure for dry air (J/kg/K) !-- G0 acceleration due to gravity (m/s^2) -!-- LV latent heat of melting (J/kg) +!-- LV latent heat of evaporation (J/kg) !-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) ! SOILMOIS - soil moisture content (volumetric fraction) ! TSO - soil temp (K) @@ -144,7 +145,7 @@ SUBROUTINE LSMRUC( & ! SFCRUNOFF - ground surface runoff [mm] ! UDRUNOFF - underground runoff [mm] ! ACRUNOFF - run-total surface runoff [mm] -! SFCEVP - total evaporation in [kg/m^2] +! SFCEVP - total time-step evaporation in [kg/m^2] ! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) ! SNOWFALLAC - run-total snowfall accumulation [m] ! ACSNOW - run-toral SWE of snowfall [mm] @@ -165,6 +166,7 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) + REAL, INTENT(IN ) :: xlat,xlon REAL, INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil @@ -207,6 +209,8 @@ SUBROUTINE LSMRUC( & REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -248,6 +252,11 @@ SUBROUTINE LSMRUC( & HFX, & QFX, & LH, & + EDIR, & + EC, & + ETT, & + SUBLIM, & + SNOH, & SFCEVP, & RUNOFF1, & RUNOFF2, & @@ -276,12 +285,7 @@ SUBROUTINE LSMRUC( & ZNTL, & LMAVAIL, & SMELT, & - SNOH, & SNFLX, & - EDIR, & - EC, & - ETT, & - SUBLIM, & sflx, & smf, & EVAPL, & @@ -391,6 +395,9 @@ SUBROUTINE LSMRUC( & INTEGER :: k1,k2 logical :: debug_print + !-- diagnostic point + real (kind=kind_phys) :: testptlat, testptlon + !----------------------------------------------------------------- ! debug_print = .false. @@ -400,6 +407,12 @@ SUBROUTINE LSMRUC( & NZS=NSL NDDZS=2*(nzs-2) + !-- + testptlat = 41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 284.50 !286.75 !280.6 !164.0 !283.0 + !-- + + !> - Table TBQ is for resolution of balance equation in vilka() CQ=173.15-.05 R273=1./273.15 @@ -423,44 +436,50 @@ SUBROUTINE LSMRUC( & !> - Initialize soil/vegetation parameters !--- This is temporary until SI is added to mass coordinate ---!!!!! - if(init .and. (lsm_cold_start) .and. iter == 1) then - DO J=jts,jte + if(init .and. iter == 1) then + + if( lsm_cold_start ) then + !-- beginning of cold-start + DO J=jts,jte DO i=its,ite -! do k=1,nsl -! keepfr3dflag(i,k,j)=0. -! enddo -!> - Initializing snow fraction, thereshold = 32 mm of snow water -!! or ~100 mm of snow height ! -! snowc(i,j) = min(1.,snow(i,j)/32.) -! soilt1(i,j)=soilt(i,j) -! if(snow(i,j).le.32.) soilt1(i,j)=tso(i,1,j) -!> - Initializing inside snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snow(i,j).gt.32.) THEN - soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j)) - IF (debug_print ) THEN - print *, & - 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j - ENDIF - ELSE - soilt1(i,j) = tso(i,1,j) - ENDIF - ENDIF - tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15 - qcg (i,j) =0. +!> - Initializing inside-snow temp if it is not defined + IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN + IF(snowc(i,j).gt.0.) THEN + soilt1(i,j)=min(273.15,0.5*(soilt(i,j)+tso(i,1,j)) ) + IF (debug_print ) THEN + print *, & + 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon + ENDIF + ELSE + soilt1(i,j) = tso(i,1,j) + ENDIF + ENDIF + tsnav(i,j) =min(0.,0.5*(soilt(i,j)+tso(i,1,j))-273.15) + !- 10feb22 - limit snow albedo at high elevations + !- based on Roesch et al., Climate Dynamics (2001),17:933-946 + if(hgt(i,j) > 2500.) then + snoalb(i,j) = min(0.65,snoalb(i,j)) + endif + patmb=P8w(i,kms,j)*1.e-2 QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - IF((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) THEN - !17sept19 - bad approximation with very low mavail. - !qvg(i,j) = QSG(i,j)*mavail(i,j) - qvg (i,j) = qv3d(i,1,j) - IF (debug_print ) THEN - print *, & - 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,j - ENDIF - ENDIF -! qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + + if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + qcg (i,j) = qc3d(i,1,j) + if (debug_print ) then + print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon + endif + endif + + if((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) then + qvg (i,j) = qv3d(i,1,j) + if (debug_print ) then + print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon + endif + endif + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + SMELT(i,j) = 0. SNOM (i,j) = 0. ACSNOW(i,j) = 0. @@ -483,8 +502,6 @@ SUBROUTINE LSMRUC( & acwaterbudget(i,j) = 0. smtotold(i,j)=0. canwatold(i,j)=0. -! Temporarily!!! -! canwat(i,j)=0. !> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and @@ -501,20 +518,61 @@ SUBROUTINE LSMRUC( & evapl (i,j) = 0. prcpl (i,j) = 0. ENDDO - ENDDO + ENDDO - infiltrp = 0. - do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. - enddo - else ! .not. init==true. + infiltrp = 0. + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo + + else + !-- restart DO J=jts,jte DO i=its,ite + SMELT(i,j) = 0. + SNOM (i,j) = 0. + ACSNOW(i,j) = 0. + SNOWFALLAC(i,j) = 0. + PRECIPFR(i,j) = 0. + RHOSNF(i,j) = -1.e3 ! non-zero flag + SNFLX(i,j) = 0. + DEW (i,j) = 0. + PC (i,j) = 0. + zntl (i,j) = 0. + RUNOFF1(i,j) = 0. + RUNOFF2(i,j) = 0. SFCRUNOFF(i,j) = 0. UDRUNOFF(i,j) = 0. + ACRUNOFF(i,j) = 0. + emissl (i,j) = 0. + budget(i,j) = 0. + acbudget(i,j) = 0. + waterbudget(i,j) = 0. + acwaterbudget(i,j) = 0. + smtotold(i,j)=0. + canwatold(i,j)=0. + chklowq(i,j) = 1. + infiltr(i,j) = 0. + snoh (i,j) = 0. + edir (i,j) = 0. + ec (i,j) = 0. + ett (i,j) = 0. + sublim(i,j) = 0. + sflx (i,j) = 0. + smf (i,j) = 0. + evapl (i,j) = 0. + prcpl (i,j) = 0. ENDDO ENDDO + + infiltrp = 0. + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo + + endif ! cold start endif ! init==.true. !----------------------------------------------------------------- @@ -531,22 +589,16 @@ SUBROUTINE LSMRUC( & DO i=its,ite IF (debug_print ) THEN -! if(j==10) then - print *,' IN LSMRUC ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & - ims,ime,jms,jme,its,ite,jts,jte,nzs - print *,' IVGTYP, ISLTYP ', ivgtyp(i,j),isltyp(i,j) - print *,' MAVAIL ', mavail(i,j) - print *,' SOILT,QVG,P8w',soilt(i,j),qvg(i,j),p8w(i,1,j) - print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & - qfx(i,j),hfx(i,j) - print *, ' GSW, GLW =',gsw(i,j),glw(i,j) - print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) - print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) - print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) - print *, ' I,J=, after SFCLAY CHS,FLHC ',i,j,chs(i,j),flhc(i,j) - print *, 'LSMRUC, IVGTYP,ISLTYP,ALB = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j - print *, 'LSMRUC I,J,DT,RAINBL =',I,J,dt,RAINBL(i,j) - print *, 'XLAND ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC start) i=',i,' lat,lon=',xlat,xlon, & + 'mavail ', mavail(i,j),' soilt',soilt(i,j),'qvg ',qvg(i,j),& + 'p8w',p8w(i,1,j),'sflay qfx',qfx(i,j),'sflay hfx',hfx(i,j),& + 'gsw ',gsw(i,j),'glw ',glw(i,j),'soilt ',soilt(i,j), & + 'chs ',chs(i,j),'flqc ',flhc(i,j),'alb ',alb(i,j), & + 'rainbl ',rainbl(i,j),'dt ',dt + print *,'nzs',nzs, 'ivgtyp ',ivgtyp(i,j),'isltyp ',isltyp(i,j) + endif ENDIF @@ -655,7 +707,10 @@ SUBROUTINE LSMRUC( & NZS1=NZS-1 !----- IF (debug_print ) THEN - print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + endif ENDIF DO K=2,NZS1 @@ -694,7 +749,7 @@ SUBROUTINE LSMRUC( & ! ! rooting depth RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then + if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.02) then RHOSN = SNOW(i,j)/SNOWH(i,j) else RHOSN = 300. @@ -702,8 +757,11 @@ SUBROUTINE LSMRUC( & IF (debug_print ) THEN if(init) then - print *,'before SOILVEGIN - z0,znt(195,254)',z0(i,j),znt(i,j) - print *,'ILAND, ISOIL =',i,j,iland,isoil + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j) + print *,'ILAND, ISOIL =',i,iland,isoil + endif endif ENDIF @@ -719,21 +777,21 @@ SUBROUTINE LSMRUC( & EMISBCK(I,J) = EMISSL(I,J) IF (debug_print ) THEN - if(init) & - print *,'after SOILVEGIN - z0,znt(1,26),lai(1,26)',z0(i,j),znt(i,j),lai(i,j) - if(init)then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j) print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j print *,'NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j + endif endif ENDIF CN=CFACTR_DATA ! exponent ! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated SAT = 5.e-4 ! units [m] -! if(i==666.and.j==282) print *,'second 666,282 - sat',sat !-- definition of number of soil levels in the rooting zone ! IF(iforest(ivgtyp(i,j)).ne.1) THEN @@ -820,7 +878,6 @@ SUBROUTINE LSMRUC( & ! LAND POINT OR SEA ICE if(xice(i,j).ge.xice_threshold) then -! if(IVGTYP(i,j).eq.isice) then SEAICE(i,j)=1. else SEAICE(i,j)=0. @@ -882,24 +939,34 @@ SUBROUTINE LSMRUC( & LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & - i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO - print *,'CONFLX =',CONFLX - print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & + i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO + print *,'CONFLX =',CONFLX + print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + endif ENDIF smtotold(i,j)=0. - do k=1,nzs-1 + + !do k=1,nzs-1 + do k=1,nroot smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) enddo - smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) + !smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print .and. abs(xlat-testptlat).lt.0.2 & + .and. abs(xlon-testptlon).lt.0.2) then + print *,'Old soilm1d ',i,soilm1d + endif canwatold(i,j) = canwatr !----------------------------------------------------------------- CALL SFCTMP (debug_print, dt,ktau,conflx,i,j, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & @@ -911,7 +978,8 @@ SUBROUTINE LSMRUC( & EMISSL(I,J),EMISBCK(I,J), & QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & canwatr,vegfra(I,J),alb(I,J),znt(I,J), & - snoalb(i,j),albbck(i,j),lai(i,j), & !new + snoalb(i,j),albbck(i,j),lai(i,j), & + hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & !--- soil fixed fields QWRTZ, & @@ -987,25 +1055,37 @@ SUBROUTINE LSMRUC( & smavail(i,j) = 0. smmax (i,j) = 0. - do k=1,nzs-1 + !do k=1,nzs-1 + !-- root-zone soil moisture + do k=1,nroot smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) smmax (i,j) =smmax (i,j)+(qmin+dqm)* & (zshalf(k+1)-zshalf(k)) enddo - smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) - smmax (i,j) =smmax (i,j)+(qmin+dqm)* & - (zsmain(nzs)-zshalf(nzs)) + !smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + !smmax (i,j) =smmax (i,j)+(qmin+dqm)* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, & + 'RUNOFF1', RUNOFF1(I,J), 'RUNOFF2 ',RUNOFF2(I,J), & + 'edir ',edir(I,J),'ec ',ec(I,J),'ett ',ett(I,J) + endif + endif !--- Convert the water unit into mm - SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - ACRUNOFF(I,J) = ACRUNOFF(I,J)+(RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. + !-- three lines below are commented because accumulation + ! happens in sfc_drv_ruc + !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 + !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. + smtotold (I,J) = smtotold(I,J) * 1000. ! mm do k=1,nzs @@ -1025,7 +1105,7 @@ SUBROUTINE LSMRUC( & !tgs add together dew and cloud at the ground surface !30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - Z0 (I,J) = ZNT (I,J) + !Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS patmb=P8w(i,1,j)*1.e-2 Q2SAT=QSN(TABS,TBQ)/PATMB @@ -1042,13 +1122,6 @@ SUBROUTINE LSMRUC( & ! CHKLOWQ(I,J)=1. ! endif - IF (debug_print ) THEN - if(CHKLOWQ(I,J).eq.0.) then - print *,'i,j,CHKLOWQ', & - i,j,CHKLOWQ(I,J) - endif - ENDIF - if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m @@ -1056,14 +1129,18 @@ SUBROUTINE LSMRUC( & SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. -if (debug_print) then - print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) -endif + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) + endif + endif INFILTR(I,J) = INFILTRP MAVAIL (i,j) = LMAVAIL(I,J) IF (debug_print ) THEN - print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !!! QFX (I,J) = LH(I,J)/LV SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT @@ -1077,9 +1154,9 @@ SUBROUTINE LSMRUC( & ! endif !--- SNOWC snow cover flag - if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - SNOWFRAC = SNOWFRAC*XICE(I,J) - endif + !if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then + ! SNOWFRAC = SNOWFRAC*XICE(I,J) + !endif SNOWC(I,J)=SNOWFRAC @@ -1101,20 +1178,34 @@ SUBROUTINE LSMRUC( & ! endif ! budget(i,j)=budget(i,j)-smf(i,j) + if (debug_print ) then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + !-- compute budget for a test point ac=0. as=0. + wb=0. - ac=max(0.,canwat(i,j)-canwatold(i,j)*1.e3) - as=max(0.,snwe-snowold(i,j)) - wb =rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source - -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) - + ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change + as=snwe-snowold(i,j) ! SWE change + wb = smavail(i,j)-smtotold(i,j) waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source -qfx(i,j)*dt & -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) + -ac-as ! - (smavail(i,j)-smtotold(i,j)) + + print *,'soilm1d ',i,soilm1d + print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, & + 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), & + 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), & + 'smelt ',smelt(i,j)*dt*1.e3,'smc change ',wb, & + 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & + 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) + !-- + ! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & @@ -1124,27 +1215,29 @@ SUBROUTINE LSMRUC( & !!!!TEST use LH to check water budget ! GRDFLX (I,J) = waterbudget(i,j) - IF (debug_print ) THEN - print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb - print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & - i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & - smelt(i,j)*dt*1.e3, & - (smavail(i,j)-smtotold(i,j)) - - print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) - print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) - print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) - ENDIF +! print *,'Smf=',smf(i,j),i,j +! print *,'Budget',budget(i,j),i,j +! print *,'RUNOFF2= ', i,j,runoff2(i,j) +! print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb +! print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & +! i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & +! smelt(i,j)*dt*1.e3, & +! (smavail(i,j)-smtotold(i,j)) +! +! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) +! print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) +! print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) +! print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) +! ENDIF IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !--- end of a land or sea ice point @@ -1169,6 +1262,7 @@ END SUBROUTINE LSMRUC !! the snow "mosaic" approach is turned on. !! - Updates emissivity and albedo for patch snow. SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input variables + xlat,xlon,testptlat,testptlon, & nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & @@ -1177,7 +1271,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia PATM,TABS,QVATM,QCATM,rho, & GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & MAVAIL,CST,VEGFRA,ALB,ZNT, & - ALB_SNOW,ALB_SNOW_FREE,lai, & + ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1199,7 +1293,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor + REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + REAL, INTENT(IN ) :: testptlat,testptlon REAL, INTENT(IN ) :: C1SN,C2SN LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables @@ -1216,6 +1311,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia VEGFRA, & ALB_SNOW_FREE, & lai, & + hgt,stdev, & SEAICE, & RHO, & QKMS, & @@ -1367,6 +1463,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER :: K,ILNB + integer :: isncovr_opt + REAL :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET @@ -1388,11 +1486,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SNWE,RHOSN,SNOM,SMELT,TS1D ENDIF + !-- Snow fraction options + !-- option 1: original formulation using critical snow depth to compute + !-- snow fraction + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. + isncovr_opt = 1 + !-- + !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 + snhei_crit=0.01601*1.e3/rhosn + snhei_crit_newsn=0.0005*1.e3/rhosn + !-- + zntsn = z0tbl(isice) snow_mosaic=0. snfr = 1. NEWSN=0. newsnowratio = 0. snowfracnewsn=0. + rhonewsn = 100. if(snhei == 0.) snowfrac=0. smelt = 0. RAINF = 0. @@ -1464,17 +1574,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(bsn*snwe*100..lt.1.e-4) goto 777 XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(62.5,XSN),890.) -! rhosn=MIN(MAX(100.,XSN),400.) -! rhosn=MIN(MAX(50.,XSN),400.) 777 continue - -! else -! rhosn =200. -! rhonewsn =200. endif + !-- snow_mosaic from the previous time step + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. + newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] acsnow=acsnow+newsn*1.e3 @@ -1488,18 +1594,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia newsnowratio = min(1.,newsn/(snwe+newsn)) -!*** Calculate fresh snow density (t > -15C, else MIN value) -!*** Eq. 10 from Koren et al. (1999) -!--- old formulation from Koren (1999) -! if(tabs.lt.258.15) then -! rhonewsn=50. -! rhonewsn=100. -! rhonewsn=62.5 - -! else -! rhonewsn=MIN(rhonewsn,400.) -! endif -!--- end of old formulation + if(isncovr_opt == 2) then + !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012) + ! time-step snowfall [mm H2O], 0.1 - accumulation constant (unitless) + snowfrac = snowfrac + tanh(0.1*newsn*1.e3)*(1.-snowfrac) ! eq. 8.1 from CLM5 + if(debug_print) print *,'2 - snowfrac newsn', i,j,ktau,snowfrac + endif !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) @@ -1524,15 +1624,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(100.,XSN),500.) -! rhosn=MIN(MAX(50.,XSN),400.) - -!Update snow on the ground -! snwe=snwe+newsn -! newsnowratio = min(1.,newsn/snwe) -! snhei=snwe*rhowater/rhosn -! NEWSN=NEWSN*rhowater/rhonewsn ENDIF ! end NEWSN > 0. IF(PRCPMS.NE.0.) THEN @@ -1553,9 +1644,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! J. of Hydrometeorology, 2006, CLM. interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac -!original - next 2 lines -! interw=DELT*PRCPMS*vegfrac -! intersn=NEWSN*vegfrac infwater=PRCPMS - interw/delt if((interw+intersn) > 0.) then intwratio=interw/(interw+intersn) @@ -1564,7 +1652,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! Update water/snow intercepted by the canopy dd1=CST + interw + intersn CST=DD1 -! if(i==666.and.j==282) print *,'666,282 - cst,sat,interw,intersn',cst,sat,interw,intersn IF(CST.GT.SAT) THEN CST=SAT DRIP=DD1-SAT @@ -1577,12 +1664,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infwater=PRCPMS endif ! vegfrac > 0.01 -! SNHEI_CRIT is a threshold for fractional snow - SNHEI_CRIT=0.01601*1.e3/rhosn - SNHEI_CRIT_newsn=0.0005*1.e3/rhosn -! snowfrac from the previous time step - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) - if(snowfrac < 0.75) snow_mosaic = 1. IF(NEWSN.GT.0.) THEN !Update snow on the ground @@ -1619,9 +1700,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! SNHEI_CRIT_newsn=0.001*1.e3/rhosn ! endif - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -!24nov15 - SNOWFRAC for urban category < 0.75 - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + if(isncovr_opt == 1) then + !-- update snow cover with accounting for fresh snow + snowfrac=min(1.,snhei/(2.*snhei_crit)) + endif + ! if(meltfactor > 1.5) then ! if(isltyp > 9 .and. isltyp < 13) then !24nov15 clay soil types - SNOFRAC < 0.9 @@ -1632,16 +1715,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snowfrac=min(0.85,snowfrac) ! endif -! SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -! elseif(snowfrac < 0.3 .and. tabs > 275.) then -! if(snowfrac < 0.3.and. tabs > 275.) snow_mosaic = 1. + if(newsn > 0. ) then + SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + endif - if(snowfrac < 0.75) snow_mosaic = 1. + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains to 0.85 (based on Swiss weather model over the Alps) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) - if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + !24nov15 - SNOWFRAC for urban category < 0.75 + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. + + KEEP_SNOW_ALBEDO = 0. + IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN ! new snow KEEP_SNOW_ALBEDO = 1. snow_mosaic=0. ! ??? @@ -1660,14 +1749,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). -!5mar12 IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) -! IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then if( snhei .le. 2.*ZNT)then + ! shallow snow znt=0.55*znt+0.45*z0tbl(iland) elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then znt=0.2*znt+0.8*z0tbl(iland) elseif(snhei > 4.*ZNT) then + ! deep snow znt=z0tbl(iland) endif ENDIF @@ -1790,7 +1879,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -1836,7 +1925,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia runoff1s=0. runoff2s=0. - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -1904,7 +1993,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia else snfr=snowfrac endif - CALL SNOWSOIL (debug_print, & !--- input variables + CALL SNOWSOIL (debug_print,xlat,xlon, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1934,7 +2023,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snfr=snowfrac endif - CALL SNOWSEAICE (debug_print, & + CALL SNOWSEAICE (debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1992,6 +2081,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,' Ground flux on snow-free land', i,j,ss print *,' CSTS, CST', i,j,csts,cst ENDIF + do k=1,nzs soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac @@ -2092,6 +2182,56 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif endif ! snow_mosaic = 1. + !-- 13 jan 2022 + ! update snow fraction after melting (Swenson, S.C. and Lawrence, 2012, + ! JGR, DOI:10.1029/2012MS000165 + ! + !if (snwe > 0.) then + ! if(smelt > 0.) then + !update snow fraction after melting + !n_melt = 200./max(10.,topo_std) + ! snowfrac = max(0.,snowfrac - (acos(min(1.,(2.*(smelt*delt/snwe) - + ! 1.)))/piconst)**10) + !snowfrac = 1. - (acos(min(1.,(2.*(smelt*delt/snwe) - + !1.)))/piconst)**10. + ! if(i==744.and.j==514 .or. i==924.and.j==568)then + !print *,'smr,n_melt,topo_std', smr,n_melt,topo_std + ! print *,'3 - snowfrac end', i,j,ktau,snowfrac,smelt*delt, snwe, + ! piconst + ! endif + ! endif + !else + ! snowfrac = 0. + !endif + ! + !-- The NY07 parameterization gives more realistic snow cover fraction + ! than SL12 + !-- 13 Jan 2022 + !-- update snow fraction after metlting (Niu, G.-Y., and Yang, Z.-L. 2007, + !JGR, + ! DOI:10.1029/2007JD008674) + ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the + ! forested areas with large roughness + + if(isncovr_opt == 1) then + !-- update snow cover after possible melting + snowfrac=min(1.,snhei/(2.*snhei_crit)) + else + !-- isncovr_opt=2 + if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + snowfrac = tanh( snhei/(2.5 * 0.25 *(rhosn/rhonewsn)**1.0)) + else + snowfrac = tanh( snhei/(2.5 *min(0.25,znt) *(rhosn/rhonewsn)**1.0)) + endif + endif + + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains ( Swiss weather model) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + ! run-total accumulated snow based on snowfall and snowmelt in [m] snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) @@ -2113,7 +2253,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5) then ! LAND - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2140,7 +2280,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia alb=albice RNET = GSWnew + XINET - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -2211,7 +2351,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, & + SUBROUTINE SOIL (debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2293,7 +2433,7 @@ SUBROUTINE SOIL (debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables REAL, & @@ -2548,7 +2688,7 @@ SUBROUTINE SOIL (debug_print, & !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -2584,7 +2724,7 @@ SUBROUTINE SOIL (debug_print, & ! field capacity ! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation ! when soil moisture is below field capacity. [Lee and Pielke, 1992] -! This formulation agrees with obsevations when top layer is < 2 cm thick. +! This formulation agrees with observations when top layer is < 2 cm thick. ! Soilres = 1 for snow, glaciers and wetland. ! fc=ref - suggested in the paper ! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change @@ -2614,27 +2754,8 @@ SUBROUTINE SOIL (debug_print, & !************************************************************** ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - if(1==2) then - print *,'i,j,iland,isoil ', i,j,iland,isoil - print *,'delt,ktau,conflx,nzs,nddzs,nroot ',delt,ktau,conflx,nzs,nddzs,nroot - print *,'PRCPMS,RAINF ',PRCPMS,RAINF - print *,'PATM,TABS,QVATM,QCATM,EMISS,RNET ',PATM,TABS,QVATM,QCATM,EMISS,RNET - print *,'QKMS,TKMS,PC,rho,vegfrac, lai ',QKMS,TKMS,PC,rho,vegfrac, lai - print *,'thdif ',thdif - print *,'cap ',cap - print *,'drycan,wetcan ',drycan,wetcan - print *,'transum,dew,soilres,alfa ',transum,dew,soilres,alfa - print *,'mavail ',mavail - print *,'dqm,qmin,bclh,zsmain,zshalf,DTDZS',dqm,qmin,bclh,zsmain,zshalf,DTDZS - print *,'xlv,CP,G0_P,cvw,stbolt ',xlv,CP,G0_P,cvw,stbolt - print *,'tso=',tso - print *,'soilt=',soilt - print *,'qvg=',qvg - print *,'qsg=',qsg - print *,'qcg=',qcg - endif ! 1==2 - - CALL SOILTEMP(debug_print, & + + CALL SOILTEMP(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2650,15 +2771,6 @@ SUBROUTINE SOIL (debug_print, & !--- output variables tso,soilt,qvg,qsg,qcg,x) -if(1==2) then - print *,'after tso=',tso - print *,'after soilt=',soilt - print *,'after qvg=',qvg - print *,'after qsg=',qsg - print *,'after qcg=',qcg - print *,'after x=',x -endif - !************************************************************************ !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW @@ -2866,7 +2978,7 @@ END SUBROUTINE SOIL !! on its surface. it solves heat diffusion inside ice and energy !! budget at the surface of ice. It computes skin temperature and !! temerature inside sea ice. - SUBROUTINE SICE ( debug_print, & + SUBROUTINE SICE ( debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & EMISS,RNET,QKMS,TKMS,rho,myj, & @@ -2890,7 +3002,7 @@ SUBROUTINE SICE ( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables REAL, & @@ -3038,7 +3150,7 @@ SUBROUTINE SICE ( debug_print, & tn,aa1,bb,pp,fkq,r210 ENDIF QGOLD=QSG - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over sea ice QVG=QS1 QSG=QS1 @@ -3134,7 +3246,7 @@ END SUBROUTINE SICE !! solves energy and moisture budgets on the surface of snow, and !! on the interface of snow and soil. It computes skin temperature, !! snow temperature, snow depth and snow melt. - SUBROUTINE SNOWSOIL ( debug_print, & + SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & @@ -3234,7 +3346,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - SNHEI_CRIT,meltfactor + SNHEI_CRIT,meltfactor,xlat,xlon LOGICAL, INTENT(IN ) :: myj @@ -3546,7 +3658,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & SMELT=0. ! DD1=0. - H=1. + H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3573,7 +3685,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & SNWE=0. ENDIF - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -3601,7 +3713,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & IF (debug_print ) THEN print *, 'TSO before calling SNOWTEMP: ', tso ENDIF - CALL SNOWTEMP(debug_print, & + CALL SNOWTEMP(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -3823,7 +3935,7 @@ END SUBROUTINE SNOWSOIL !! its surface. It solves energy budget on the snow interface with !! atmosphere and snow interface with ice. It calculates skin !! temperature, snow and ice temperatures, snow depth and snow melt. - SUBROUTINE SNOWSEAICE( debug_print, & + SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & @@ -3856,7 +3968,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - meltfactor, snhei_crit + meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj @@ -3958,8 +4070,9 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL, DIMENSION(1:NZS) :: cotso,rhtso REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr - integer :: nmelt + integer :: nmelt, isncond_opt + REAL :: keff !----------------------------------------------------------------- XLMELT=3.35E+5 @@ -3967,6 +4080,12 @@ SUBROUTINE SNOWSEAICE( debug_print, & XLVm=XLV+XLMELT ! STBOLT=5.670151E-8 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + isncond_opt = 1 + keff = 0.265 + !--- SNOW flag -- ISICE ! ILAND=isice @@ -4006,7 +4125,16 @@ SUBROUTINE SNOWSEAICE( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN + + if(isncond_opt == 1) then THDIFSN = 0.265/RHOCSN + else +!07Jun19 - snow thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + THDIFSN = keff/rhocsn + !print *,'1 keff,rhosn,rhocsn,THDIFSN ',i,j,keff,rhosn,rhocsn,THDIFSN + !-- old version THDIFSN = 0.265/RHOCSN + endif RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -4231,14 +4359,17 @@ SUBROUTINE SNOWSEAICE( debug_print, & print *,'TABS,QVATM,TN,QVG=',TABS,QVATM,TN,QVG ENDIF - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over snow QVG=QS1 QSG=QS1 QCG=0. -!--- SOILT - skin temperature +!--- SOILT - skin temperature of snow on ice SOILT=TS1 + if(nmelt==1 .and. snowfrac==1) then + soilt = min(273.15,soilt) + endif IF (debug_print ) THEN print *,' AFTER VILKA-SNOW on SEAICE' @@ -4440,7 +4571,15 @@ SUBROUTINE SNOWSEAICE( debug_print, & !13mar18 rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + else +!07Jun19 - snow thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + thdifsn = keff/RHOCSN + endif + endif endif @@ -4578,7 +4717,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4648,7 +4787,7 @@ SUBROUTINE SOILTEMP( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables REAL, & @@ -4803,7 +4942,7 @@ SUBROUTINE SOILTEMP( debug_print, & ! AA1=AA*alfa+CC PP=PATM*1.E3 AA1=AA1/PP - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 @@ -4826,7 +4965,7 @@ SUBROUTINE SOILTEMP( debug_print, & 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN ! if(i.eq.279.and.j.eq.263) then @@ -4901,7 +5040,7 @@ END SUBROUTINE SOILTEMP !>\ingroup lsm_ruc_group !> This subroutine solves energy bugdget equation and heat diffusion !! equation to obtain snow and soil temperatures. - SUBROUTINE SNOWTEMP( debug_print, & + SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & snwe,snwepr,snhei,newsnow,snowfrac, & @@ -4979,7 +5118,7 @@ SUBROUTINE SNOWTEMP( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & - rhonewsn,meltfactor + rhonewsn,meltfactor,xlat,xlon real :: rhonewcsn !--- 3-D Atmospheric variables @@ -5087,13 +5226,19 @@ SUBROUTINE SNOWTEMP( debug_print, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr - integer :: nmelt, iter + REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff + integer :: nmelt, iter, isncond_opt !----------------------------------------------------------------- iter = 0 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + isncond_opt = 1 + keff = 0.265 + do k=1,nzs transp (k)=0. cotso (k)=0. @@ -5107,7 +5252,16 @@ SUBROUTINE SNOWTEMP( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + else +!07Jun19 - thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + THDIFSN = keff/rhocsn + !print *,'2 keff,rhosn,rhocsn,THDIFSN ',i,j,keff,rhosn,rhocsn,THDIFSN + endif + RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -5175,8 +5329,8 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5204,9 +5358,9 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -273.15) endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -5227,8 +5381,8 @@ SUBROUTINE SNOWTEMP( debug_print, & denom = 1. + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) cotsn=cotso(NZS) @@ -5245,7 +5399,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ETT1=0. EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) - H=1. + H=MAVAIL !1. TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS UMVEG=1.-VEGFRAC @@ -5334,7 +5488,14 @@ SUBROUTINE SNOWTEMP( debug_print, & AA1=AA1/PP BB=BB-SNOH/TDENOM - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + IF (debug_print ) THEN + if (abs(xlat-42.05).lt.0.5 .and. & + abs(xlon-286.75).lt.0.5)then + print *,'1-', i,tn,aa1,bb,pp,ktau,newsnow,snwe,snhei,soilt,soilt1,tso,rhosn,rhonewcsn + print *,'2-', i,tdenom,fkq,vegfrac,can,tabs,R210,D10,R21,D9sn,D1sn,R22sn,R7,prcpms + endif + ENDIF + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 @@ -5353,7 +5514,7 @@ SUBROUTINE SNOWTEMP( debug_print, & GOTO 200 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 @@ -5380,19 +5541,30 @@ SUBROUTINE SNOWTEMP( debug_print, & iter=1 ! goto 2211 endif -endif ! 1==2 IF (debug_print ) THEN if(iter==1) then print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 endif ENDIF +endif ! 1==2 !--- SOILT - skin temperature SOILT=TS1 + if(nmelt==1 .and. snowfrac==1) then + !--7feb22 on the second iteration when SNOH is known, + !-- check if the snow skin temperature is <273.15K + !-- when a grid cells is fully covered with snow and snow_mosaic=0. + !-- or with partial snow cover and snow_mosaic=1. + if (debug_print ) then + print *,'soilt is too high =',i,j,soilt + soilt = min(273.15,soilt) + endif + endif + IF (debug_print ) THEN ! IF(i.eq.266.and.j.eq.447) then - print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso + print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso ! endif ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface @@ -5405,14 +5577,14 @@ SUBROUTINE SNOWTEMP( debug_print, & else !-- 1 layer in snow TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT - SOILT1=TSO(1) + SOILT1=min(273.15,TSO(1)) tsob=tso(1) endif ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN ! blended TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT tso(1)=(tso(2)+(soilt-tso(2))*fso) - SOILT1=TSO(1) + SOILT1=min(273.15,TSO(1)) tsob=TSO(2) ELSE !-- very thin or zero snow. If snow is thin we suppose that @@ -5511,7 +5683,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ENDIF ! - X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & + X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & XLVM*R210*(QVG-QGOLD) IF (debug_print ) THEN print *,'SNOWTEMP storage ',i,j,x @@ -5612,7 +5784,14 @@ SUBROUTINE SNOWTEMP( debug_print, & ! rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + else +!07Jun19 - snow thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + thdifsn = keff / rhocsn + endif endif endif @@ -5716,14 +5895,14 @@ SUBROUTINE SNOWTEMP( debug_print, & IF(SNHEI.GT.0.) THEN if(ilnb.gt.1) then - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15) else - tsnav=0.5*(soilt+tso(1)) - 273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) - 273.15) endif ELSE - tsnav= soilt - 273.15 + tsnav= min(0.,soilt - 273.15) ENDIF !------------------------------------------------------------------------ @@ -5929,7 +6108,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - TOTLIQ=PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT + TOTLIQ=PRCP-DRIP/DELT-(1.-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 @@ -6522,13 +6701,13 @@ END SUBROUTINE TRANSF !> This subroutine finds the solution of energy budget at the surface !! from the pre-computed table of saturated water vapor mixing ratio !! and estimated surface temperature. - SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) + SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !-------------------------------------------------------------- !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP + REAL, INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil REAL, INTENT(OUT ) :: QS, TS @@ -6551,12 +6730,12 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) IF(I1.NE.I) GOTO 10 TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP -! print *,'in VILKA - TS,QS',ts,qs GOTO 20 ! 1 PRINT *,'Crash in surface energy budget - STOP' 1 PRINT *,' AVOST IN VILKA Table index= ',I ! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn + print *,'AVOST point at xlat/xlon=',xlat,xlon ! CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE !----------------------------------------------------------------------- @@ -7309,6 +7488,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) READ (19,*) READ (19,*)BARE READ (19,*) + READ (19,*)GLACIER + READ (19,*) READ (19,*)NATURAL READ (19,*) READ (19,*)CROP diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index c21d3a9899..ce1d43549e 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -21,30 +21,40 @@ end subroutine sfc_diag_finalize !! \section general General Algorithm !! \section detailed Detailed Algorithm !! @{ - subroutine sfc_diag_run & - & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & - & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & - & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & + subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & + & wet,shflx,chs2,cqs2,cdq,wind, & + & zf,ps,u1,v1,t1,q1,prslki,evap, & + & fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & + & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! use machine , only : kind_phys use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im + integer, intent(in) :: im, lsm, lsm_ruc + logical, intent(in) :: do_mynnsfclay logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. - real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 - real(kind=kind_phys), dimension(:), intent(in) :: & - & ps, u1, v1, t1, q1, tskin, & - & qsurf, prslki, evap, fm, fh, fm10, fh2 + real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), dimension(:), intent( in) :: & + & zf, ps, u1, v1, t1, q1, tskin, wet, & + & qsurf, prslki, evap, fm, fh, fm10, fh2, & + & shflx, chs2, cqs2, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & - & f10m, u10m, v10m, t2m, q2m + & f10m, u10m, v10m, t2m, q2m, dpt2m character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! ! locals ! + logical :: flux, debug_print real(kind=kind_phys), parameter :: qmin=1.0e-8 + real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho + real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 + real(kind=kind_phys) :: t2_alt, q2_alt + real(kind=kind_phys) :: thcon, cqs, chs + real(kind=kind_phys) :: testptlat, testptlon integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk @@ -55,6 +65,12 @@ subroutine sfc_diag_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + + !-- + testptlat = 35.3 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 273.0 !284.50 !286.75 !280.6 !164.0 !283.0 + !-- + debug_print = .false. ! ! estimate sigma ** k at 2 m ! @@ -64,6 +80,10 @@ subroutine sfc_diag_run & ! ps is in pascals ! !! + flux = .false. + + if (do_mynnsfclay .and. lsm == lsm_ruc) flux = .true. + do i = 1, im f10m(i) = fm10(i) / fm(i) ! f10m(i) = min(f10m(i),1.) @@ -75,23 +95,131 @@ subroutine sfc_diag_run & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi + thcon = (1.e5/ps(i))**rocp + !-- make sure 1st level q is not higher than saturated value + qss = fpvs(t1(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q1c = min(q1(i),qss) ! lev 1 spec. humidity - if(thsfc_loc) then ! Use local potential temperature - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + qv1 = q1c / (1. - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio + chs = cdq(i) * wind(i) + cqs = chs + qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1(i))*fhi - endif + if(.not. flux) then + !-- original method + if(lsm /= lsm_ruc) then + if(thsfc_loc) then ! Use local potential temperature + t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1c)*fhi + endif + else + !-- RUC lsm + if(chs.lt.1.E-5) then + !-- under very stable conditions use first level temperature + t2m(i) = t1(i) + else + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + + if(cqs.lt.1.E-5) then + q2m(i)=max(qmin,q1c) ! spec. humidity + else + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + endif + endif ! RUC lsm + + else + !-- flux method + if(chs2(i).lt.1.E-5) then + !-- under very stable conditions use first level temperature + t2m(i) = t1(i) + else + th2m = tskin(i)*thcon - shflx(i)/chs2(i) + t2m(i) = th2m/thcon + endif + + if(cqs2(i).lt.1.E-5) then + !-- under very stable conditions use first level for 2-m mixing ratio + q2m(i)=max(qmin,q1c) ! spec. humidity + else + x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio + q2m(i) = x2m/(1. + x2m) ! spec. humidity + endif + + !-- Alternative logarithmic diagnostics: + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > 0.) THEN + ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + !for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + T2_alt = tskin(i) + fac * dT + ELSE + !no alternatives (yet) for unstable conditions + T2_alt = t2m(i) + ENDIF + + IF (dQ > 0.) THEN + ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + !-- for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + ELSE + !no alternatives (yet) for unstable conditions + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + !t2m(i) = T2_alt + !q2m(i) = Q2_alt + endif ! flux method + + !-- check that T2m,Q2m values lie in the range between tskin and t1 + x2m = max(min(tskin(i),t1(i)) , t2m(i)) + t2m(i) = min(max(tskin(i),t1(i)) , x2m) + x2m = max(min(qsurf(i),q1c) , q2m(i)) + q2m(i) = min(max(qsurf(i),q1c) , x2m) + + !-- make sure q2m is not oversaturated qss = fpvs(t2m(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) + qss = eps * qss/(ps(i) + epsm1 * qss) q2m(i) = min(q2m(i),qss) + + ! Compute dew point, using vapor pressure + qv = max(qmin,(q2m(i)/(1.-q2m(i)))) + tem = max(ps(i) * qv/( eps - epsm1 *qv), 1.e-8) + dpt2m(i) = 243.5/( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + dpt2m(i) = min(dpt2m(i),t2m(i)) + + + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + & abs(xlon_d(i)-testptlon).lt.0.2)then + print 100,'(ruc_lsm_diag) i=',i, & + & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & + & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& + & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & + & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & + & 'chs2 ',chs2(i),'cqs2 ',cqs2(i),'cqs ',cqs,'cdq',cdq(i) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) + enddo return diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index dd3bf79b8f..8c3275332a 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -14,6 +14,43 @@ dimensions = () type = integer intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[do_mynnsfclay] + standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme + long_name = flag to activate MYNN surface layer + units = flag + dimensions = () + type = logical + intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [grav] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -46,6 +83,30 @@ type = real kind = kind_phys intent = in +[rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[wet] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [ps] standard_name = surface_air_pressure long_name = surface pressure @@ -71,7 +132,7 @@ kind = kind_phys intent = in [t1] - standard_name = air_temperature_of_new_state_at_surface_adjacent_layer + standard_name = air_temperature_at_surface_adjacent_layer long_name = 1st model layer air temperature units = K dimensions = (horizontal_loop_extent) @@ -79,7 +140,7 @@ kind = kind_phys intent = in [q1] - standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer + standard_name = specific_humidity_at_surface_adjacent_layer long_name = 1st model layer specific humidity units = kg kg-1 dimensions = (horizontal_loop_extent) @@ -157,6 +218,46 @@ dimensions = () type = logical intent = in +[shflx] + standard_name = surface_upward_temperature_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[chs2] + standard_name = surface_exchange_coefficient_for_heat_at_2m + long_name = exchange coefficient for heat at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cqs2] + standard_name = surface_exchange_coefficient_for_moisture_at_2m + long_name = exchange coefficient for moisture at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cdq] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm @@ -197,6 +298,14 @@ type = real kind = kind_phys intent = out +[dpt2m] + standard_name = dewpoint_temperature_at_2m + long_name = 2 meter dewpoint temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index be2ff93782..63f829407a 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -300,15 +300,15 @@ end subroutine lsm_ruc_finalize ! sncovr1 - real, snow cover over land (fractional) im ! ! qsurf - real, specific humidity at sfc im ! ! gflux - real, soil heat flux (w/m**2) im ! -! drain - real, subsurface runoff (m/s) im ! +! drain - real, subsurface runoff (mm/s) im ! ! evap - real, latent heat flux in kg kg-1 m s-1 im ! -! runof - real, surface runoff (m/s) im ! -! evbs - real, direct soil evaporation (m/s) im ! -! evcw - real, canopy water evaporation (m/s) im ! -! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! runof - real, surface runoff (mm/s) im ! +! evbs - real, direct soil evaporation (W m-2) im ! +! evcw - real, canopy water evaporation (W m-2) im ! +! sbsno - real, sublimation/deposit from snopack (W m-2) im ! ! stm - real, total soil column moisture content (m) im ! -! trans - real, total plant transpiration (m/s) im ! -! zorl - real, surface roughness im ! +! trans - real, total plant transpiration (W m-2) im ! +! zorl - real, surface roughness (cm) im ! ! wetness - real, normalized soil wetness im ! ! ! ! ==================== end of description ===================== ! @@ -323,17 +323,17 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& - & t1, q1, qc, stype, vtype, sigmaf, laixy, & + & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, & + & oro, sigma, zs, t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & - & rainnc, rainc, ice, snow, graupel, & - & prsl1, zf, wind, shdmin, shdmax, & + & rainnc, rainc, ice, snow, graupel, prsl1, zf, & + & wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & & isot, ivegsrc, fice, smcwlt2, smcref2, & & min_lakeice, min_seaice, oceanfrac, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_fvirt, & + & con_hfus, con_fvirt, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -345,13 +345,13 @@ subroutine lsm_ruc_run & ! inputs & qsurf_lnd, gflux_lnd, evap_lnd, hflx_lnd, & & runof, runoff, srunoff, drain, & & cm_lnd, ch_lnd, evbs, evcw, stm, wetness, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & & tsurf_ice, tsnow_ice, z0rl_ice, & & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & - & cm_ice, ch_ice, snowfallac_ice, & + & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & ! --- out & rhosnf, sbsno, & @@ -373,6 +373,7 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d + real (kind=kind_phys), dimension(:), intent(in) :: oro, sigma real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -388,7 +389,7 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys), intent(in) :: delt, min_seaice, min_lakeice real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & con_pi, con_rd, & - con_hvap, con_fvirt + con_hvap, con_hfus, con_fvirt logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy, use_lake @@ -430,10 +431,11 @@ subroutine lsm_ruc_run & ! inputs ! for land & sncovr1_lnd, qsurf_lnd, gflux_lnd, evap_lnd, & & cmm_lnd, chh_lnd, hflx_lnd, sbsno, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & ! for ice & sncovr1_ice, qsurf_ice, gflux_ice, evap_ice, ep1d_ice, & - & cmm_ice, chh_ice, hflx_ice, snowfallac_ice + & cmm_ice, chh_ice, hflx_ice, & + & snowfallac_ice, acsnow_ice, snowmt_ice real (kind=kind_phys), dimension(:), intent( out) :: & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & @@ -453,14 +455,14 @@ subroutine lsm_ruc_run & ! inputs & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land & weasd_lnd_old, snwdph_lnd_old, tskin_lnd_old, & - & tsnow_lnd_old, snowfallac_lnd_old, & + & tsnow_lnd_old, snowfallac_lnd_old, acsnow_lnd_old, & & sfcqv_lnd_old, sfcqc_lnd_old, z0rl_lnd_old, & - & sncovr1_lnd_old, & + & sncovr1_lnd_old,snowmt_lnd_old, & ! for ice & weasd_ice_old, snwdph_ice_old, tskin_ice_old, & - & tsnow_ice_old, snowfallac_ice_old, & + & tsnow_ice_old, snowfallac_ice_old, acsnow_ice_old, & & sfcqv_ice_old, sfcqc_ice_old, z0rl_ice_old, & - & sncovr1_ice_old + & sncovr1_ice_old,snowmt_ice_old !-- local spp pattern array real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm @@ -478,6 +480,7 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys),dimension (im,1,1) :: & & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 + real (kind=kind_phys),dimension (im,1) :: orog, stdev real (kind=kind_phys),dimension (im,1) :: & & albbck_lnd, alb_lnd, chs_lnd, flhc_lnd, flqc_lnd, & & wet, wet_ice, smmax, cmc, drip, ec, edir, ett, & @@ -491,7 +494,7 @@ subroutine lsm_ruc_run & ! inputs & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn, & + & precipfr, snfallac_lnd, acsn_lnd, & & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq ! ice real (kind=kind_phys),dimension (im,1) :: & @@ -500,7 +503,7 @@ subroutine lsm_ruc_run & ! inputs & solnet_ice, sfcems_ice, hfx_ice, & & sneqv_ice, snoalb1d_ice, snowh_ice, snoh_ice, tsnav_ice, & & snomlt_ice, sncovr_ice, ssoil_ice, soilt_ice, & - & z0_ice, znt_ice, snfallac_ice, & + & z0_ice, znt_ice, snfallac_ice, acsn_ice, & & qsfc_ice, qsg_ice, qvg_ice, qcg_ice, soilt1_ice @@ -539,8 +542,8 @@ subroutine lsm_ruc_run & ! inputs ipr = 10 !-- - testptlat = 74.12 !29.5 - testptlon = 164.0 !283.0 + testptlat = 68.6 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 298.6 !284.50 !286.75 !280.6 !164.0 !283.0 !-- debug_print=.false. @@ -630,7 +633,7 @@ subroutine lsm_ruc_run & ! inputs if(ivegsrc == 1) then llanduse = 'MODI-RUC' ! IGBP iswater = 17 - isice = 15 + isice = glacier else write(errmsg, '(a,i0)') 'Logic error in sfc_drv_ruc_run: iswater/isice not configured for ivegsrc=', ivegsrc errflg = 1 @@ -667,8 +670,8 @@ subroutine lsm_ruc_run & ! inputs wetness_old(i) = wetness(i) canopy_old(i) = canopy(i) !srflag_old(i) = srflag(i) - !acsnow_old(i) = acsnow(i) ! for land + acsnow_lnd_old(i) = acsnow_lnd(i) weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) tskin_lnd_old(i) = tskin_lnd(i) @@ -678,16 +681,19 @@ subroutine lsm_ruc_run & ! inputs sfcqc_lnd_old(i) = sfcqc_lnd(i) z0rl_lnd_old(i) = z0rl_lnd(i) sncovr1_lnd_old(i) = sncovr1_lnd(i) + snowmt_lnd_old(i) = snowmt_lnd(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) tskin_ice_old(i) = tskin_ice(i) tsnow_ice_old(i) = tsnow_ice(i) + acsnow_ice_old(i) = acsnow_ice(i) snowfallac_ice_old(i) = snowfallac_ice(i) sfcqv_ice_old(i) = sfcqv_ice(i) sfcqc_ice_old(i) = sfcqc_ice(i) z0rl_ice_old(i) = z0rl_ice(i) sncovr1_ice_old(i) = sncovr1_ice(i) + snowmt_ice_old(i) = snowmt_ice(i) do k = 1, lsoil_ruc smois_old(i,k) = smois(i,k) @@ -721,6 +727,8 @@ subroutine lsm_ruc_run & ! inputs sbsno(i) = 0.0 !local i,j arrays + snoh_lnd(i,j) = 0.0 + snoh_ice(i,j) = 0.0 dew_lnd(i,j) = 0.0 dew_ice(i,j) = 0.0 soilm(i,j) = 0.0 @@ -731,7 +739,8 @@ subroutine lsm_ruc_run & ! inputs qfx_ice(i,j) = 0.0 lh_lnd(i,j) = 0.0 lh_ice(i,j) = 0.0 - acsn(i,j) = 0.0 + esnow_lnd(i,j) = 0.0 + esnow_ice(i,j) = 0.0 sfcexc(i,j) = 0.0 acceta(i,j) = 0.0 ssoil_lnd(i,j) = 0.0 @@ -743,7 +752,9 @@ subroutine lsm_ruc_run & ! inputs runoff2(i,j) = 0.0 acrunoff(i,j) = 0.0 snfallac_lnd(i,j) = 0.0 + acsn_lnd(i,j) = 0.0 snfallac_ice(i,j) = 0.0 + acsn_ice(i,j) = 0.0 rhosnfr(i,j) = 0.0 precipfr(i,j) = 0.0 @@ -782,6 +793,13 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif + do j = 1, 1 ! 1:1 + do i = 1, im ! i - horizontal loop + orog(i,j) = oro(i) !topography + stdev(i,j) = sigma(i) ! st. deviation (m) + enddo + enddo + do j = 1, 1 ! 1:1 do i = 1, im ! i - horizontal loop xice(i,j) = 0. @@ -805,9 +823,9 @@ subroutine lsm_ruc_run & ! inputs !> - 2. forcing data (f): !!\n \a sfcprs - pressure at height zf above ground (pascals) !!\n \a sfctmp - air temperature (\f$K\f$) at height zf above ground -!!\n \a q2 - pressure at height zf above ground (pascals) -!!\n \a qcatm - cloud water mising ration at height zf above ground (\f$kg !kg^{-1}\f$) -!!\n \a rho2 - air density at height zf above ground (pascals) +!!\n \a q2 - water vapor mix. ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a qcatm - cloud water mixing ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a rho2 - air density at height zf above ground ((\f$kg m^{-3}\f$)) sfcprs(i,1,j) = prsl1(i) sfctmp(i,1,j) = t1(i) @@ -822,7 +840,7 @@ subroutine lsm_ruc_run & ! inputs !!\n \a rainncv - time-step non-convective precip (\f$kg m^{-2} \f$) !!\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 solod form (\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 @@ -837,16 +855,18 @@ subroutine lsm_ruc_run & ! inputs !rainncv(i,j) = rhoh2o * max(rain(i)-rainc(i),0.0) ! total time-step explicit precip !graupelncv(i,j) = rhoh2o * graupel(i) !snowncv(i,j) = rhoh2o * snow(i) - prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! tprcp in [m] - convective plus explicit - raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip - rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip + prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! total time-step convective plus explicit [mm] + raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip [mm] + rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip [mm] graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) + acsn_lnd(i,j) = acsnow_lnd(i) + snomlt_lnd(i,j) = snowmt_lnd(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + abs(xlon_d(i)-testptlon).lt.0.2)then + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i), & @@ -855,11 +875,12 @@ subroutine lsm_ruc_run & ! inputs 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'prsl1',prsl1(i),'t1',t1(i), & !'snow',snow(i), 'snowncv',snowncv(i,j), & - 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'srflag',srflag(i),'weasd mm ',weasd_lnd(i), & + 'tsnow_lnd',tsnow_lnd(i),'snwdph mm',snwdph_lnd(i), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif endif - 100 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) !-- ! ice precipitation is not used @@ -867,8 +888,6 @@ subroutine lsm_ruc_run & ! inputs ! ice not used ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - !acsn(i,j) = acsnow(i) - acsn(i,j) = 0.0 tbot(i,j) = tg3(i) @@ -963,7 +982,7 @@ subroutine lsm_ruc_run & ! inputs endif ! coszen > 0. snoalb1d_lnd(i,j) = snoalb(i) - albbck_lnd(i,j) = albbcksol(i) !sfalb_lnd_bck(i) + albbck_lnd(i,j) = min(0.9,albbcksol(i)) !sfalb_lnd_bck(i) !-- spp_lsm @@ -989,14 +1008,14 @@ subroutine lsm_ruc_run & ! inputs solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 cmc(i,j) = canopy(i) ! [mm] - soilt_lnd(i,j) = tsurf_lnd(i) ! clu_q2m_iter + soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow - if (tsnow_lnd(i) > 0. .and. tsnow_lnd(i) < 273.15) then + if (tsnow_lnd(i) > 200. .and. tsnow_lnd(i) < 273.15) then soilt1_lnd(i,j) = tsnow_lnd(i) else soilt1_lnd(i,j) = tsurf_lnd(i) endif - tsnav_lnd(i,j) = 0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15 + tsnav_lnd(i,j) = min(0.,0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15) do k = 1, lsoil_ruc smsoil (i,k,j) = smois(i,k) slsoil (i,k,j) = sh2o(i,k) @@ -1012,27 +1031,74 @@ subroutine lsm_ruc_run & ! inputs endif chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance - flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (1.+0.84*q2(i,1,j)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) + ! for output cmm_lnd(i) = cm_lnd(i) * wind(i) chh_lnd(i) = chs_lnd(i,j) * rho(i) ! - snowh_lnd(i,j) = max(1.e-7,snwdph_lnd(i) * 0.001) ! convert from mm to m - sneqv_lnd(i,j) = max(1.e-4,weasd_lnd(i)) ! [mm] - snfallac_lnd(i,j) = snowfallac_lnd(i) - !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0 .and. snowh_lnd(i,j) == 0.0) then - snowh_lnd(i,j) = 0.003 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 - endif + sneqv_lnd(i,j) = weasd_lnd(i) + snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - if (snowh_lnd(i,j) /= 0.0 .and. sneqv_lnd(i,j) == 0.0) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) ! snow density ~300 kg m-3 - endif + snfallac_lnd(i,j) = snowfallac_lnd(i) - if (sneqv_lnd(i,j) > 0. .and. snowh_lnd(i,j) > 0.) then - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 950.) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) + !> -- sanity checks on sneqv and snowh + if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(sneqv_lnd(i,j) < 1.e-7.or.soilt_lnd(i,j)>273.15d0) then + sneqv_lnd(i,j) = 0.d0 + snowh_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 300.d0 * snowh_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (snowh_lnd(i,j) /= 0.0d0 .and. sneqv_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(snowh_lnd(i,j) < 3.d-10.or.soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.003d0 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (sneqv_lnd(i,j) > 0.d0 .and. snowh_lnd(i,j) > 0.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.2.5 .and. & + abs(xlon_d(i)-testptlon).lt.2.5)then + print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.002d0 * sneqv_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 58.d0 * snowh_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif endif endif @@ -1040,64 +1106,35 @@ subroutine lsm_ruc_run & ! inputs z0_lnd(i,j) = z0rl_lnd(i)/100. znt_lnd(i,j) = z0rl_lnd(i)/100. - if(debug_print) then - if(me==0 ) then - write (0,*)'before LSMRUC for land' - write (0,*)'sfcems(i,j) =',i,j,sfcems_lnd(i,j) - write (0,*)'chklowq(i,j) =',i,j,chklowq(i,j) - write (0,*)'chs(i,j) =',i,j,chs_lnd(i,j) - write (0,*)'flqc(i,j) =',i,j,flqc_lnd(i,j) - write (0,*)'flhc(i,j) =',i,j,flhc_lnd(i,j) - write (0,*)'wet(i,j) =',i,j,wet(i,j) - write (0,*)'cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'shdfac(i,j) =',i,j,shdfac(i,j) - write (0,*)'alb(i,j) =',i,j,alb_lnd(i,j) - write (0,*)'znt(i,j) =',i,j,znt_lnd(i,j) - write (0,*)'z0(i,j) =',i,j,z0_lnd(i,j) - write (0,*)'snoalb1d(i,j) =',i,j,snoalb1d_lnd(i,j) - write (0,*)'landusef(i,:,j) =',i,j,landusef(i,:,j) - write (0,*)'soilctop(i,:,j) =',i,j,soilctop(i,:,j) - write (0,*)'nlcat=',nlcat - write (0,*)'nscat=',nscat - write (0,*)'qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'tbot(i,j) =',i,j,tbot(i,j) - write (0,*)'vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'xland(i,j) =',i,j,xland(i,j) - write (0,*)'xice(i,j) =',i,j,xice(i,j) - write (0,*)'iswater=',iswater - write (0,*)'isice=',isice - write (0,*)'xice_threshold=',xice_threshold - write (0,*)'con_cp=',con_cp - write (0,*)'con_rv=',con_rv - write (0,*)'con_rd=',con_rd - write (0,*)'con_g=',con_g - write (0,*)'con_pi=',con_pi - write (0,*)'con_hvap=',con_hvap - write (0,*)'stbolt=',stbolt - write (0,*)'smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'acrunoff(i,j) =',i,j,acrunoff(i,j) - write (0,*)'acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'shdmin1d(i,j) =',i,j,shdmin1d(i,j) - write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) - write (0,*)'rdlai2d =',rdlai2d - endif + !if (debug_print) then + !-- diagnostics for a land test point with known lat/lon + if (kdt < 10) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + !if(weasd_lnd(i) > 0.) & + print 100,'(ruc_lsm_drv before RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& + !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& + 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & + 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & + 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & + 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j),& + 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & + 'keepfrsoil',keepfrsoil(i,1,j), & + 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif + endif ! debug_print + !-- !> - Call RUC LSM lsmruc() for land. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & @@ -1105,6 +1142,7 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & @@ -1125,50 +1163,54 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smsoil(i,:,j), slsoil(i,:,j), soilm(i,j), smmax(i,j), & & stsoil(i,:,j), soilt_lnd(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_lnd(i,j), snoh_lnd(i,j), & & hfx_lnd(i,j), qfx_lnd(i,j), lh_lnd(i,j), & & 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(i,j), snomlt_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, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) - if(debug_print) then - write (0,*)'after LSMRUC for land' - write (0,*)'after sneqv(i,j) =',i,j,sneqv_lnd(i,j) - write (0,*)'after snowh(i,j) =',i,j,snowh_lnd(i,j) - write (0,*)'after sncovr(i,j) =',i,j,sncovr_lnd(i,j) - write (0,*)'after vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'after stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'after wet(i,j) =',i,j,wet(i,j) - write (0,*)'after cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'after qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'after qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'after qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'after qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'after dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'after soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'after tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'after soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'after tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'after smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'after slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'after stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'after smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'after keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'after soilm(i,j) =',i,j,soilm(i,j) - write (0,*)'after smmax(i,j) =',i,j,smmax(i,j) - write (0,*)'after hfx(i,j) =',i,j,hfx_lnd(i,j) - write (0,*)'after qfx(i,j) =',i,j,qfx_lnd(i,j) - write (0,*)'after lh(i,j) =',i,j,lh_lnd(i,j) - write (0,*)'after infiltr(i,j) =',i,j,infiltr(i,j) - write (0,*)'after runoff1(i,j) =',i,j,runoff1(i,j) - write (0,*)'after runoff2(i,j) =',i,j,runoff2(i,j) - write (0,*)'after ssoil(i,j) =',i,j,ssoil_lnd(i,j) - write (0,*)'after snfallac(i,j) =',i,j,snfallac_lnd(i,j) - write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'after snomlt(i,j) =',i,j,snomlt_lnd(i,j) - endif + if(debug_print) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print 100,'(ruc_lsm_drv after RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'sneqv(i,j) =',sneqv_lnd(i,j), & + 'snowh(i,j) =',snowh_lnd(i,j), & + 'sncovr(i,j) =',sncovr_lnd(i,j), & + 'vtype(i,j) =',vtype_lnd(i,j), & + 'stype(i,j) =',stype_lnd(i,j), & + 'wet(i,j) =',wet(i,j), & + 'cmc(i,j) =',cmc(i,j), & + 'qsfc(i,j) =',qsfc_lnd(i,j), & + 'qvg(i,j) =',qvg_lnd(i,j), & + 'qsg(i,j) =',qsg_lnd(i,j), & + 'qcg(i,j) =',qcg_lnd(i,j), & + 'dew(i,j) =',dew_lnd(i,j), & + 'soilt(i,j) =',soilt_lnd(i,j), & + 'tskin(i) =',tskin_lnd(i), & + 'soilt1(i,j) =',soilt1_lnd(i,j), & + 'tsnav(i,j) =',tsnav_lnd(i,j), & + 'smsoil(i,:,j)=',smsoil(i,:,j), & + 'slsoil(i,:,j)=',slsoil(i,:,j), & + 'stsoil(i,:,j)=',stsoil(i,:,j), & + 'smfrsoil(i,:,j)=',smfrsoil(i,:,j), & + 'keepfrsoil(i,:,j)=',keepfrsoil(i,:,j), & + 'soilm(i,j) =',soilm(i,j), & + 'smmax(i,j) =',smmax(i,j), & + 'hfx(i,j) =',hfx_lnd(i,j), & + 'lh(i,j) =',lh_lnd(i,j), & + 'infiltr(i,j) =',infiltr(i,j), & + 'runoff1(i,j) =',runoff1(i,j), & + 'runoff2(i,j) =',runoff2(i,j), & + '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) + endif + endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -1178,23 +1220,21 @@ subroutine lsm_ruc_run & ! inputs !!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) !!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) -!!\n \a lh - actual latent heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a hfx - sensible heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) -!!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface -!!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) +!!\n \a snoh - phase-change heat flux from snowmelt (\f$W m^{-2}\f$) ! -! --- ... do not return the following output fields to parent model -! ec - canopy water evaporation (m s-1) -! edir - direct soil evaporation (m s-1) +! evcw (W m-2) - canopy water evaporation flux +! evbs (W m-2) - direct soil evaporation flux +! trans (W m-2) - total plant transpiration +! edir, ec, ett - direct evaporation, evaporation of +! canopy water and transpiration (kg m-2 s-1) ! et(nsoil)-plant transpiration from a particular root layer (m s-1) -! ett - total plant transpiration (m s-1) -! esnow - sublimation from (or deposition to if <0) snowpack (m s-1) +! esnow - sublimation from (or deposition to if <0) snowpack (kg m-2 s-1) +! sbsno - sublimation from (or deposition to if <0) snowpack (W m-2) +! hfx - upward heat flux at the surface (W/m^2) +! qfx - upward moisture flux at the surface (kg kg-1 kg m-2 s-1) ! drip - through-fall of precip and/or dew in excess of canopy ! water-holding capacity (m) -! snomlt - snow melt (m) (water equivalent) +! snomlt - snow melt (kg m-2) (water equivalent) ! xlai - leaf area index (dimensionless) ! soilw - available soil moisture in root zone (unitless fraction ! between smcwlt and smcmax) @@ -1202,40 +1242,39 @@ subroutine lsm_ruc_run & ! inputs ! nroot - number of root layers, a function of veg type, determined ! in subroutine redprm. - - !evbs(i) = edir(i,j) - !evcw(i) = ec(i,j) - !trans(i) = ett(i,j) - !sbsno(i) = esnow(i,j) - !snohf(i) = snoh(i,j) + evbs(i) = edir(i,j) * rhoh2o * con_hvap + evcw(i) = ec(i,j) * rhoh2o * con_hvap + trans(i) = ett(i,j) * rhoh2o * con_hvap + sbsno(i) = esnow_lnd(i,j) * con_hfus + snohf(i) = snoh_lnd(i,j) ! Interstitial - evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kinematic - hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! kinematic + evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kg kg-1 m s-1 kinematic + hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! K m s-1 kinematic gflux_lnd(i) = ssoil_lnd(i,j) qsurf_lnd(i) = qsfc_lnd(i,j) tsurf_lnd(i) = soilt_lnd(i,j) tsnow_lnd(i) = soilt1_lnd(i,j) stm(i) = soilm(i,j) * 1.e-3 ! convert to [m] - runof (i) = runoff1(i,j) - drain (i) = runoff2(i,j) + runof (i) = runoff1(i,j) * rhoh2o ! surface kg m-2 s-1 + drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 wetness(i) = wet(i,j) - ! tsnow(i) = soilt1(i,j) sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) ! --- ... units [m/s] = [g m-2 s-1] rhosnf(i) = rhosnfr(i,j) - !acsnow(i) = acsn(i,j) ! kg m-2 + acsnow_lnd(i) = acsn_lnd(i,j) ! accum kg m-2 + snowmt_lnd(i) = snomlt_lnd(i,j) ! accum kg m-2 ! --- ... accumulated total runoff and surface runoff - runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt * 0.001 ! kg m-2 - srunoff(i) = srunoff(i) + runof(i) * delt * 0.001 ! kg m-2 + runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt ! accum total kg m-2 + srunoff(i) = srunoff(i) + runof(i) * delt ! accum surface kg m-2 ! --- ... accumulated frozen precipitation (accumulation in lsmruc) - snowfallac_lnd(i) = snfallac_lnd(i,j) ! kg m-2 + snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * 1000.0 @@ -1254,7 +1293,7 @@ subroutine lsm_ruc_run & ! inputs !-- fill in albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_lnd(i) = sfalb_lnd(i) albdnir_lnd(i) = sfalb_lnd(i) - albinir_lnd(i) = sfalb_lnd(i) + albivis_lnd(i) = sfalb_lnd(i) albinir_lnd(i) = sfalb_lnd(i) do k = 1, lsoil_ruc @@ -1275,23 +1314,26 @@ subroutine lsm_ruc_run & ! inputs !-- ice point if (debug_print) then - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & - print 101,'(ruc_lsm_drv ice) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i),'flag_ice',flag_ice(i),& + if (abs(xlat_d(i)-testptlat).lt.0.1 .and. & + abs(xlon_d(i)-testptlon).lt.0.1)then + !if(weasd_ice(i) > 0.) & + print 101,'(ruc_lsm_drv_ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & !'rainc',rainc(i),'rainnc',rainnc(i), & 'sfcqv_ice',sfcqv_ice(i),& !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & - 'prsl1',prsl1(i),'t1',t1(i), & - !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'prsl1',prsl1(i),'t1',t1(i),'snwdph_ice ',snwdph_ice(i), & 'srflag',srflag(i),'weasd_ice',weasd_ice(i), & 'tsurf_ice',tsurf_ice(i),'tslb(i,1)',tslb(i,1) endif endif - 101 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 101 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) + + edir (i,j) = 0.0 + ec (i,j) = 0.0 + ett (i,j) = 0.0 sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. @@ -1310,13 +1352,13 @@ subroutine lsm_ruc_run & ! inputs sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] - soilt_ice(i,j) = tsurf_ice(i) ! clu_q2m_iter - if (tsnow_ice(i) > 0. .and. tsnow_ice(i) < 273.15) then + soilt_ice(i,j) = tsurf_ice(i) + if (tsnow_ice(i) > 150. .and. tsnow_ice(i) < 273.15) then soilt1_ice(i,j) = tsnow_ice(i) else soilt1_ice(i,j) = tsurf_ice(i) endif - tsnav_ice(i,j) = 0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15 + tsnav_ice(i,j) = min(0.,0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15) do k = 1, lsoil_ruc stsice (i,k,j) = tsice(i,k) smice (i,k,j) = 1. @@ -1328,8 +1370,9 @@ subroutine lsm_ruc_run & ! inputs wet_ice(i,j) = 1. chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance - flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (1. + 0.84*q2(i,1,j)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) + ! for output cmm_ice(i) = cm_ice (i) * wind(i) chh_ice(i) = chs_ice(i,j) * rho(i) @@ -1338,6 +1381,8 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] snfallac_ice(i,j) = snowfallac_ice(i) + acsn_ice(i,j) = acsnow_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then @@ -1358,7 +1403,7 @@ subroutine lsm_ruc_run & ! inputs znt_ice(i,j) = z0rl_ice(i)/100. !> - Call RUC LSM lsmruc() for ice. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & @@ -1366,6 +1411,7 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & @@ -1386,10 +1432,11 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smice(i,:,j), slice(i,:,j), soilm(i,j), smmax(i,j), & & stsice(i,:,j), soilt_ice(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_ice(i,j), snoh_ice(i,j), & & hfx_ice(i,j), qfx_ice(i,j), lh_ice(i,j), & & 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(i,j), snomlt_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, & & ims,ime, jms,jme, kms,kme, & @@ -1409,18 +1456,21 @@ subroutine lsm_ruc_run & ! inputs sfcqc_ice(i) = qcg_ice(i,j) snowfallac_ice(i) = snfallac_ice(i,j) ! kg m-2 + acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 + snowmt_ice(i) = snomlt_ice(i,j) ! kg m-2 ! --- ... unit conversion (from m to mm) - snwdph_ice(i) = snowh_ice(i,j) * 1000.0 - weasd_ice(i) = sneqv_ice(i,j) ! mm + snwdph_ice(i) = snowh_ice(i,j) * rhoh2o + weasd_ice(i) = sneqv_ice(i,j) ! kg m-2 sncovr1_ice(i) = sncovr_ice(i,j) - z0rl_ice(i) = znt_ice(i,j)*100. + z0rl_ice(i) = znt_ice(i,j)*100. ! cm !-- semis_ice is with snow effect semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect sfalb_ice(i) = alb_ice(i,j) + !-- albdvis_ice,albdnir_ice,albivis_ice,albinir_ice albdvis_ice(i) = sfalb_ice(i) albdnir_ice(i) = sfalb_ice(i) - albinir_ice(i) = sfalb_ice(i) + albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) @@ -1462,22 +1512,25 @@ subroutine lsm_ruc_run & ! inputs !srflag(i) = srflag_old(i) tsnow_lnd(i) = tsnow_lnd_old(i) snowfallac_lnd(i) = snowfallac_lnd_old(i) - !acsnow(i) = acsnow_old(i) + acsnow_lnd(i) = acsnow_lnd_old(i) sfcqv_lnd(i) = sfcqv_lnd_old(i) sfcqc_lnd(i) = sfcqc_lnd_old(i) wetness(i) = wetness_old(i) z0rl_lnd(i) = z0rl_lnd_old(i) sncovr1_lnd(i) = sncovr1_lnd_old(i) + snowmt_lnd(i) = snowmt_lnd_old(i) !ice weasd_ice(i) = weasd_ice_old(i) snwdph_ice(i) = snwdph_ice_old(i) tskin_ice(i) = tskin_ice_old(i) tsnow_ice(i) = tsnow_ice_old(i) snowfallac_ice(i) = snowfallac_ice_old(i) + acsnow_ice(i) = acsnow_ice_old(i) sfcqv_ice(i) = sfcqv_ice_old(i) sfcqc_ice(i) = sfcqc_ice_old(i) z0rl_ice(i) = z0rl_ice_old(i) sncovr1_ice(i) = sncovr1_ice_old(i) + snowmt_ice(i) = snowmt_ice_old(i) do k = 1, lsoil_ruc smois(i,k) = smois_old(i,k) From 5cdaeebd97eaab36a55844eb4f75319cd6aea58a Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Thu, 31 Mar 2022 22:32:48 +0000 Subject: [PATCH 10/50] Update meta file consistent with other changes. --- physics/sfc_drv_ruc.meta | 72 +++++++++++++++++++++++++++++++++++++--- 1 file changed, 68 insertions(+), 4 deletions(-) diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index b9709c4d3c..addfd940f6 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -664,6 +664,22 @@ type = real kind = kind_phys intent = in +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sigma] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [zs] standard_name = depth_of_soil_layers long_name = depth of soil levels for land surface model @@ -993,6 +1009,14 @@ type = real kind = kind_phys intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_fvirt] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) @@ -1322,13 +1346,37 @@ kind = kind_phys intent = inout [snowfallac_lnd] - standard_name = surface_snow_amount_over_land - long_name = run-total snow accumulation on the ground over land + standard_name = surface_snow_amount_vardens_over_land + long_name = run-total snow accumulation on the ground with variable snow density over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_lnd] + standard_name = surface_snow_lwe_thickness_amount_over_land + long_name = run-total snowfall water equivalent over land units = kg m-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout +[snowmt_lnd] + standard_name = surface_snow_melt_over_land + long_name = snow melt during timestep over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [albdvis_lnd] standard_name = surface_albedo_direct_visible_over_land long_name = direct surface albedo visible band over land @@ -1458,8 +1506,24 @@ kind = kind_phys intent = in [snowfallac_ice] - standard_name = surface_snow_amount_over_ice - long_name = run-total snow accumulation on the ground over ice + standard_name = surface_snow_amount_vardens_over_ice + long_name = run-total snow accumulation on the ground with variable snow density over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_ice] + standard_name = surface_snow_lwe_thickness_amount_over_ice + long_name = run-total snowfall water equivalent over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowmt_ice] + standard_name = surface_snow_melt_over_ice + long_name = snow melt during timestep over ice units = kg m-2 dimensions = (horizontal_loop_extent) type = real From 6867825a4511451755d334080f3530b2dd158d6f Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Thu, 31 Mar 2022 22:49:16 +0000 Subject: [PATCH 11/50] Transfer some variables from Interstitial to Diag in the GFS_debug.F90. Added Glacier land-use type to set_soilveg_ruc.F90 --- physics/GFS_debug.F90 | 14 ++++++++++---- physics/namelist_soilveg_ruc.F90 | 1 + physics/set_soilveg_ruc.F90 | 8 +++++--- 3 files changed, 16 insertions(+), 7 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 8e6d5e7811..183a9aff59 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -627,6 +627,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr_n ', Diag%fluxr(:,n)) !end do call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%srunoff ', Diag%srunoff) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbs ', Diag%evbs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcw ', Diag%evcw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sbsno ', Diag%sbsno) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbsa ', Diag%evbsa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcwa ', Diag%evcwa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snohfa ', Diag%snohfa) @@ -1203,8 +1206,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ice ', Interstitial%evap_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_land ', Interstitial%evap_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_water ', Interstitial%evap_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evbs ', Interstitial%evbs ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evcw ', Interstitial%evcw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ext_diag_thompson_reset', Interstitial%ext_diag_thompson_reset) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faerlw ', Interstitial%faerlw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faersw ', Interstitial%faersw ) @@ -1301,7 +1302,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_tcp ', Interstitial%save_tcp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_u ', Interstitial%save_u ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_v ', Interstitial%save_v ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sbsno ', Interstitial%sbsno ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbfc ', Interstitial%scmpsw%uvbfc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbf0 ', Interstitial%scmpsw%uvbf0 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirbm ', Interstitial%scmpsw%nirbm ) @@ -1314,6 +1314,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1326,7 +1329,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_water ', Interstitial%tprcp_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans ', Interstitial%trans ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) @@ -1340,6 +1343,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index 1e05122c41..4708fdc022 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -32,6 +32,7 @@ module namelist_soilveg_ruc REAL CFACTR_DATA REAL RSMAX_DATA INTEGER BARE + INTEGER GLACIER INTEGER NATURAL INTEGER CROP INTEGER URBAN diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index cac4fd1e79..a6d7aa08b9 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -29,7 +29,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -195,9 +195,10 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & 0., 0., 0., 0., 0., 0./) natural = 10 - bare = 16 crop = 12 urban = 13 + glacier = 15 + bare = 16 endif ! end if veg table @@ -337,7 +338,8 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) - SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & + SATPSI =(/0.121, 0.150, 0.218, 0.786, 0.786, 0.478, & + !SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & From e4f51c2eaa2ab97268cebef29852b83f19daf071 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Mon, 4 Apr 2022 21:26:13 +0000 Subject: [PATCH 12/50] Fixed units for snow accumulation with variable density. --- physics/module_sf_ruclsm.F90 | 6 +++--- physics/sfc_drv_ruc.F90 | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 2a55561232..45328e3949 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -147,7 +147,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! ACRUNOFF - run-total surface runoff [mm] ! SFCEVP - total time-step evaporation in [kg/m^2] ! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! SNOWFALLAC - run-total snowfall accumulation [m] +! SNOWFALLAC - run-total snowfall accumulation [mm] ! ACSNOW - run-toral SWE of snowfall [mm] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). !-- used only in MYJPBL. @@ -2232,9 +2232,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) -! run-total accumulated snow based on snowfall and snowmelt in [m] +! run-total accumulated snow based on snowfall and snowmelt in [mm] - snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) + snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))*1.e3 ELSE !--- no snow diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 63f829407a..fee72523fd 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -1382,7 +1382,7 @@ subroutine lsm_ruc_run & ! inputs sneqv_ice(i,j) = weasd_ice(i) ! [mm] snfallac_ice(i,j) = snowfallac_ice(i) acsn_ice(i,j) = acsnow_ice(i) - snomlt_ice(i,j) = snowmt_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then From 293c71fcb428151a3c0fcfddfeb450230eeb8db6 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Mon, 4 Apr 2022 22:40:08 +0000 Subject: [PATCH 13/50] Added output of density of frozen precipitation over ice. --- physics/sfc_drv_ruc.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index fee72523fd..e9d198bba9 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -1222,6 +1222,7 @@ subroutine lsm_ruc_run & ! inputs !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom !!\n \a snoh - phase-change heat flux from snowmelt (\f$W m^{-2}\f$) ! +! --- ... units [m/s] = [g m-2 s-1] ! evcw (W m-2) - canopy water evaporation flux ! evbs (W m-2) - direct soil evaporation flux ! trans (W m-2) - total plant transpiration @@ -1261,11 +1262,10 @@ subroutine lsm_ruc_run & ! inputs drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 wetness(i) = wet(i,j) - sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) - ! --- ... units [m/s] = [g m-2 s-1] - rhosnf(i) = rhosnfr(i,j) + + rhosnf(i) = rhosnfr(i,j) ! kg m-3 acsnow_lnd(i) = acsn_lnd(i,j) ! accum kg m-2 snowmt_lnd(i) = snomlt_lnd(i,j) ! accum kg m-2 @@ -1455,6 +1455,7 @@ subroutine lsm_ruc_run & ! inputs sfcqv_ice(i) = qvg_ice(i,j) sfcqc_ice(i) = qcg_ice(i,j) + rhosnf(i) = rhosnfr(i,j) ! kg m-3 snowfallac_ice(i) = snfallac_ice(i,j) ! kg m-2 acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 snowmt_ice(i) = snomlt_ice(i,j) ! kg m-2 From 53a4613d47cda776423b686db7ab247ee324070c Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Fri, 8 Apr 2022 21:14:14 +0000 Subject: [PATCH 14/50] From communication with Greg, multiply R1 by 1000. to compute graupel, snow and rain reaching the groundd. --- physics/module_mp_thompson.F90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 042e014f63..d36fd2090d 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -3934,7 +3934,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo - if (rr(kts).gt.R1*10.) & + !if (rr(kts).gt.R1*10.) & + if (rr(kts).gt.R1*1000.) & pptrain = pptrain + sed_r(kts)*DT*onstep(1) enddo else !if(.not. sedi_semi) @@ -4025,7 +4026,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo - if (ri(kts).gt.R1*10.) & + !if (ri(kts).gt.R1*10.) & + if (ri(kts).gt.R1*1000.) & pptice = pptice + sed_i(kts)*DT*onstep(2) enddo endif @@ -4052,7 +4054,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo - if (rs(kts).gt.R1*10.) & + !if (rs(kts).gt.R1*10.) & + !-- 8apr22 communication with Greg + if (rs(kts).gt.R1*1000.) & pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) enddo endif @@ -4080,7 +4084,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo - if (rg(kts).gt.R1*10.) & + !if (rg(kts).gt.R1*10.) & + !-- 8apr22 - communication with Greg + if (rg(kts).gt.R1*1000.) & pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) enddo else ! if(.not. sedi_semi) then From 4b8f341df2cb2890e4724c0a97d6ec3ea9e7d317 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 20 Apr 2022 19:42:55 +0000 Subject: [PATCH 15/50] Removed special treatment of 2-m diagnostics for stable regime per Joe Olson's request. --- physics/sfc_diag.f | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index ce1d43549e..c1ce94d1f3 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -124,37 +124,37 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & endif else !-- RUC lsm - if(chs.lt.1.E-5) then + !if(chs.lt.1.E-5) then !-- under very stable conditions use first level temperature - t2m(i) = t1(i) - else + ! t2m(i) = t1(i) + !else t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + !endif - if(cqs.lt.1.E-5) then - q2m(i)=max(qmin,q1c) ! spec. humidity - else + !if(cqs.lt.1.E-5) then + ! q2m(i)=max(qmin,q1c) ! spec. humidity + !else q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi - endif + !endif endif ! RUC lsm else !-- flux method - if(chs2(i).lt.1.E-5) then + !if(chs2(i).lt.1.E-5) then !-- under very stable conditions use first level temperature - t2m(i) = t1(i) - else + ! t2m(i) = t1(i) + !else th2m = tskin(i)*thcon - shflx(i)/chs2(i) t2m(i) = th2m/thcon - endif + !endif - if(cqs2(i).lt.1.E-5) then + !if(cqs2(i).lt.1.E-5) then !-- under very stable conditions use first level for 2-m mixing ratio - q2m(i)=max(qmin,q1c) ! spec. humidity - else + ! q2m(i)=max(qmin,q1c) ! spec. humidity + !else x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio q2m(i) = x2m/(1. + x2m) ! spec. humidity - endif + !endif !-- Alternative logarithmic diagnostics: dT = t1(i) - tskin(i) From 5411aaf804acdf604d15b939409860d5a66cece3 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Tue, 10 May 2022 18:53:13 +0000 Subject: [PATCH 16/50] Comment modification in sfc_dial.f. Zero out snowfallacc_lnd/ice at the beginning of the free forecast. --- physics/sfc_diag.f | 3 ++- physics/sfc_drv_ruc.F90 | 12 ++++++++++-- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index c1ce94d1f3..28c946468c 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -188,9 +188,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & !q2m(i) = Q2_alt endif ! flux method - !-- check that T2m,Q2m values lie in the range between tskin and t1 + !-- check that T2m values lie in the range between tskin and t1 x2m = max(min(tskin(i),t1(i)) , t2m(i)) t2m(i) = min(max(tskin(i),t1(i)) , x2m) + !-- check that Q2m values lie in the range between qsurf and q1 x2m = max(min(qsurf(i),q1c) , q2m(i)) q2m(i) = min(max(qsurf(i),q1c) , x2m) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index e9d198bba9..d3a88b054f 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -1041,7 +1041,11 @@ subroutine lsm_ruc_run & ! inputs sneqv_lnd(i,j) = weasd_lnd(i) snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - snfallac_lnd(i,j) = snowfallac_lnd(i) + if(kdt == 1) then + snfallac_lnd(i,j) = 0. + else + snfallac_lnd(i,j) = snowfallac_lnd(i) + endif !> -- sanity checks on sneqv and snowh if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then @@ -1380,7 +1384,11 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] - snfallac_ice(i,j) = snowfallac_ice(i) + if(kdt == 1) then + snfallac_ice(i,j) = 0. + else + snfallac_ice(i,j) = snowfallac_ice(i) + endif acsn_ice(i,j) = acsnow_ice(i) snomlt_ice(i,j) = snowmt_ice(i) From d6058acdec03d7fbee8b3cf60499df9232b146b2 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Tue, 10 May 2022 22:08:39 +0000 Subject: [PATCH 17/50] Commented out zeroing out SNOWFALLACC when it is a restart. --- physics/module_sf_ruclsm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 45328e3949..1c930a24eb 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -533,7 +533,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SMELT(i,j) = 0. SNOM (i,j) = 0. ACSNOW(i,j) = 0. - SNOWFALLAC(i,j) = 0. + !SNOWFALLAC(i,j) = 0. PRECIPFR(i,j) = 0. RHOSNF(i,j) = -1.e3 ! non-zero flag SNFLX(i,j) = 0. From 5ddaac96b293f1e4e6e107400ddbc5b9a748e408 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Wed, 11 May 2022 18:45:52 +0000 Subject: [PATCH 18/50] Final changes needed to pass the regression tests for Restgarts. Removed zeroing out the state variables at the beginning of the forecast. --- physics/module_sf_ruclsm.F90 | 16 ++++++---------- physics/sfc_drv_ruc.F90 | 21 +++++++++++++-------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 1c930a24eb..ccee79faf9 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -526,14 +526,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & soiliqw(k)=0. enddo - else + !else !-- restart DO J=jts,jte DO i=its,ite SMELT(i,j) = 0. - SNOM (i,j) = 0. - ACSNOW(i,j) = 0. - !SNOWFALLAC(i,j) = 0. PRECIPFR(i,j) = 0. RHOSNF(i,j) = -1.e3 ! non-zero flag SNFLX(i,j) = 0. @@ -544,7 +541,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & RUNOFF2(i,j) = 0. SFCRUNOFF(i,j) = 0. UDRUNOFF(i,j) = 0. - ACRUNOFF(i,j) = 0. emissl (i,j) = 0. budget(i,j) = 0. acbudget(i,j) = 0. @@ -566,11 +562,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDDO ENDDO - infiltrp = 0. - do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. - enddo + ! infiltrp = 0. + ! do k=1,nsl + ! soilice(k)=0. + ! soiliqw(k)=0. + ! enddo endif ! cold start endif ! init==.true. diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index d3a88b054f..9e24f27982 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -671,29 +671,29 @@ subroutine lsm_ruc_run & ! inputs canopy_old(i) = canopy(i) !srflag_old(i) = srflag(i) ! for land - acsnow_lnd_old(i) = acsnow_lnd(i) weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) tskin_lnd_old(i) = tskin_lnd(i) tsnow_lnd_old(i) = tsnow_lnd(i) - snowfallac_lnd_old(i) = snowfallac_lnd(i) sfcqv_lnd_old(i) = sfcqv_lnd(i) sfcqc_lnd_old(i) = sfcqc_lnd(i) z0rl_lnd_old(i) = z0rl_lnd(i) sncovr1_lnd_old(i) = sncovr1_lnd(i) snowmt_lnd_old(i) = snowmt_lnd(i) + acsnow_lnd_old(i) = acsnow_lnd(i) + snowfallac_lnd_old(i) = snowfallac_lnd(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) tskin_ice_old(i) = tskin_ice(i) tsnow_ice_old(i) = tsnow_ice(i) - acsnow_ice_old(i) = acsnow_ice(i) - snowfallac_ice_old(i) = snowfallac_ice(i) sfcqv_ice_old(i) = sfcqv_ice(i) sfcqc_ice_old(i) = sfcqc_ice(i) z0rl_ice_old(i) = z0rl_ice(i) sncovr1_ice_old(i) = sncovr1_ice(i) snowmt_ice_old(i) = snowmt_ice(i) + acsnow_ice_old(i) = acsnow_ice(i) + snowfallac_ice_old(i) = snowfallac_ice(i) do k = 1, lsoil_ruc smois_old(i,k) = smois(i,k) @@ -860,8 +860,6 @@ subroutine lsm_ruc_run & ! inputs rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip [mm] graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) - acsn_lnd(i,j) = acsnow_lnd(i) - snomlt_lnd(i,j) = snowmt_lnd(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & @@ -1043,8 +1041,13 @@ subroutine lsm_ruc_run & ! inputs if(kdt == 1) then snfallac_lnd(i,j) = 0. + acsn_lnd(i,j) = 0. + snomlt_lnd(i,j) = 0. else + !-- run-total accumulation snfallac_lnd(i,j) = snowfallac_lnd(i) + acsn_lnd(i,j) = acsnow_lnd(i) + snomlt_lnd(i,j) = snowmt_lnd(i) endif !> -- sanity checks on sneqv and snowh @@ -1386,11 +1389,13 @@ subroutine lsm_ruc_run & ! inputs sneqv_ice(i,j) = weasd_ice(i) ! [mm] if(kdt == 1) then snfallac_ice(i,j) = 0. + acsn_ice(i,j) = 0. + snomlt_ice(i,j) = 0. else snfallac_ice(i,j) = snowfallac_ice(i) + acsn_ice(i,j) = acsnow_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) endif - acsn_ice(i,j) = acsnow_ice(i) - snomlt_ice(i,j) = snowmt_ice(i) !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then From 10d0caf503fa85758dc60c2ad309c09934c036fe Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Mon, 16 May 2022 22:52:21 +0000 Subject: [PATCH 19/50] Added namelist parameters: diag_flux and diag_log, to control 2-m diagnostics --- physics/sfc_diag.f | 73 ++++++++++++++++++++++--------------------- physics/sfc_diag.meta | 21 ++++++++----- 2 files changed, 51 insertions(+), 43 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index c1ce94d1f3..77484563a9 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -21,11 +21,11 @@ end subroutine sfc_diag_finalize !! \section general General Algorithm !! \section detailed Detailed Algorithm !! @{ - subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & + subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & & wet,shflx,chs2,cqs2,cdq,wind, & - & zf,ps,u1,v1,t1,q1,prslki,evap, & - & fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & + & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & + & fh2,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! @@ -34,8 +34,9 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & implicit none ! integer, intent(in) :: im, lsm, lsm_ruc - logical, intent(in) :: do_mynnsfclay logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. + logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics + logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp real(kind=kind_phys), dimension(:), intent( in) :: & & zf, ps, u1, v1, t1, q1, tskin, wet, & @@ -48,7 +49,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & ! ! locals ! - logical :: flux, debug_print + logical :: debug_print real(kind=kind_phys), parameter :: qmin=1.0e-8 real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 @@ -80,9 +81,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & ! ps is in pascals ! !! - flux = .false. - if (do_mynnsfclay .and. lsm == lsm_ruc) flux = .true. do i = 1, im f10m(i) = fm10(i) / fm(i) @@ -107,7 +106,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & cqs = chs qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - if(.not. flux) then + if(.not. diag_flux) then !-- original method if(lsm /= lsm_ruc) then if(thsfc_loc) then ! Use local potential temperature @@ -156,36 +155,38 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & q2m(i) = x2m/(1. + x2m) ! spec. humidity !endif + if(diagLog) then !-- Alternative logarithmic diagnostics: - dT = t1(i) - tskin(i) - dQ = qv1 - qsfcmr - dz1= zf(i) ! level of atm. forcing - IF (dT > 0.) THEN - ff = MIN(MAX(1.-dT/10.,0.01), 1.0) - !for now, set zt = 0.05 - fac = LOG((2. + .05)/(0.05 + ff))/ & - & LOG((dz1 + .05)/(0.05 + ff)) - T2_alt = tskin(i) + fac * dT - ELSE - !no alternatives (yet) for unstable conditions - T2_alt = t2m(i) - ENDIF - - IF (dQ > 0.) THEN - ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) - !-- for now, set zt = 0.05 - fac = LOG((2. + .05)/(0.05 + ff))/ & + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > 0.) THEN + ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + !for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & & LOG((dz1 + .05)/(0.05 + ff)) - Q2_alt = qsfcmr + fac * dQ ! mix. ratio - Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity - ELSE + T2_alt = tskin(i) + fac * dT + ELSE !no alternatives (yet) for unstable conditions - Q2_alt = q2m(i) - ENDIF - !-- Note: use of alternative diagnostics will make - ! it cooler and drier with stable stratification - !t2m(i) = T2_alt - !q2m(i) = Q2_alt + T2_alt = t2m(i) + ENDIF + + IF (dQ > 0.) THEN + ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + !-- for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + ELSE + !no alternatives (yet) for unstable conditions + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + t2m(i) = T2_alt + q2m(i) = Q2_alt + endif ! log method for stable regime endif ! flux method !-- check that T2m,Q2m values lie in the range between tskin and t1 @@ -210,7 +211,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d,do_mynnsfclay, & !-- diagnostics for a test point with known lat/lon if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & & abs(xlon_d(i)-testptlon).lt.0.2)then - print 100,'(ruc_lsm_diag) i=',i, & + print 100,'(ruc_lsm_diag) i=',i, & & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 8c3275332a..91a5c8d416 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -30,13 +30,6 @@ type = real kind = kind_phys intent = in -[do_mynnsfclay] - standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme - long_name = flag to activate MYNN surface layer - units = flag - dimensions = () - type = logical - intent = in [lsm] standard_name = control_for_land_surface_scheme long_name = flag for land surface model @@ -218,6 +211,20 @@ dimensions = () type = logical intent = in +[diag_flux] + standard_name = flag_for_flux_method_in_2m_diagnostics + long_name = flag for flux method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[diag_log] + standard_name = flag_for_log_method_in_2m_diagnostics + long_name = flag for log method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in [shflx] standard_name = surface_upward_temperature_flux long_name = kinematic surface upward sensible heat flux From dc34afafb354cc9b73dfbf8422622ad2223d7242 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Mon, 16 May 2022 22:54:20 +0000 Subject: [PATCH 20/50] Initialize local accumulation variables to zero. --- physics/sfc_drv_ruc.F90 | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index e9d198bba9..d2e893e173 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -671,29 +671,29 @@ subroutine lsm_ruc_run & ! inputs canopy_old(i) = canopy(i) !srflag_old(i) = srflag(i) ! for land - acsnow_lnd_old(i) = acsnow_lnd(i) weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) tskin_lnd_old(i) = tskin_lnd(i) tsnow_lnd_old(i) = tsnow_lnd(i) - snowfallac_lnd_old(i) = snowfallac_lnd(i) sfcqv_lnd_old(i) = sfcqv_lnd(i) sfcqc_lnd_old(i) = sfcqc_lnd(i) z0rl_lnd_old(i) = z0rl_lnd(i) sncovr1_lnd_old(i) = sncovr1_lnd(i) snowmt_lnd_old(i) = snowmt_lnd(i) + acsnow_lnd_old(i) = acsnow_lnd(i) + snowfallac_lnd_old(i) = snowfallac_lnd(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) tskin_ice_old(i) = tskin_ice(i) tsnow_ice_old(i) = tsnow_ice(i) - acsnow_ice_old(i) = acsnow_ice(i) - snowfallac_ice_old(i) = snowfallac_ice(i) sfcqv_ice_old(i) = sfcqv_ice(i) sfcqc_ice_old(i) = sfcqc_ice(i) z0rl_ice_old(i) = z0rl_ice(i) sncovr1_ice_old(i) = sncovr1_ice(i) snowmt_ice_old(i) = snowmt_ice(i) + acsnow_ice_old(i) = acsnow_ice(i) + snowfallac_ice_old(i) = snowfallac_ice(i) do k = 1, lsoil_ruc smois_old(i,k) = smois(i,k) @@ -755,9 +755,8 @@ subroutine lsm_ruc_run & ! inputs acsn_lnd(i,j) = 0.0 snfallac_ice(i,j) = 0.0 acsn_ice(i,j) = 0.0 - rhosnfr(i,j) = 0.0 precipfr(i,j) = 0.0 - + rhosnfr(i,j) = -1.e3 endif enddo ! i=1,im enddo @@ -860,8 +859,6 @@ subroutine lsm_ruc_run & ! inputs rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip [mm] graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) - acsn_lnd(i,j) = acsnow_lnd(i) - snomlt_lnd(i,j) = snowmt_lnd(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & @@ -1041,7 +1038,16 @@ subroutine lsm_ruc_run & ! inputs sneqv_lnd(i,j) = weasd_lnd(i) snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - snfallac_lnd(i,j) = snowfallac_lnd(i) + if(kdt == 1) then + snfallac_lnd(i,j) = 0. + acsn_lnd(i,j) = 0. + snomlt_lnd(i,j) = 0. + else + !-- run-total accumulation + snfallac_lnd(i,j) = snowfallac_lnd(i) + acsn_lnd(i,j) = acsnow_lnd(i) + snomlt_lnd(i,j) = snowmt_lnd(i) + endif !> -- sanity checks on sneqv and snowh if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then @@ -1380,9 +1386,15 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] - snfallac_ice(i,j) = snowfallac_ice(i) - acsn_ice(i,j) = acsnow_ice(i) - snomlt_ice(i,j) = snowmt_ice(i) + if(kdt == 1) then + snfallac_ice(i,j) = 0. + acsn_ice(i,j) = 0. + snomlt_ice(i,j) = 0. + else + snfallac_ice(i,j) = snowfallac_ice(i) + acsn_ice(i,j) = acsnow_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) + endif !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then From c24a9ae4feefc8595e4f6090f2640caac5a0d313 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Mon, 16 May 2022 22:56:30 +0000 Subject: [PATCH 21/50] Removed initialization of accumulation arrays to zero from the restart. --- physics/module_sf_ruclsm.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 45328e3949..6dda912c47 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -531,9 +531,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO J=jts,jte DO i=its,ite SMELT(i,j) = 0. - SNOM (i,j) = 0. - ACSNOW(i,j) = 0. - SNOWFALLAC(i,j) = 0. PRECIPFR(i,j) = 0. RHOSNF(i,j) = -1.e3 ! non-zero flag SNFLX(i,j) = 0. @@ -544,7 +541,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & RUNOFF2(i,j) = 0. SFCRUNOFF(i,j) = 0. UDRUNOFF(i,j) = 0. - ACRUNOFF(i,j) = 0. emissl (i,j) = 0. budget(i,j) = 0. acbudget(i,j) = 0. From 9b39f5c18aa6a5a112a4c03e33fdf88fcd1d737a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 17 May 2022 18:25:15 +0000 Subject: [PATCH 22/50] Add github user middlecoff as a codeowner in RRFS_dev --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 4742d1f7b7..1ac1dbe7c6 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @zhanglikate +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @zhanglikate @middlecoff # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 979686860705ddc61a29b28282905b26c54497a5 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 17 May 2022 20:28:43 +0000 Subject: [PATCH 23/50] Bug introduce in the previous commit is fixed. --- physics/sfc_diag.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 4fae0bea59..e766e8e177 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -25,7 +25,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & & wet,shflx,chs2,cqs2,cdq,wind, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & - & fh2,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & + & tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! @@ -155,7 +155,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & q2m(i) = x2m/(1. + x2m) ! spec. humidity !endif - if(diagLog) then + if(diag_log) then !-- Alternative logarithmic diagnostics: dT = t1(i) - tskin(i) dQ = qv1 - qsfcmr From d40f5e2b55d1215900e46b2960e3812774ecf337 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 17 May 2022 22:16:31 +0000 Subject: [PATCH 24/50] Change to GSL CODEOWNERS --- CODEOWNERS | 131 +---------------------------------------------------- 1 file changed, 1 insertion(+), 130 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index cf7a886aa0..1ac1dbe7c6 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -1,138 +1,9 @@ -######################################################################## - -# CODEOWNERS RULES (syntax guide is at end of file) - -# Default codeowners for files that don't have specific owners: - -* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - - -# The following lines are from the CCPP Primary Schemes Points of Contact -# https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 -# (Internal NOAA document.) - -smoke/* @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_ntiedtke* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shinhongvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/ysuvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -######################################################################## - # Lines starting with '#' are comments. # Each line is a file pattern followed by one or more owners. # These owners will be the default owners for everything in the repo. #* @defunkt +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @zhanglikate @middlecoff # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From eccf83a8b8241850bb9c5a47f0d73c4629a6d0c2 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Wed, 18 May 2022 17:53:05 +0000 Subject: [PATCH 25/50] Returned the comments on soil resistance back. --- physics/module_sf_ruclsm.F90 | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 0cf820303b..01e9c1100d 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2581,6 +2581,21 @@ SUBROUTINE SOIL (debug_print, & ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif alfa=1. +! field capacity +! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation +! when soil moisture is below field capacity. [Lee and Pielke, 1992] +! This formulation agrees with obsevations when top layer is < 2 cm thick. +! Soilres = 1 for snow, glaciers and wetland. +! fc=ref - suggested in the paper +! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change +! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct +! evaporation, effects sparsely vegetated areas--> cooler during the day +! fc=max(qmin,ref*0.25) ! +! For now we'll go back to ref*0.5 +! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct +! evaporation. Therefore , it is replaced with ref*0.7. + !fc=max(qmin,ref*0.5) + !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then From f496099a9a55acdea52e23f9c2a6d5b043f5b1df Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 19 May 2022 00:19:54 +0000 Subject: [PATCH 26/50] Fix from Joe to remove code that was added back in by the big merge. --- physics/GFS_rrtmgp_cloud_mp.F90 | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 53b4d801c5..60d5a0a85f 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -179,20 +179,11 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! ! SGS clouds present, use cloud-fraction modified to include sgs clouds. ! - if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then - ! MYNN sub-grid cloud fraction. - if (do_mynnedmf) then - ! If rain/snow present, use GFDL MP cloud-fraction... - if (tracer(iCol,iLay,i_cldrain)>1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - ! GF sub-grid cloud fraction. - else - ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... - if (qci_conv(iCol,iLay) <= 0.) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - endif + if (imfdeepcnv==imfdeepcnv_gf .and. kdt>1) then + ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... + if (qci_conv(iCol,iLay) <= 0.) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif ! ! No SGS clouds, use GFDL MP cloud-fraction... ! From 1d2d97038ecf9a0f94f235e552e516183f0cc18e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 19 May 2022 20:56:48 +0000 Subject: [PATCH 27/50] move smoke to physics/smoke --- {smoke => physics/smoke}/dep_dry_gocart_mod.F90 | 0 {smoke => physics/smoke}/dep_dry_mod.F90 | 0 {smoke => physics/smoke}/dep_simple_mod.F90 | 0 {smoke => physics/smoke}/dep_vertmx_mod.F90 | 0 {smoke => physics/smoke}/dep_wet_ls_mod.F90 | 0 {smoke => physics/smoke}/dust_data_mod.F90 | 0 {smoke => physics/smoke}/dust_fengsha_mod.F90 | 0 {smoke => physics/smoke}/module_add_emiss_burn.F90 | 0 {smoke => physics/smoke}/module_plumerise1.F90 | 0 {smoke => physics/smoke}/module_smoke_plumerise.F90 | 0 {smoke => physics/smoke}/module_zero_plumegen_coms.F90 | 0 {smoke => physics/smoke}/plume_data_mod.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_config.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_data.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.meta | 0 {smoke => physics/smoke}/rrfs_smoke_postpbl.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_postpbl.meta | 0 {smoke => physics/smoke}/rrfs_smoke_wrapper.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_wrapper.meta | 0 {smoke => physics/smoke}/seas_data_mod.F90 | 0 {smoke => physics/smoke}/seas_mod.F90 | 0 {smoke => physics/smoke}/seas_ngac_mod.F90 | 0 23 files changed, 0 insertions(+), 0 deletions(-) rename {smoke => physics/smoke}/dep_dry_gocart_mod.F90 (100%) rename {smoke => physics/smoke}/dep_dry_mod.F90 (100%) rename {smoke => physics/smoke}/dep_simple_mod.F90 (100%) rename {smoke => physics/smoke}/dep_vertmx_mod.F90 (100%) rename {smoke => physics/smoke}/dep_wet_ls_mod.F90 (100%) rename {smoke => physics/smoke}/dust_data_mod.F90 (100%) rename {smoke => physics/smoke}/dust_fengsha_mod.F90 (100%) rename {smoke => physics/smoke}/module_add_emiss_burn.F90 (100%) rename {smoke => physics/smoke}/module_plumerise1.F90 (100%) rename {smoke => physics/smoke}/module_smoke_plumerise.F90 (100%) rename {smoke => physics/smoke}/module_zero_plumegen_coms.F90 (100%) rename {smoke => physics/smoke}/plume_data_mod.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_config.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_data.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.meta (100%) rename {smoke => physics/smoke}/rrfs_smoke_postpbl.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_postpbl.meta (100%) rename {smoke => physics/smoke}/rrfs_smoke_wrapper.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_wrapper.meta (100%) rename {smoke => physics/smoke}/seas_data_mod.F90 (100%) rename {smoke => physics/smoke}/seas_mod.F90 (100%) rename {smoke => physics/smoke}/seas_ngac_mod.F90 (100%) diff --git a/smoke/dep_dry_gocart_mod.F90 b/physics/smoke/dep_dry_gocart_mod.F90 similarity index 100% rename from smoke/dep_dry_gocart_mod.F90 rename to physics/smoke/dep_dry_gocart_mod.F90 diff --git a/smoke/dep_dry_mod.F90 b/physics/smoke/dep_dry_mod.F90 similarity index 100% rename from smoke/dep_dry_mod.F90 rename to physics/smoke/dep_dry_mod.F90 diff --git a/smoke/dep_simple_mod.F90 b/physics/smoke/dep_simple_mod.F90 similarity index 100% rename from smoke/dep_simple_mod.F90 rename to physics/smoke/dep_simple_mod.F90 diff --git a/smoke/dep_vertmx_mod.F90 b/physics/smoke/dep_vertmx_mod.F90 similarity index 100% rename from smoke/dep_vertmx_mod.F90 rename to physics/smoke/dep_vertmx_mod.F90 diff --git a/smoke/dep_wet_ls_mod.F90 b/physics/smoke/dep_wet_ls_mod.F90 similarity index 100% rename from smoke/dep_wet_ls_mod.F90 rename to physics/smoke/dep_wet_ls_mod.F90 diff --git a/smoke/dust_data_mod.F90 b/physics/smoke/dust_data_mod.F90 similarity index 100% rename from smoke/dust_data_mod.F90 rename to physics/smoke/dust_data_mod.F90 diff --git a/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 similarity index 100% rename from smoke/dust_fengsha_mod.F90 rename to physics/smoke/dust_fengsha_mod.F90 diff --git a/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 similarity index 100% rename from smoke/module_add_emiss_burn.F90 rename to physics/smoke/module_add_emiss_burn.F90 diff --git a/smoke/module_plumerise1.F90 b/physics/smoke/module_plumerise1.F90 similarity index 100% rename from smoke/module_plumerise1.F90 rename to physics/smoke/module_plumerise1.F90 diff --git a/smoke/module_smoke_plumerise.F90 b/physics/smoke/module_smoke_plumerise.F90 similarity index 100% rename from smoke/module_smoke_plumerise.F90 rename to physics/smoke/module_smoke_plumerise.F90 diff --git a/smoke/module_zero_plumegen_coms.F90 b/physics/smoke/module_zero_plumegen_coms.F90 similarity index 100% rename from smoke/module_zero_plumegen_coms.F90 rename to physics/smoke/module_zero_plumegen_coms.F90 diff --git a/smoke/plume_data_mod.F90 b/physics/smoke/plume_data_mod.F90 similarity index 100% rename from smoke/plume_data_mod.F90 rename to physics/smoke/plume_data_mod.F90 diff --git a/smoke/rrfs_smoke_config.F90 b/physics/smoke/rrfs_smoke_config.F90 similarity index 100% rename from smoke/rrfs_smoke_config.F90 rename to physics/smoke/rrfs_smoke_config.F90 diff --git a/smoke/rrfs_smoke_data.F90 b/physics/smoke/rrfs_smoke_data.F90 similarity index 100% rename from smoke/rrfs_smoke_data.F90 rename to physics/smoke/rrfs_smoke_data.F90 diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 similarity index 100% rename from smoke/rrfs_smoke_lsdep_wrapper.F90 rename to physics/smoke/rrfs_smoke_lsdep_wrapper.F90 diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta similarity index 100% rename from smoke/rrfs_smoke_lsdep_wrapper.meta rename to physics/smoke/rrfs_smoke_lsdep_wrapper.meta diff --git a/smoke/rrfs_smoke_postpbl.F90 b/physics/smoke/rrfs_smoke_postpbl.F90 similarity index 100% rename from smoke/rrfs_smoke_postpbl.F90 rename to physics/smoke/rrfs_smoke_postpbl.F90 diff --git a/smoke/rrfs_smoke_postpbl.meta b/physics/smoke/rrfs_smoke_postpbl.meta similarity index 100% rename from smoke/rrfs_smoke_postpbl.meta rename to physics/smoke/rrfs_smoke_postpbl.meta diff --git a/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 similarity index 100% rename from smoke/rrfs_smoke_wrapper.F90 rename to physics/smoke/rrfs_smoke_wrapper.F90 diff --git a/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta similarity index 100% rename from smoke/rrfs_smoke_wrapper.meta rename to physics/smoke/rrfs_smoke_wrapper.meta diff --git a/smoke/seas_data_mod.F90 b/physics/smoke/seas_data_mod.F90 similarity index 100% rename from smoke/seas_data_mod.F90 rename to physics/smoke/seas_data_mod.F90 diff --git a/smoke/seas_mod.F90 b/physics/smoke/seas_mod.F90 similarity index 100% rename from smoke/seas_mod.F90 rename to physics/smoke/seas_mod.F90 diff --git a/smoke/seas_ngac_mod.F90 b/physics/smoke/seas_ngac_mod.F90 similarity index 100% rename from smoke/seas_ngac_mod.F90 rename to physics/smoke/seas_ngac_mod.F90 From 7ed3fe4da34a0c0bf076d2859c80e5ee88c675c2 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 23 May 2022 22:18:58 +0000 Subject: [PATCH 28/50] Initialization change for the restart. --- physics/module_sf_ruclsm.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index ccee79faf9..6dda912c47 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -526,7 +526,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & soiliqw(k)=0. enddo - !else + else !-- restart DO J=jts,jte DO i=its,ite @@ -562,11 +562,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDDO ENDDO - ! infiltrp = 0. - ! do k=1,nsl - ! soilice(k)=0. - ! soiliqw(k)=0. - ! enddo + infiltrp = 0. + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo endif ! cold start endif ! init==.true. From 42184e7d30cef3553508e147a4b9017c41454c1f Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Thu, 9 Jun 2022 19:14:22 +0000 Subject: [PATCH 29/50] bugfix for converting abs temp to theta --- physics/module_sf_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 98e894155c..0d81e145ae 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -848,7 +848,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - TH1D(I)=T1D(I)**(100000./P1D(I))**ROVCP !(Theta, K) + TH1D(I)=T1D(I)*(100000./P1D(I))**ROVCP !(Theta, K) TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO From 600991e94d80e02f826068fb733b8dca3835f59b Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 15 Jun 2022 14:42:51 +0000 Subject: [PATCH 30/50] changes to get this to compile --- physics/lsm_ruc.F90 | 4 ++-- physics/mynnedmf_wrapper.F90 | 16 ++-------------- 2 files changed, 4 insertions(+), 16 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index dd3bf19eff..d206308cb7 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -324,8 +324,8 @@ subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & imp_physics_nssl, & - & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& - & t1, q1, qc, stype, vtype, sigmaf, laixy, & + & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, & + & oro, sigma, zs, t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & & rainnc, rainc, ice, snow, graupel, prsl1, zf, & & wind, shdmin, shdmax, & diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 98909be2db..5917145fe9 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -183,11 +183,8 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: mix_chem, fire_turb - !integer, intent(in) :: nchem, ndvel, kdvel - !for testing only: - logical, parameter :: mix_chem=.false., fire_turb=.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1 + integer, intent(in) :: nchem, ndvel + integer, parameter :: kdvel=1 ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -364,15 +361,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (mix_chem) then - allocate ( chem3d(im,levs,nchem) ) - do k=1,levs - do i=1,im - chem3d(i,k,1)=qgrs_smoke_conc(i,k) - chem3d(i,k,2)=qgrs_dust_conc (i,k) - enddo - enddo - endif ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) From fd991180a32ba51076fbe196f5630d3bddb5b3fd Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 21 Jun 2022 12:07:29 +0000 Subject: [PATCH 31/50] Remove unneeded code --- physics/module_sf_mynn.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 6a9bb909fb..0d81e145ae 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -111,10 +111,6 @@ MODULE module_sf_mynn INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute - ! these in FV3. They will be written over anyway. - ! Computing the fluxes here is leftover from the WRF world. REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab From 3c6cb33d998c12f00c56279bcd4ec85127c96745 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 2 Sep 2022 16:44:46 +0000 Subject: [PATCH 32/50] "update smoke/dust and ddvel as input to MYNN" --- physics/module_bl_mynn.F90 | 46 +- physics/mynnedmf_wrapper.F90 | 15 +- physics/mynnedmf_wrapper.meta | 21 +- physics/smoke/dep_dry_gocart_mod.F90 | 302 -------- physics/smoke/dep_dry_mod.F90 | 294 +------- physics/smoke/dep_simple_mod.F90 | 766 -------------------- physics/smoke/dep_vertmx_mod.F90 | 212 ------ physics/smoke/dep_wet_ls_mod.F90 | 562 -------------- physics/smoke/dust_data_mod.F90 | 5 +- physics/smoke/dust_fengsha_mod.F90 | 564 +++++++------- physics/smoke/module_add_emiss_burn.F90 | 16 +- physics/smoke/module_plumerise1.F90 | 13 +- physics/smoke/module_smoke_plumerise.F90 | 5 +- physics/smoke/module_wetdep_ls.F90 | 79 ++ physics/smoke/rrfs_smoke_config.F90 | 38 +- physics/smoke/rrfs_smoke_data.F90 | 651 ----------------- physics/smoke/rrfs_smoke_lsdep_wrapper.F90 | 98 +-- physics/smoke/rrfs_smoke_lsdep_wrapper.meta | 32 +- physics/smoke/rrfs_smoke_postpbl.F90 | 17 +- physics/smoke/rrfs_smoke_postpbl.meta | 13 +- physics/smoke/rrfs_smoke_wrapper.F90 | 174 ++--- physics/smoke/rrfs_smoke_wrapper.meta | 55 +- physics/smoke/seas_mod.F90 | 3 - 23 files changed, 687 insertions(+), 3294 deletions(-) delete mode 100755 physics/smoke/dep_dry_gocart_mod.F90 delete mode 100755 physics/smoke/dep_simple_mod.F90 delete mode 100755 physics/smoke/dep_vertmx_mod.F90 delete mode 100755 physics/smoke/dep_wet_ls_mod.F90 create mode 100755 physics/smoke/module_wetdep_ls.F90 delete mode 100755 physics/smoke/rrfs_smoke_data.F90 mode change 100644 => 100755 physics/smoke/rrfs_smoke_lsdep_wrapper.F90 diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 8ffd8040cd..9c44ded7a5 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -395,9 +395,9 @@ SUBROUTINE mynn_bl_driver( & &sh3d,sm3d, & &nchem,kdvel,ndvel, & !Smoke/Chem variables - &chem3d, vdep, & + &chem3d,vdep,smoke_dbg, & &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables + &mix_chem,enh_mix,rrfs_sd, & ! end smoke/chem variables &Tsq,Qsq,Cov, & &RUBLTEN,RVBLTEN,RTHBLTEN, & @@ -458,7 +458,7 @@ SUBROUTINE mynn_bl_driver( & LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE - LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke + LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & @@ -1052,9 +1052,9 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF ( rrfs_smoke .and. mix_chem ) then + IF ( rrfs_sd .and. mix_chem ) then do ic = 1,ndvel - vd1(ic) = vdep(i,ic) !is this correct???? + vd1(ic) = vdep(i,ic) ! dry deposition veolocity chem1(kts,ic) = chem3d(i,kts,ic) s_awchem1(kts,ic)=0. enddo @@ -1066,7 +1066,7 @@ SUBROUTINE mynn_bl_driver( & enddo ELSE do ic = 1,ndvel - vd1(ic) = 0. !is this correct??? (ite) or (ndvel) + vd1(ic) = 0. ! dry deposition veolocity chem1(kts,ic) = 0. s_awchem1(kts,ic)=0. enddo @@ -1349,7 +1349,7 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( rrfs_smoke .and. mix_chem ) THEN + IF ( rrfs_sd .and. mix_chem ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1360,11 +1360,11 @@ SUBROUTINE mynn_bl_driver( & &s_aw1,s_awchem1, & &emis_ant_no(i), & &frp(i), & - &fire_turb ) + &enh_mix, smoke_dbg ) DO ic = 1,nchem DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) + chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) ENDDO ENDDO ENDIF @@ -5252,7 +5252,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & dfh, & s_aw, s_awchem, & emis_ant_no,frp, & - fire_turb ) + enh_mix, smoke_dbg ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i @@ -5266,11 +5266,11 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 REAL, INTENT(IN) :: emis_ant_no,frp,pblh - LOGICAL, INTENT(IN) :: fire_turb + LOGICAL, INTENT(IN) :: enh_mix,smoke_dbg !local vars REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x + REAL, DIMENSION(kts:kte) :: a,b,c,d,x REAL :: rhs,dztop REAL :: t,dzk REAL :: hght @@ -5282,8 +5282,8 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION(kts:kte) :: rhoinv REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: no_threshold = 0.1 - REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing + REAL, PARAMETER :: NO_threshold = 0.1 ! For anthropogenic sources + REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5314,15 +5314,16 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO - !Enhance diffusion over fires - IF ( fire_turb ) THEN + !Enhanced mixing over fires + IF ( enh_mix ) THEN + kmaxfire = ceiling(log(frp)) DO k=kts+1,kte-1 khdz_old = khdz(k) khdz_back = pblh * 0.15 / dz(k) !Modify based on anthropogenic emissions of NO and FRP IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN - khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / no_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 + IF ( emis_ant_no > NO_threshold ) THEN + khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF IF ( frp > frp_threshold ) THEN @@ -5344,7 +5345,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources - & + dtz(k) * -vd1(ic)*chem1(1,ic) & + & - dtz(k)*vd1(ic)*chem1(k,ic) & & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 @@ -5361,11 +5362,14 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & c(kte)=0. d(kte)=chem1(kte,ic) - !CALL tridiag(kte,a,b,c,d) CALL tridiag3(kte,a,b,c,d,x) + IF ( smoke_dbg ) THEN + print*,'aerosol mixing ic,chem1,chem2(k,ic)',ic,(chem1(kts:kts+10,ic)),(x(kts:kts+10)) + print*,'aerosol PBL mixing ic,vd1(ic)',ic,vd1(ic) + END IF + DO k=kts,kte - !chem_new(k,ic)=d(k) chem1(k,ic)=x(k) ENDDO ENDDO diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 5917145fe9..b669611ebc 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -161,7 +161,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & + & rrfs_sd, chem3d, frp, mix_chem, enh_mix, & + & nchem, ndvel, vdep, smoke_dbg, & & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) @@ -185,6 +186,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem integer, intent(in) :: nchem, ndvel integer, parameter :: kdvel=1 + logical, intent(in) :: smoke_dbg ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -290,10 +292,10 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem arrays real(kind_phys), dimension(:), intent(inout) :: frp - logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke + logical, intent(in) :: mix_chem, enh_mix, rrfs_sd real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind=kind_phys), dimension(:,: ), intent(inout) :: vdep real(kind=kind_phys), dimension(im) :: emis_ant_no - real(kind=kind_phys), dimension(im,ndvel) :: vdep !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -360,7 +362,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - vdep = 0. ! hli for chem dry deposition, 0 temporarily ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) @@ -719,10 +720,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & - & Chem3d=chem3d,Vdep=vdep, & + & Chem3d=chem3d,Vdep=vdep,smoke_dbg=smoke_dbg, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & - & mix_chem=mix_chem,fire_turb=fire_turb, & - & rrfs_smoke=rrfs_smoke, & + & mix_chem=mix_chem,enh_mix=enh_mix, & + & rrfs_sd=rrfs_sd, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 33f97113f2..ed212f80dc 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1359,9 +1359,9 @@ type = real kind = kind_phys intent = inout -[rrfs_smoke] +[rrfs_sd] standard_name = do_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) + long_name = flag controlling rrfs_sd collection (default off) units = flag dimensions = () type = logical @@ -1373,7 +1373,7 @@ dimensions = () type = logical intent = in -[fire_turb] +[enh_mix] standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag @@ -1394,6 +1394,21 @@ dimensions = () type = integer intent = in +[vdep] + standard_name = dry_deposition_velocity_mynn_pbl_transport + long_name = dry deposition velocity by mynn pbl transport + units = m s-1 + dimensions = (horizontal_loop_extent,2) + type = real + kind = kind_phys + intent = in +[smoke_dbg] + standard_name = do_smoke_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/smoke/dep_dry_gocart_mod.F90 b/physics/smoke/dep_dry_gocart_mod.F90 deleted file mode 100755 index 9fb5edfd11..0000000000 --- a/physics/smoke/dep_dry_gocart_mod.F90 +++ /dev/null @@ -1,302 +0,0 @@ -!>\file dep_dry_gocart_mod.F90 -!! This file is GOCART dry deposition module to calculate the dry deposition -!! velocities of smoke and dust. - -module dep_dry_gocart_mod - - use machine , only : kind_phys - use rrfs_smoke_data - - implicit none - - private - - public :: gocart_drydep_driver - -CONTAINS - -subroutine gocart_drydep_driver(numgas, & - moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & - ivgtyp,tsk,pbl,ust,znt,g, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - num_moist,num_chem, & - its,ite, jts,jte, kts,kte,numgas - REAL(kind_phys), INTENT(IN ) :: g - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),& - INTENT(IN ) :: moist - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) ,& - INTENT(INOUT) :: chem - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) ,& - INTENT(IN ) :: dz8w, p8w,rho_phy - INTEGER, DIMENSION( ims:ime , jms:jme ) ,& - INTENT(IN ) :: ivgtyp - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) ,& - INTENT(INOUT) :: tsk, & - pbl, & - ust, & - xland,znt,hfx - -!! .. Local Scalars .. - - INTEGER :: iland, iprt, iseason, jce, jcs, & - n, nr, ipr, jpr, nvr, & - idrydep_onoff,imx,jmx,lmx - integer :: ii,jj,kk,i,j,k,nv - integer, dimension (1,1) :: ilwi - real(kind_phys), DIMENSION (5) :: tc,bems - real(kind_phys), dimension (1,1) :: z0,w10m,gwet,airden,airmas,& - delz_sfc,hflux,ts,pblz,ustar,& - ps,dvel,drydf - REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel - - do nv=1,num_chem - do j=jts,jte - do i=its,ite - ddvel(i,j,nv)=0. - enddo - enddo - enddo - imx=1 - jmx=1 - lmx=1 - do j=jts,jte - do i=its,ite - dvel(1,1)=0. - ilwi(1,1)=0 - if(xland(i,j).gt.1.5)ilwi=1 -! for aerosols, ii=1 or ii=2 - ii=1 - if(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.23)ii=1 - airden(1,1)=rho_phy(i,kts,j) - delz_sfc(1,1)=dz8w(i,kts,j) - ustar(1,1)=ust(i,j) - hflux(1,1)=hfx(i,j) - pblz(1,1)=pbl(i,j) - ps(1,1)=p8w(i,kts,j)*.01 - z0(1,1)=znt(i,j) - ts(1,1)=tsk(i,j) - - call depvel_gocart(ii,imx,jmx,lmx,& - airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & - ps, z0, dvel, drydf,g) - do nv=1,num_chem - ddvel(i,j,nv)=dvel(1,1) - enddo - enddo - enddo -end subroutine gocart_drydep_driver - - - -SUBROUTINE depvel_gocart( & - ii,imx,jmx,lmx,& - airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & - ps, z0, dvel, drydf,g0) - -! **************************************************************************** -! * * -! * Calculate dry deposition velocity. * -! * * -! * Input variables: * -! * AEROSOL(k) - Logical, T = aerosol species, F = gas species * -! * IREG(i,j) - # of landtypes in grid square * -! * ILAND(i,j,ldt) - Land type ID for element ldt =1,IREG(i,j) * -! * IUSE(i,j,ldt) - Fraction of gridbox area occupied by land type * -! * element ldt * -! * USTAR(i,j) - Friction velocity (m s-1) * -! * DELZ_SFC(i,j) - Thickness of layer above surface * -! * PBLZ(i,j) - Mixing depth (m) * -! * Z0(i,j) - Roughness height (m) * -! * * -! * Determined in this subroutine (local): * -! * OBK - Monin-Obukhov length (m): set to 1.E5 m under * -! * neutral conditions * -! * Rs(ldt) - Bulk surface resistance(s m-1) for species k to * -! * surface ldt * -! * Ra - Aerodynamic resistance. * -! * Rb - Sublayer resistance. * -! * Rs - Surface resistance. * -! * Rttl - Total deposition resistance (s m-1) for species k * -! * Rttl(k) = Ra + Rb + Rs. * -! * * -! * Returned: * -! * DVEL(i,j,k) - Deposition velocity (m s-1) of species k * -! * DRYDf(i,j,k) - Deposition frequency (s-1) of species k, * -! * = DVEL / DELZ_SFC * -! * * -! **************************************************************************** - - - IMPLICIT NONE - INTEGER, INTENT(IN) :: imx,jmx,lmx - REAL(kind_phys), INTENT(IN) :: airden(imx,jmx), delz_sfc(imx,jmx) - REAL(kind_phys), INTENT(IN) :: hflux(imx,jmx), ts(imx,jmx) - REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx), pblz(imx,jmx) - REAL(kind_phys), INTENT(IN) :: ps(imx,jmx) - INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL(kind_phys), INTENT(IN) :: z0(imx,jmx) - REAL(kind=kind_phys), INTENT(IN) :: g0 - REAL(kind_phys), INTENT(OUT) :: dvel(imx,jmx), drydf(imx,jmx) - - REAL(kind_phys) :: obk, vds, czh, rttl, frac, logmfrac, psi_h, cz, eps - REAL(kind_phys) :: vd, ra, rb, rs - INTEGER :: i, j, k, ldt, iolson, ii - CHARACTER(LEN=50) :: msg - REAL(kind_phys) :: prss, tempk, tempc, xnu, ckustr, reyno, aird, diam, xm, z - REAL(kind_phys) :: frpath, speed, dg, dw, rt - REAL(kind_phys) :: rad0, rix, gfact, gfaci, rdc, rixx, rluxx, rgsx, rclx - REAL(kind_phys) :: dtmp1, dtmp2, dtmp3, dtmp4 - REAL(kind_phys) :: biofit,vk - - psi_h=0.0 - ! executable statements - j_loop: DO j = 1,jmx - i_loop: DO i = 1,imx - vk=.4 - vd = 0.0 - ra = 0.0 - rb = 0.0 ! only required for gases (SO2) - rs = 0.0 - -! **************************************************************************** -! * Compute the the Monin-Obhukov length. * -! * The direct computation of the Monin-Obhukov length is: * -! * * -! * - Air density * Cp * T(surface air) * Ustar^3 * -! * OBK = ---------------------------------------------- * -! * vK * g * Sensible Heat flux * -! * * -! * Cp = 1000 J/kg/K = specific heat at constant pressure * -! * vK = 0.4 = von Karman's constant * -! **************************************************************************** - - IF (hflux(i,j) == 0.0) THEN - obk = 1.0E5 - ELSE - ! MINVAL(hflux), MINVAL(airden), MINVAL(ustar) =?? - obk = -airden(i,j) * 1000.0 * ts(i,j) * (ustar(i,j))**3 & - / (vk * g0 * hflux(i,j)) -! -- debug: - IF ( obk == 0.0 ) WRITE(*,211) obk, i, j -211 FORMAT(1X,'OBK=', E11.2, 1X,' i,j = ', 2I4) - - END IF - - cz = delz_sfc(i,j) / 2.0 ! center of the grid box above surface - -! **************************************************************************** -! * (1) Aerosodynamic resistance Ra and sublayer resistance Rb. * -! * * -! * The Reynolds number REYNO diagnoses whether a surface is * -! * aerodynamically rough (REYNO > 10) or smooth. Surface is * -! * rough in all cases except over water with low wind speeds. * -! * * -! * For gas species over land and ice (REYNO >= 10) and for aerosol * -! * species for all surfaces: * -! * * -! * Ra = 1./VT (VT from GEOS Kzz at L=1, m/s). * -! * * -! * The following equations are from Walcek et al, 1986: * -! * * -! * For gas species when REYNO < 10 (smooth), Ra and Rb are combined * -! * as Ra: * -! * * -! * Ra = { ln(ku* z1/Dg) - Sh } / ku* eq.(13) * -! * * -! * where z1 is the altitude at the center of the lowest model layer * -! * (CZ); * -! * Sh is a stability correction function; * -! * k is the von Karman constant (0.4, vK); * -! * u* is the friction velocity (USTAR). * -! * * -! * Sh is computed as a function of z1 and L eq ( 4) and (5)): * -! * * -! * 0 < z1/L <= 1: Sh = -5 * z1/L * -! * z1/L < 0: Sh = exp{ 0.598 + 0.39*ln(E) - 0.09(ln(E))^2 } * -! * where E = min(1,-z1/L) (Balkanski, thesis). * -! * * -! * For gas species when REYNO >= 10, * -! * * -! * Rb = 2/ku* (Dair/Dg)**(2/3) eq.(12) * -! * where Dg is the gas diffusivity, and * -! * Dair is the air diffusivity. * -! * * -! * For aerosol species, Rb is combined with surface resistance as Rs. * -! * * -! **************************************************************************** - - frac = cz / obk - IF (frac > 1.0) frac = 1.0 - IF (frac > 0.0 .AND. frac <= 1.0) THEN - psi_h = -5.0*frac - ELSE IF (frac < 0.0) THEN - eps = MIN(1.0D0, -frac) - logmfrac = LOG(eps) - psi_h = EXP( 0.598 + 0.39 * logmfrac - 0.09 * (logmfrac)**2 ) - END IF - !-------------------------------------------------------------- - ! Aerosol species, Rs here is the combination of Rb and Rs. - - ra = (LOG(cz/z0(i,j)) - psi_h) / (vk*ustar(i,j)) - - vds = 0.002*ustar(i,j) - IF (obk < 0.0) & - vds = vds * (1.0+(-300.0/obk)**0.6667) - - czh = pblz(i,j)/obk - IF (czh < -30.0) vds = 0.0009*ustar(i,j)*(-czh)**0.6667 - - ! --Set Vds to be less than VDSMAX (entry in input file divided -- - ! by 1.E4). VDSMAX is taken from Table 2 of Walcek et al. [1986]. - ! Invert to get corresponding R - if(ii.eq.1)then - rs=1.0/MIN(vds,2.0D-2) - else - rs=1.0/MIN(vds,2.0D-3) - endif - - - ! ------ Set max and min values for bulk surface resistances ------ - - rs= MAX(1.0D0, MIN(rs, 9.9990D+3)) - -! **************************************************************************** -! * * -! * Compute dry deposition velocity. * -! * * -! * IUSE is the fraction of the grid square occupied by surface ldt in * -! * units of per mil (IUSE=500 -> 50% of the grid square). Add the * -! * contribution of surface type ldt to the deposition velocity; this is * -! * a loop over all surface types in the gridbox. * -! * * -! * Total resistance = Ra + Rb + Rs. -! * * -! **************************************************************************** - - rttl = ra + rb + rs - vd = vd + 1./rttl - - ! ------ Load array DVEL ------ - dvel(i,j) = vd * 1.2 - - ! -- Set a minimum value for DVEL - ! MIN(VdSO2) = 2.0e-3 m/s over ice - ! = 3.0e-3 m/s over land - ! MIN(vd_aerosol) = 1.0e-4 m/s - - IF (dvel(i,j) < 1.0E-4) dvel(i,j) = 1.0E-4 - drydf(i,j) = dvel(i,j) / delz_sfc(i,j) - - END DO i_loop - END DO j_loop - -END SUBROUTINE depvel_gocart - -end module dep_dry_gocart_mod diff --git a/physics/smoke/dep_dry_mod.F90 b/physics/smoke/dep_dry_mod.F90 index 9520d2897b..ea7dd99639 100755 --- a/physics/smoke/dep_dry_mod.F90 +++ b/physics/smoke/dep_dry_mod.F90 @@ -4,300 +4,66 @@ module dep_dry_mod use machine , only : kind_phys - use rrfs_smoke_config, only : epsilc, GOCART_SIMPLE => CHEM_OPT_GOCART, CTRA_OPT_NONE -! use chem_tracers_mod, only : p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms, -! & -! config_flags => chem_config - use dep_dry_gocart_mod - use dep_simple_mod - use dep_vertmx_mod -! use aero_soa_vbs_mod, only : soa_vbs_depdriver implicit none - private public :: dry_dep_driver contains - subroutine dry_dep_driver(data,ktau,dtstep,julday,current_month,t_phy,p_phy, & - moist,p8w,rmol,alt,gmt,t8w,raincv, & - chem,rho_phy,dz8w,exch_h,hfx, & - ivgtyp,tsk,gsw,vegfra,pbl,ust,znt,z,z_at_w, & - xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & - anh3,ddep,dep_vel_o3,g, & - e_co,kemit,snowh,numgas, & - num_chem,num_moist, & + subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- -! USE module_model_constants -! USE module_configure -! USE module_state_description -! USE module_dep_simple -! USE module_initial_chem_namelists,only:p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms -! USE module_vertmx_wrf -! USE module_chemvars,only:epsilc -! USE module_data_sorgam -! USE module_aerosols_sorgam -! USE module_gocart_settling -! use module_dep_simple -! USE module_gocart_drydep,only: gocart_drydep_driver -! USE module_aerosols_soa_vbs, only: soa_vbs_depdriver -! USE module_mosaic_drydep, only: mosaic_drydep_driver -! USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate IMPLICIT NONE - type(smoke_data), pointer, intent(inout) :: data - INTEGER, INTENT(IN ) :: numgas, current_month, & - num_chem,num_moist, julday, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + INTEGER, INTENT(IN ) :: ndvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: & - ktau - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - - INTEGER, INTENT(IN ) :: kemit - REAL(kind_phys), DIMENSION( ims:ime, kms:kemit, jms:jme ), & - INTENT(IN ) :: & - e_co - - - - - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - alt, & - t8w, & - dz8w, & - p8w,z_at_w , & - exch_h,rho_phy,z - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(INOUT) :: & - h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT) :: & - tsk, & - gsw, & - vegfra, & - pbl, & - snowh, & - raincv, & - ust, & - hfx, & - xland, & - xlat, & - xlong, & - znt,rmol - REAL(kind_phys), DIMENSION( ims:ime, jms:jme, num_chem ), & - INTENT(OUT ) :: ddep - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT) :: & - dep_vel_o3 - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - p_phy, & - t_phy + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: ust, rmol + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: rel_hum - REAL(kind_phys), INTENT(IN ) :: & - dtstep,g,gmt + REAL(kind_phys), PARAMETER :: kpart=500. + REAL(kind_phys) :: dvpart -!--- deposition and emissions stuff -! .. Parameters .. -! .. -! .. Local Scalars .. - - REAL(kind_phys) :: cdt, factor - - INTEGER :: idrydep_onoff - -! INTEGER :: chem_conv_tr, chem_opt - -! CHARACTER (4) :: luse_typ,mminlu_loc -! .. -! .. Local Arrays .. - REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel +! +! Output array + REAL(kind_phys), DIMENSION( its:ite, jts:jte, ndvel ), INTENT(INOUT) :: ddvel -! REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy - REAL(kind_phys), DIMENSION( kts:kte ) :: dryrho_1d -! turbulent transport - real(kind_phys) :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) integer :: i,j,k,nv ! ! necessary for aerosols (module dependent) ! - REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res - REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_def - REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_zcen - -! .. ! .. Intrinsic Functions .. INTRINSIC max, min -! chem_opt = chem_opt -! chem_conv_tr = chem_conv_tr - -! ! compute dry deposition velocities = ddvel -! -! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine -! only when drydep_opt == WESELY -! the wesely_driver routine computes aer_res, and currently -! you cannot compute aerosol drydep without it !! -! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines -! -! write(6,*)'call dry dep driver' - dep_vel_o3(:,:)=0. - ddvel(:,:,:) = 0.0 - idrydep_onoff = 0 - -! drydep_select: SELECT CASE(drydep_opt) - -! CASE ( WESELY ) -! -! drydep_opt == WESELY means -! wesely for gases -! other (appropriate) routine for aerosols -! -! CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') - - IF( chem_opt /= GOCART_SIMPLE ) THEN - call wesely_driver(data,ktau,dtstep, & - current_month, & - gmt,julday,t_phy,moist,p8w,t8w,raincv, & - p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & - ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& - snowh,numgas, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - ENDIF - IF (( chem_opt == GOCART_SIMPLE ) .or. & - ( chem_opt == GOCARTRACM_KPP) .or. & - ( chem_opt == 316) .or. & - ( chem_opt == 317) .or. & -! ( chem_opt == 502) .or. & - (chem_opt == 304 )) then -! -! this does aerosol species (dust,seas, bc,oc) for gocart only -! this does aerosol species (dust,seas, bc,oc,sulf) for gocart only -!, - call gocart_drydep_driver(numgas, & - moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & - ivgtyp,tsk,pbl,ust,znt,g, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - ELSE if (chem_opt == 501 ) then -! for caesium .1cm/s -! - ddvel(:,:,:)=.001 - ELSE if (chem_opt == 108 ) then -!! call soa_vbs_depdriver (ust,t_phy, & -!! moist,p8w,rmol,znt,pbl, & -!! alt,p_phy,chem,rho_phy,dz8w, & -!! h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & -!! aer_res,ddvel(:,:,numgas+1:num_chem), & -!! num_chem-numgas, & -!! ids,ide, jds,jde, kds,kde, & -!! ims,ime, jms,jme, kms,kme, & -!! its,ite, jts,jte, kts,kte ) -! limit aerosol ddvels to <= 0.5 m/s -! drydep routines occasionally produce unrealistically-large particle -! diameter leading to unrealistically-large sedimentation velocity - ddvel(:,:,numgas+1:num_chem) = min( 0.50, ddvel(:,:,numgas+1:num_chem)) - ELSE - !Set dry deposition velocity to zero when using the - !chemistry tracer mode. - ddvel(:,:,:) = 0. - END IF - idrydep_onoff = 1 - -! -! Compute dry deposition according to NGAC -! - cdt = real(dtstep, kind=kind_phys) - do nv = 1, num_chem - do j = jts, jte - do i = its, ite - factor = 1._kind_phys - exp(-ddvel(i,j,nv)*cdt/dz8w(i,kts,j)) - ddep(i,j,nv) = max(0.0, factor * chem(i,kts,j,nv)) & !ug/m2/s - * (p8w(i,kts,j)-p8w(i,kts+1,j))/g/dtstep - end do - end do - end do - -! This will be called later from subgrd_transport_driver.F !!!!!!!! -! -! - do 100 j=jts,jte - do 100 i=its,ite - if(p_dust_1.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_dust_1) - pblst=0. -! -! -!-- start with vertical mixing -! - do k=kts,kte+1 - zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) - enddo - - if (chem_conv_tr == CTRA_OPT_NONE) then - ekmfull = 0. - else - ekmfull(kts)=0. - do k=kts+1,kte - ekmfull(k)=max(1.e-6,exch_h(i,k,j)) - enddo - ekmfull(kte+1)=0. - end if - -!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO -!!$! FORCE MIXING TO A CERTAIN DEPTH: -!!$! -!!$! --- Mix the emissions up several layers -! - do k=kts,kte - zz(k)=z(i,k,j)-z_at_w(i,kts,j) - enddo -! vertical mixing routine (including deposition) -! need to be careful here with that dumm tracer in spot 1 -! do not need lho,lho2 -! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) -! -! if(p_o3.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_o3) - do nv=1,num_chem-0 - do k=kts,kte - pblst(k)=max(epsilc,chem(i,k,j,nv)) - dryrho_1d(k) = 1./alt(i,k,j) + ddvel(:,:,:) = 0.0 + do nv = 1, ndvel + do j = jts, jte + do i = its, ite + dvpart = ust(i,j)/kpart + + IF (rmol(i,j)<0.) THEN ! UNSTABLE LAYERING CORRECTION + dvpart = dvpart*(1.+(-300.*rmol(i,j))**0.66667) + ENDIF + + IF (rel_hum(i,1,j)>0.8) THEN ! HIGH RELATIVE HUMIDITY CORRECTION + dvpart = dvpart*(1.+0.37*exp((rel_hum(i,1,j)-0.8)/0.2)) + END IF + ddvel(i,j,nv) = MIN(0.50,dvpart) ! m/s + enddo enddo + enddo - !mix_select: SELECT CASE(chem_opt) - !CASE DEFAULT - call vertmx(data,dtstep,pblst,ekmfull,dryrho_1d, & - zzfull,zz,ddvel(i,j,nv),kts,kte) - - !END SELECT mix_select - - do k=kts,kte - chem(i,k,j,nv)=max(epsilc,pblst(k)) - enddo - enddo -100 continue - -END SUBROUTINE dry_dep_driver +end subroutine dry_dep_driver end module dep_dry_mod diff --git a/physics/smoke/dep_simple_mod.F90 b/physics/smoke/dep_simple_mod.F90 deleted file mode 100755 index 37a8189b55..0000000000 --- a/physics/smoke/dep_simple_mod.F90 +++ /dev/null @@ -1,766 +0,0 @@ -!>\file dep_simple_mod.F90 -!! This file contains the Wesely dry deposition module. - -module dep_simple_mod - - use rrfs_smoke_data - use rrfs_smoke_config, GOCART_SIMPLE => CHEM_OPT_GOCART, chem_opt=>chem_opt -! use chem_tracers_mod, config_flags => chem_config - -! USE module_data_sorgam - - implicit none - -!-------------------------------------------------- -! .. Default Accessibility .. -!-------------------------------------------------- - PUBLIC - - - CONTAINS - -SUBROUTINE wesely_driver( data, ktau, dtstep, current_month, & - gmt, julday, t_phy,moist, p8w, t8w, raincv, & - p_phy, chem, rho_phy, dz8w, ddvel, aer_res_def, & - aer_res_zcen, ivgtyp, tsk, gsw, vegfra, pbl, & - rmol, ust, znt, xlat, xlong, & - z, z_at_w, snowh, numgas, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - implicit none -!-------------------------------------------------- -! Wesely dry dposition driver -!-------------------------------------------------- - -! USE module_model_constants -! USE module_wrf_control,only:num_moist,num_chem -! USE module_state_description -! USE module_initial_chem_namelists -! USE module_data_sorgam -! USE module_state_description, only: param_first_scalar - type(smoke_data), intent(inout), pointer :: data - INTEGER, INTENT(IN ) :: julday, & - numgas, current_month, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: ktau - REAL(kind_phys), INTENT(IN ) :: dtstep,gmt - -!-------------------------------------------------- -! advected moisture variables -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN ) :: & - moist -!-------------------------------------------------- -! advected chemical species -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT ) :: & - chem -!-------------------------------------------------- -! deposition velocities -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( its:ite, jts:jte, num_chem ), INTENT(INOUT ) :: & - ddvel -!-------------------------------------------------- -! input from met model -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & - t_phy, & - p_phy, & - dz8w, & - z, & - t8w, & - p8w, & - z_at_w, & - rho_phy - INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: & - ivgtyp - REAL(KIND_PHYS), DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) :: & - tsk, & - gsw, & - vegfra, & - pbl, & - rmol, & - ust, & - xlat, & - xlong, & - raincv, & - znt - REAL(KIND_PHYS), intent(inout) :: aer_res_def(its:ite,jts:jte) - REAL(KIND_PHYS), intent(inout) :: aer_res_zcen(its:ite,jts:jte) - REAL(KIND_PHYS), INTENT(IN) :: snowh(ims:ime,jms:jme) - -!-------------------------------------------------- -! .. Local Scalars -!-------------------------------------------------- - REAL(kind_phys) :: clwchem, dvfog, dvpart, pa, rad, dep_vap - REAL(KIND_PHYS) :: rhchem, ta, ustar, vegfrac, z1, zntt - INTEGER :: i, iland, iprt, iseason, j, jce, jcs, n, nr, ipr,jpr,nvr - LOGICAL :: highnh3, rainflag, vegflag, wetflag -!-------------------------------------------------- -! .. Local Arrays -!-------------------------------------------------- - REAL(KIND_PHYS) :: p(kts:kte) - REAL(KIND_PHYS) :: srfres(numgas) - REAL(KIND_PHYS) :: ddvel0d(numgas) - -!----------------------------------------------------------- -! necessary for aerosols (module dependent) -!----------------------------------------------------------- - real(kind_phys) :: rcx(numgas) - - -!----------------------------------------------------------- -! .. Intrinsic Functions -!----------------------------------------------------------- -! integer :: chem_opt - - INTRINSIC max, min - - data => get_thread_smoke_data() - -! chem_opt = chem_opt - - dep_vap = depo_fact - !print*,'hli simple chem_opt',chem_opt - -! CALL wrf_debug(15,'in dry_dep_wesely') - - if( julday < 90 .or. julday > 270 ) then - iseason = 2 -! CALL wrf_debug(15,'setting iseason to 2') - else - iseason = 1 - endif - - -tile_lat_loop : & - do j = jts,jte -tile_lon_loop : & - do i = its,ite - iprt = 0 - - iland = luse2usgs( ivgtyp(i,j) ) -!-- - - ta = tsk(i,j) - rad = gsw(i,j) - vegfrac = vegfra(i,j) - pa = .01*p_phy(i,kts,j) - clwchem = moist(i,kts,j,p_qc) - ustar = ust(i,j) - zntt = znt(i,j) - z1 = z_at_w(i,kts+1,j) - z_at_w(i,kts,j) -!----------------------------------------------------------- -! Set logical default values -!----------------------------------------------------------- - rainflag = .FALSE. - wetflag = .FALSE. - highnh3 = .FALSE. -! if(p_qr > 1) then -! if(moist(i,kts,j,p_qr) > 1.e-18 .or. raincv(i,j) > 0.) then -! rainflag = .true. -! endif -! endif - rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) - rhchem = MAX(5.,RHCHEM) - if (rhchem >= 95.) wetflag = .true. - -!----------------------------------------------------------- -!--- deposition -!----------------------------------------------------------- -! if(snowc(i,j).gt.0.)iseason=4 - CALL rc( data, rcx, ta, rad, rhchem, iland, & - iseason, numgas, wetflag, rainflag, highnh3, & - iprt, moist(i,kts,j,p_qv), p8w(i,kts,j) ) - srfres(1:numgas-2) = rcx(1:numgas-2) - srfres(numgas-1:numgas) = 0. - CALL deppart( data, rmol(i,j), ustar, rhchem, clwchem, iland, dvpart, dvfog ) - ddvel0d(1:numgas) = 0. - aer_res_def(i,j) = 0. - aer_res_zcen(i,j) = 0. - CALL landusevg( data, ddvel0d, ustar, rmol(i,j), zntt, z1, dvpart, iland, & - numgas, srfres, aer_res_def(i,j), aer_res_zcen(i,j), p_sulf ) - -!----------------------------------------------------------- -!wig: CBMZ does not have HO and HO2 last so need to copy all species -! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) -!----------------------------------------------------------- - ddvel(i,j,1:numgas) = ddvel0d(1:numgas) - end do tile_lon_loop - end do tile_lat_loop - -!----------------------------------------------------------- -! For the additional CBMZ species, assign similar RADM counter parts for -! now. Short lived species get a zero velocity since dry dep should be -! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate -!----------------------------------------------------------- -! - -!----------------------------------------------------------- -! For gocartsimple : need msa. On the other hand sulf comes from aerosol routine -!----------------------------------------------------------- - if (chem_opt == GOCART_SIMPLE ) then - do j=jts,jte - do i=its,ite - ddvel(i,j,p_msa) = ddvel(i,j,p_sulf) - ddvel(i,j,p_sulf) = 0. - ddvel(i,j,p_dms) = 0. - end do - end do - end if - -END SUBROUTINE wesely_driver - - SUBROUTINE rc( data, rcx, t, rad, rh, iland, & - iseason, numgas, wetflag, rainflag, highnh3, & - iprt, spec_hum, p_srf ) -!---------------------------------------------------------------------- -! THIS SUBROUTINE CALCULATES SURFACE RESISTENCES ACCORDING -! TO THE MODEL OF -! M. L. WESELY, -! ATMOSPHERIC ENVIRONMENT 23 (1989), 1293-1304 -! WITH SOME ADDITIONS ACCORDING TO -! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, -! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 -! WRITTEN BY WINFRIED SEIDL, APRIL 1997 -! MODYFIED BY WINFRIED SEIDL, MARCH 2000 -! FOR MM5 VERSION 3 -!---------------------------------------------------------------------- - -! USE module_state_description -! USE module_initial_chem_namelists - implicit none - type(smoke_data), pointer, intent(inout) :: data -!---------------------------------------------------------------------- -! ... dummy arguments -!---------------------------------------------------------------------- - INTEGER, intent(in) :: iland, iseason, numgas - INTEGER, intent(in) :: iprt - REAL(KIND_PHYS), intent(in) :: rad, rh - REAL(KIND_PHYS), intent(in) :: t ! surface temp (K) - REAL(KIND_PHYS), intent(in) :: p_srf ! surface pressure (Pa) - REAL(KIND_PHYS), intent(in) :: spec_hum ! surface specific humidity (kg/kg) - real(kind_phys), intent(out) :: rcx(numgas) - LOGICAL, intent(in) :: highnh3, rainflag, wetflag - -!---------------------------------------------------------------------- -! .. Local Scalars .. -!---------------------------------------------------------------------- - REAL(KIND_PHYS), parameter :: t0 = 298. - REAL(KIND_PHYS), parameter :: tmelt = 273.16 - INTEGER :: lt, n - INTEGER :: chem_opt - REAL(KIND_PHYS) :: rclx, rdc, resice, rgsx, rluo1, rluo2 - REAL(KIND_PHYS) :: rlux, rmx, rs, rsmx, rdtheta, z, wrk - REAL(KIND_PHYS) :: qs, es, ws, dewm, dv_pan, drat - REAL(KIND_PHYS) :: crs, tc - REAL(KIND_PHYS) :: rs_pan, tc_pan - LOGICAL :: has_dew -!---------------------------------------------------------------------- -! .. Local Arrays .. -!---------------------------------------------------------------------- - REAL(KIND_PHYS) :: hstary(numgas) - -!---------------------------------------------------------------------- -! .. Intrinsic Functions .. -!---------------------------------------------------------------------- - INTRINSIC exp - - chem_opt = chem_opt - - rcx(1:numgas) = 1. - - tc = t - 273.15 - rdtheta = 0. - - z = 200./(rad+0.1) - -!!! HARDWIRE VALUES FOR TESTING -! z=0.4727409 -! tc=22.76083 -! t=tc+273.15 -! rad = 412.8426 -! rainflag=.false. -! wetflag=.false. - - IF ( tc<=0. .OR. tc>=40. ) THEN - rs = 9999. - ELSE - rs = data%ri(iland,iseason)*(1+z*z)*(400./(tc*(40.-tc))) - END IF - rdc = 100.*(1. + 1000./(rad + 10.))/(1. + 1000.*rdtheta) - rluo1 = 1./(1./3000. + 3./data%rlu(iland,iseason)) - rluo2 = 1./(1./1000. + 3./data%rlu(iland,iseason)) - resice = 1000.*exp( -(tc + 4.) ) - wrk = (t0 - t)/(t0*t) - - - DO n = 1, numgas - IF( data%hstar(n) /= 0. ) then - hstary(n) = data%hstar(n)*exp( data%dhr(n)*wrk ) -!---------------------------------------------------------------------- -! SPECIAL TREATMENT FOR HNO3, HNO4, H2O2, PAA -!---------------------------------------------------------------------- - rmx = 1./(hstary(n)/3000. + 100.*data%f0(n)) - rsmx = rs*data%dratio(n) + rmx - rclx = 1./(1.e-5*hstary(n)/data%rcls(iland,iseason) & - + data%f0(n)/data%rclo(iland,iseason)) + resice - rgsx = 1./(1.e-5*hstary(n)/data%rgss(iland,iseason) & - + data%f0(n)/data%rgso(iland,iseason)) + resice - rlux = data%rlu(iland,iseason)/(1.e-5*hstary(n) + data%f0(n)) + resice - IF( wetflag ) THEN - rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo1) - END IF - IF( rainflag ) THEN - rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo2) - END IF - rcx(n) = 1./(1./rsmx + 1./rlux + 1./(rdc + rclx) + 1./(data%rac(iland,iseason) + rgsx)) - rcx(n) = max( 1.,rcx(n) ) - end IF - END DO - -!-------------------------------------------------- -! SPECIAL TREATMENT FOR OZONE -!-------------------------------------------------- -! SPECIAL TREATMENT FOR SO2 (Wesely) -! HSTARY(P_SO2)=DATA%HSTAR(P_SO2)*EXP(DATA%DHR(P_SO2)*(1./T-1./298.)) -! RMX=1./(HSTARY(P_SO2)/3000.+100.*DATA%F0(P_SO2)) -! RSMX=RS*DATA%DRATIO(P_SO2)+RMX -! RLUX=DATA%RLU(ILAND,ISEASON)/(1.E-5*HSTARY(P_SO2)+DATA%F0(P_SO2)) -! & +RESICE -! RCLX=DATA%RCLS(ILAND,ISEASON)+RESICE -! RGSX=DATA%RGSS(ILAND,ISEASON)+RESICE -! IF ((wetflag).OR.(RAINFLAG)) THEN -! IF (ILAND.EQ.1) THEN -! RLUX=50. -! ELSE -! RLUX=100. -! END IF -! END IF -! RCX(P_SO2)=1./(1./RSMX+1./RLUX+1./(RDC+RCLX) -! & +1./(DATA%RAC(ILAND,ISEASON)+RGSX)) -! IF (RCX(P_SO2).LT.1.) RCX(P_SO2)=1. - -!-------------------------------------------------- -! SO2 according to Erisman et al. 1994 -! R_STOM -!-------------------------------------------------- -is_so2 : & - if( p_so2 > 1 ) then - rsmx = rs*data%dratio(p_so2) -!-------------------------------------------------- -! R_EXT -!-------------------------------------------------- - IF (tc> -1. ) THEN - IF (rh<81.3) THEN - rlux = 25000.*exp(-0.0693*rh) - ELSE - rlux = 0.58E12*exp(-0.278*rh) - END IF - END IF - IF (((wetflag) .OR. (rainflag)) .AND. (tc> -1. )) THEN - rlux = 1. - END IF - IF ((tc>= -5. ) .AND. (tc<= -1. )) THEN - rlux = 200. - END IF - IF (tc< -5. ) THEN - rlux = 500. - END IF -!-------------------------------------------------- -! INSTEAD OF R_INC R_CL and R_DC of Wesely are used -!-------------------------------------------------- - rclx = data%rcls(iland,iseason) -!-------------------------------------------------- -! DRY SURFACE -!-------------------------------------------------- - rgsx = 1000. -!-------------------------------------------------- -! WET SURFACE -!-------------------------------------------------- - IF ((wetflag) .OR. (rainflag)) THEN - IF (highnh3) THEN - rgsx = 0. - ELSE - rgsx = 500. - END IF - END IF -!-------------------------------------------------- -! WATER -!-------------------------------------------------- - IF (iland==iswater_temp) THEN - rgsx = 0. - END IF -!-------------------------------------------------- -! SNOW -!-------------------------------------------------- - IF( iseason==4 .OR. iland==isice_temp ) THEN - IF( tc > 2. ) THEN - rgsx = 0. - else IF ( tc >= -1. .AND. tc <= 2. ) THEN - rgsx = 70.*(2. - tc) - else IF ( tc < -1. ) THEN - rgsx = 500. - END IF - END IF -!-------------------------------------------------- -! TOTAL SURFACE RESISTENCE -!-------------------------------------------------- - IF ((iseason/=4) .AND. (data%ixxxlu(iland)/=1) .AND. (iland/=iswater_temp) .AND. & - (iland/=isice_temp)) THEN - rcx(p_so2) = 1./(1./rsmx+1./rlux+1./(rclx+rdc+rgsx)) - ELSE - rcx(p_so2) = rgsx - END IF - rcx(p_so2) = max( 1.,rcx(p_so2) ) - end if is_so2 -!-------------------------------------------------- -! NH3 according to Erisman et al. 1994 -! R_STOM -!-------------------------------------------------- - END SUBROUTINE rc - - SUBROUTINE deppart( data, rmol, ustar, rh, clw, iland, & - dvpart, dvfog ) -!-------------------------------------------------- -! THIS SUBROUTINE CALCULATES SURFACE DEPOSITION VELOCITIES -! FOR FINE AEROSOL PARTICLES ACCORDING TO THE MODEL OF -! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, -! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 -! WRITTEN BY WINFRIED SEIDL, APRIL 1997 -! MODIFIED BY WINFRIED SEIDL, MARCH 2000 -! FOR MM5 VERSION 3 -!-------------------------------------------------- - implicit none - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: iland - REAL(KIND_PHYS), intent(in) :: clw, rh, rmol, ustar - REAL(KIND_PHYS), intent(out) :: dvfog, dvpart - -!-------------------------------------------------- -! .. Intrinsic Functions .. -!-------------------------------------------------- - INTRINSIC exp - - dvpart = ustar/data%kpart(iland) - IF (rmol<0.) THEN -!-------------------------------------------------- -! UNSTABLE LAYERING CORRECTION -!-------------------------------------------------- - dvpart = dvpart*(1.+(-300.*rmol)**0.66667) - END IF - IF (rh>80.) THEN -!-------------------------------------------------- -! HIGH RELATIVE HUMIDITY CORRECTION -! ACCORDING TO J. W. ERISMAN ET AL. -! ATMOSPHERIC ENVIRONMENT 31 (1997), 321-332 -!-------------------------------------------------- - dvpart = dvpart*(1.+0.37*exp((rh-80.)/20.)) - END IF - -!-------------------------------------------------- -! SEDIMENTATION VELOCITY OF FOG WATER ACCORDING TO -! R. FORKEL, W. SEIDL, R. DLUGI AND E. DEIGELE -! J. GEOPHYS. RES. 95D (1990), 18501-18515 -!-------------------------------------------------- - dvfog = 0.06*clw - IF (data%ixxxlu(iland)==5) THEN -!-------------------------------------------------- -! TURBULENT DEPOSITION OF FOG WATER IN CONIFEROUS FOREST ACCORDI -! A. T. VERMEULEN ET AL. -! ATMOSPHERIC ENVIRONMENT 31 (1997), 375-386 -!-------------------------------------------------- - dvfog = dvfog + 0.195*ustar*ustar - END IF - - END SUBROUTINE deppart - - SUBROUTINE landusevg( data, vgs, ustar, rmol, z0, zz, & - dvparx, iland, numgas, srfres, aer_res_def, & - aer_res_zcen, p_sulf ) -!-------------------------------------------------- -! This subroutine calculates the species specific deposition velocit -! as a function of the local meteorology and land use. The depositi -! Velocity is also landuse specific. -! Reference: Hsieh, C.M., Wesely, M.L. and Walcek, C.J. (1986) -! A Dry Deposition Module for Regional Acid Deposition -! EPA report under agreement DW89930060-01 -! Revised version by Darrell Winner (January 1991) -! Environmental Engineering Science 138-78 -! California Institute of Technology -! Pasadena, CA 91125 -! Modified by Winfried Seidl (August 1997) -! Fraunhofer-Institut fuer Atmosphaerische Umweltforschung -! Garmisch-Partenkirchen, D-82467 -! for use of Wesely and Erisman surface resistances -! Inputs: -! Ustar : The grid average friction velocity (m/s) -! Rmol : Reciprocal of the Monin-Obukhov length (1/m) -! Z0 : Surface roughness height for the grid square (m) -! SrfRes : Array of landuse/atmospheric/species resistances (s/m) -! Slist : Array of chemical species codes -! Dvparx : Array of surface deposition velocity of fine aerosol p -! Outputs: -! Vgs : Array of species and landuse specific deposition -! velocities (m/s) -! Vg : Cell-average deposition velocity by species (m/s) -! Variables used: -! SCPR23 : (Schmidt #/Prandtl #)**(2/3) Diffusion correction fac -! Zr : Reference Height (m) -! Iatmo : Parameter specifying the stabilty class (Function of -! Z0 : Surface roughness height (m) -! karman : Von Karman constant (from module_model_constants) -!-------------------------------------------------- - -! USE module_model_constants, only: karman - implicit none - - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: iland, numgas, p_sulf - REAL(KIND_PHYS), intent(in) :: dvparx, ustar, z0, zz - REAL(KIND_PHYS), intent(inout) :: rmol - REAL(KIND_PHYS), intent(inout) :: aer_res_def - REAL(KIND_PHYS), intent(inout) :: aer_res_zcen -!-------------------------------------------------- -! .. Array Arguments .. -!-------------------------------------------------- - REAL(KIND_PHYS), intent(in) :: srfres(numgas) - REAL(KIND_PHYS), intent(out) :: vgs(numgas) - -!-------------------------------------------------- -! .. Local Scalars .. -!-------------------------------------------------- - INTEGER :: jspec - REAL(KIND_PHYS) :: vgp, vgpart, zr - REAL(KIND_PHYS) :: rmol_tmp -!-------------------------------------------------- -! .. Local Arrays .. -!-------------------------------------------------- - REAL(KIND_PHYS) :: vgspec(numgas) - -!-------------------------------------------------- -! Calculate aerodynamic resistance for reference -! height = layer center -!-------------------------------------------------- - zr = zz*.5 - rmol_tmp = rmol - CALL depvel( data, numgas, rmol_tmp, zr, z0, ustar, & - vgspec, vgpart, aer_res_zcen ) -!-------------------------------------------------- -! Set the reference height (2.0 m) -!-------------------------------------------------- -! zr = 10.0 - zr = 2.0 - -!-------------------------------------------------- -! CALCULATE THE DEPOSITION VELOCITY without any surface -! resistance term, i.e. 1 / (ra + rb) -!-------------------------------------------------- - CALL depvel( data, numgas, rmol, zr, z0, ustar, & - vgspec, vgpart, aer_res_def ) - -!-------------------------------------------------- -! Calculate the deposition velocity for each species -! and grid cell by looping through all the possibile combinations -! of the two -!-------------------------------------------------- - vgp = 1.0/((1.0/vgpart)+(1.0/dvparx)) -!-------------------------------------------------- -! Loop through the various species -!-------------------------------------------------- - DO jspec = 1, numgas -!-------------------------------------------------- -! Add in the surface resistance term, rc (SrfRes) -!-------------------------------------------------- - vgs(jspec) = 1.0/(1.0/vgspec(jspec) + srfres(jspec)) - END DO - vgs(p_sulf) = vgp - - CALL cellvg( data, vgs, ustar, zz, zr, rmol, numgas ) - - END SUBROUTINE landusevg - - SUBROUTINE cellvg( data, vgtemp, ustar, dz, zr, rmol, nspec ) -!-------------------------------------------------- -! THIS PROGRAM HAS BEEN DESIGNED TO CALCULATE THE CELL AVERAGE -! DEPOSITION VELOCITY GIVEN THE VALUE OF VG AT SOME REFERENCE -! HEIGHT ZR WHICH IS MUCH SMALLER THAN THE CELL HEIGHT DZ. -! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) -! Modified by Darrell A. Winner (February 1991) -!.....PROGRAM VARIABLES... -! VgTemp - DEPOSITION VELOCITY AT THE REFERENCE HEIGHT -! USTAR - FRICTION VELOCITY -! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH -! ZR - REFERENCE HEIGHT -! DZ - CELL HEIGHT -! CELLVG - CELL AVERAGE DEPOSITION VELOCITY -! VK - VON KARMAN CONSTANT -!-------------------------------------------------- - -! USE module_model_constants, only: karman - implicit none - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: nspec - REAL(KIND_PHYS), intent(in) :: dz, rmol, ustar, zr -!-------------------------------------------------- -! .. Array Arguments .. -!-------------------------------------------------- - REAL(KIND_PHYS), intent(out) :: vgtemp(nspec) -!-------------------------------------------------- -! .. Local Scalars .. -!-------------------------------------------------- - INTEGER :: nss - REAL(KIND_PHYS) :: a, fac, pdz, pzr, vk -!-------------------------------------------------- -! .. Intrinsic Functions .. -!-------------------------------------------------- - INTRINSIC alog, sqrt - -!-------------------------------------------------- -! Set the von Karman constant -!-------------------------------------------------- - vk = karman - -!-------------------------------------------------- -! DETERMINE THE STABILITY BASED ON THE CONDITIONS -! 1/L < 0 UNSTABLE -! 1/L = 0 NEUTRAL -! 1/L > 0 STABLE -!-------------------------------------------------- - DO nss = 1, nspec - IF (rmol < 0.) THEN - pdz = sqrt(1.0 - 9.0*dz*rmol) - pzr = sqrt(1.0 - 9.0*zr*rmol) - fac = ((pdz - 1.0)/(pzr - 1.0))*((pzr + 1.0)/(pdz + 1.0)) - a = 0.74*dz*alog(fac) + (0.164/rmol)*(pdz-pzr) - ELSE IF (rmol == 0.) THEN - a = 0.74*(dz*alog(dz/zr) - dz + zr) - ELSE - a = 0.74*(dz*alog(dz/zr) - dz + zr) + (2.35*rmol)*(dz - zr)**2 - END IF -!-------------------------------------------------- -! CALCULATE THE DEPOSITION VELOCITIY -!-------------------------------------------------- - vgtemp(nss) = vgtemp(nss)/(1.0 + vgtemp(nss)*a/(vk*ustar*(dz - zr))) - END DO - - END SUBROUTINE cellvg - - SUBROUTINE depvel( data, numgas, rmol, zr, z0, ustar, & - depv, vgpart, aer_res ) -!-------------------------------------------------- -! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT -! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE -! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. -! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) -! Modified by Darrell A. Winner (Feb. 1991) -! by Winfried Seidl (Aug. 1997) -!.....PROGRAM VARIABLES... -! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH -! ZR - REFERENCE HEIGHT -! Z0 - SURFACE ROUGHNESS HEIGHT -! SCPR23 - (Schmidt #/Prandtl #)**(2/3) Diffusion correction fact -! UBAR - ABSOLUTE VALUE OF SURFACE WIND SPEED -! DEPVEL - POLLUTANT DEPOSITION VELOCITY -! Vk - VON KARMAN CONSTANT -! USTAR - FRICTION VELOCITY U* -! POLINT - POLLUTANT INTEGRAL -! AER_RES - AERODYNAMIC RESISTANCE -!.....REFERENCES... -! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL -! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, -! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. -!.....RESTRICTIONS... -! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV -! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE -! SURFACE LAYER, A HEIGHT OF O(30M). -! 2. ALL INPUT UNITS MUST BE CONSISTENT -! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION -! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED -! ON THE WORK OF BUSINGER ET AL.(1971). -! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT -! THE SAME FOR THE CASES L<0 AND L>0. -!-------------------------------------------------- - -! USE module_model_constants, only: karman - implicit none - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: numgas - REAL(KIND_PHYS), intent(in) :: ustar, z0, zr - REAL(KIND_PHYS), intent(out) :: vgpart, aer_res - REAL(KIND_PHYS), intent(inout) :: rmol -!-------------------------------------------------- -! .. Array Arguments .. -!-------------------------------------------------- - REAL(KIND_PHYS), intent(out) :: depv(numgas) -!-------------------------------------------------- -! .. Local Scalars .. -!-------------------------------------------------- - INTEGER :: l - REAL(KIND_PHYS) :: ao, ar, polint, vk -!-------------------------------------------------- -! .. Intrinsic Functions .. -!-------------------------------------------------- - INTRINSIC alog -!-------------------------------------------------- -! Set the von Karman constant -!-------------------------------------------------- - vk = karman - -!-------------------------------------------------- -! Calculate the diffusion correction factor -! SCPR23 is calculated as (Sc/Pr)**(2/3) using Sc= 1.15 and Pr= 1.0 -! DATA%SCPR23 = 1.10 -!-------------------------------------------------- -! DETERMINE THE STABILITY BASED ON THE CONDITIONS -! 1/L < 0 UNSTABLE -! 1/L = 0 NEUTRAL -! 1/L > 0 STABLE -!-------------------------------------------------- - - if(abs(rmol) < 1.E-6 ) rmol = 0. - - IF (rmol<0) THEN - ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 - ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 - polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) - ELSE IF (rmol==0.) THEN - polint = 0.74*alog(zr/z0) - ELSE - polint = 0.74*alog(zr/z0) + 4.7*rmol*(zr-z0) - END IF - -!-------------------------------------------------- -! CALCULATE THE Maximum DEPOSITION VELOCITY -!-------------------------------------------------- - DO l = 1, numgas - depv(l) = ustar*vk/(2.0*data%scpr23(l)+polint) - END DO - vgpart = ustar*vk/polint - aer_res = polint/(karman*max(ustar,1.0e-4)) - - END SUBROUTINE depvel - - ! NOTE: dep_init is now in rrfs_smoke_data - -end module dep_simple_mod diff --git a/physics/smoke/dep_vertmx_mod.F90 b/physics/smoke/dep_vertmx_mod.F90 deleted file mode 100755 index d56b1b87ee..0000000000 --- a/physics/smoke/dep_vertmx_mod.F90 +++ /dev/null @@ -1,212 +0,0 @@ -!>\file dep_vertmx_mod.F90 -!! This file calculates change in time of phi due to vertical mixing and dry deposition. - -MODULE dep_vertmx_mod - use rrfs_smoke_data - use machine , only : kind_phys - -CONTAINS - -!----------------------------------------------------------------------- - SUBROUTINE vertmx( data, dt, phi, kt_turb, dryrho, & - zsigma, zsigma_half, vd, kts, ktem1 ) -! !! purpose - calculate change in time of phi due to vertical mixing -! !! and dry deposition (for 1 species, 1 vertical column, 1 time step) -! !! Mariusz Pagowski, March 2001 -! !! conventions used: -! !! input is lower case -! !! output is upper case -! -! !! modifications by R Easter, May 2006 -! !! added dryrho so this routine conserves column mass burde -! !! when dry deposition velocity is zero -! !! changed "kte" to "ktem1" for consistency with the kte in WRF -! -! ARGUMENTS -! -! dt = time step (s) -! phi = initial/final (at input/output) species mixing ratios at "T" points -! kt_turb = turbulent exchange coefficients (m^2/s) at "W" points -! dryrho = dry air density (kg/m^3) at "T" points -! zsigma = heights (m) at "W" points -! zsigma_half = heights (m) at "T" points -! vd = dry deposition velocity (m/s) -! kts, ktem1 = vertical indices of bottom and top "T" points -! - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 - REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: kt_turb, zsigma - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: dryrho, zsigma_half - REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: phi -! .. -! .. Local Scalars .. - INTEGER :: k -! .. -! .. Local Arrays .. - REAL(KIND=KIND_PHYS), DIMENSION (kts+1:ktem1) :: a_coeff - REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: b_coeff, lhs1, lhs2, lhs3, rhs -! .. -! .. External Subroutines .. -! EXTERNAL coeffs, rlhside, tridiag -! .. - CALL coeffs( data, kts, ktem1, dryrho, zsigma, zsigma_half, a_coeff, b_coeff ) - - CALL rlhside( data, kts, ktem1, kt_turb, dryrho, a_coeff, b_coeff, & - phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) - - CALL tridiag( data, kts, ktem1, lhs1, lhs2, lhs3, rhs ) - - DO k = kts,ktem1 - phi(k) = rhs(k) - END DO - - END SUBROUTINE vertmx - - -!----------------------------------------------------------------------- - SUBROUTINE rlhside( data, kts, ktem1, k_turb, dryrho, a_coeff, b_coeff, & - phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) - !! to calculate right and left hand sides in diffusion equation - !! for the tridiagonal solver - !! Mariusz Pagowski, March 2001 - !! conventions used: - !! input is lower case - !! output is upper case - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 - REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: k_turb - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts+1:ktem1) :: a_coeff - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: b_coeff, dryrho - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: phi - REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: lhs1, lhs2, lhs3, rhs -! .. -! .. Local Scalars .. - !REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .25, beta_implicit = .75 - REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .0, beta_implicit = 1. - INTEGER :: i - -! .. - i = kts - a2 = a_coeff(i+1)*k_turb(i+1) - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(vd*dryrho(i)+a2))*phi(i) + & - alfa_explicit*(a2*phi(i+1)) - lhs1(i) = 0. - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(vd*dryrho(i)+a2) - lhs3(i) = -beta_implicit*a2 - - DO i = kts+1, ktem1-1 - a1 = a_coeff(i)*k_turb(i) - a2 = a_coeff(i+1)*k_turb(i+1) - - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1+a2))*phi(i) + & - alfa_explicit*(a1*phi(i-1) + a2*phi(i+1)) - - lhs1(i) = -beta_implicit*a1 - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) - lhs3(i) = -beta_implicit*a2 - END DO - - i = ktem1 - a1 = a_coeff(i)*k_turb(i) - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1 ))*phi(i) + & - alfa_explicit*(a1*phi(i-1)) - lhs1(i) = -beta_implicit*a1 - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1 ) - lhs3(i) = 0. - - END SUBROUTINE rlhside - - -!----------------------------------------------------------------------- - SUBROUTINE tridiag( data, kts, ktem1, a, b, c, f ) - !! to solve system of linear eqs on tridiagonal matrix n times n - !! after Peaceman and Rachford, 1955 - !! a,b,c,F - are vectors of order n - !! a,b,c - are coefficients on the LHS - !! F - is initially RHS on the output becomes a solution vector - !! Mariusz Pagowski, March 2001 - !! conventions used: - !! input is lower case - !! output is upper case - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: a, b, c - REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: f -! .. -! .. Local Scalars .. - REAL(KIND_PHYS) :: p - INTEGER :: i -! .. -! .. Local Arrays .. - REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: q -! .. - q(kts) = -c(kts)/b(kts) - f(kts) = f(kts)/b(kts) - - DO i = kts+1, ktem1 - p = 1./(b(i)+a(i)*q(i-1)) - q(i) = -c(i)*p - f(i) = (f(i)-a(i)*f(i-1))*p - END DO - - DO i = ktem1 - 1, kts, -1 - f(i) = f(i) + q(i)*f(i+1) - END DO - - END SUBROUTINE tridiag - - -!----------------------------------------------------------------------- - SUBROUTINE coeffs( data, kts, ktem1, dryrho, & - z_sigma, z_sigma_half, a_coeff, b_coeff ) -! !! to calculate coefficients in diffusion equation -! !! Mariusz Pagowski, March 2001 -! !! conventions used: -! !! input is lower case -! !! output is upper case -! .. Scalar Arguments .. - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - - INTEGER, INTENT(IN) :: kts,ktem1 -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: z_sigma - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: z_sigma_half, dryrho - REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts+1:ktem1) :: a_coeff - REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: b_coeff -! .. -! .. Local Scalars .. - INTEGER :: i - REAL(KIND=KIND_PHYS) :: dryrho_at_w -! .. - DO i = kts, ktem1 - b_coeff(i) = 1./(dryrho(i)*(z_sigma(i+1)-z_sigma(i))) - END DO - - DO i = kts+1, ktem1 - dryrho_at_w = 0.5*(dryrho(i)+dryrho(i-1)) - a_coeff(i) = dryrho_at_w/(z_sigma_half(i)-z_sigma_half(i-1)) - END DO - - END SUBROUTINE coeffs - -!----------------------------------------------------------------------- -END MODULE dep_vertmx_mod diff --git a/physics/smoke/dep_wet_ls_mod.F90 b/physics/smoke/dep_wet_ls_mod.F90 deleted file mode 100755 index 3a7a186eac..0000000000 --- a/physics/smoke/dep_wet_ls_mod.F90 +++ /dev/null @@ -1,562 +0,0 @@ -!>\file dep_wet_ls_mod.F90 -!! This file contains aerosol wet deposition module. - -module dep_wet_ls_mod - use rrfs_smoke_data - use machine , only : kind_phys - use rrfs_smoke_config -! use chem_tracers_mod -! use chem_rc_mod -! use chem_tracers_mod -! use chem_const_mod, only : grav => grvity - - implicit none - - ! -- large scale wet deposition scavenging factors - - private - - public :: dep_wet_ls_init - public :: wetdep_ls - public :: WetRemovalGOCART - -contains - -! subroutine dep_wet_ls_init(config, rc) - subroutine dep_wet_ls_init(data) - implicit none - type(smoke_data), intent(inout) :: data - - ! -- I/O arguments -! type(chem_config_type), intent(in) :: config -! integer, intent(out) :: rc - - ! -- local variables - integer :: ios, n - - ! -- begin - !rc = CHEM_RC_SUCCESS - - ! -- set aerosol wet scavenging coefficients - if (associated(data%alpha)) then - deallocate(data%alpha, stat=ios) - !if (chem_rc_test((ios /= 0), msg="Failed to deallocate memory", & - ! file=__FILE__, line=__LINE__, rc=rc)) return - end if - - allocate(data%alpha(num_chem), stat=ios) - !if (chem_rc_test((ios /= 0), msg="Failed to allocate memory", & - ! file=__FILE__, line=__LINE__, rc=rc)) return - - data%alpha = 0. - - select case (wetdep_ls_opt) - case (WDLS_OPT_GSD) - - select case (chem_opt) - case (CHEM_OPT_GOCART) - data%alpha = 1.0 - end select - - case (WDLS_OPT_NGAC) - - select case (chem_opt) - case (CHEM_OPT_GOCART) - data%alpha(p_so2 ) = 0. - data%alpha(p_sulf ) = 1.5 - data%alpha(p_dms ) = 0. - data%alpha(p_msa ) = 0. - data%alpha(p_p25 ) = 1. - data%alpha(p_bc1 ) = 0.7 - data%alpha(p_bc2 ) = 0.7 - data%alpha(p_oc1 ) = 1. - data%alpha(p_oc2 ) = 1. - data%alpha(p_dust_1) = 1. - data%alpha(p_dust_2) = 1. - data%alpha(p_dust_3) = 1. - data%alpha(p_dust_4) = 1. - data%alpha(p_dust_5) = 1. - data%alpha(p_seas_1) = 1. - data%alpha(p_seas_2) = 1. - data%alpha(p_seas_3) = 1. - data%alpha(p_seas_4) = 1. - data%alpha(p_seas_5) = 1. - data%alpha(p_p10 ) = 1. - case default - ! -- NGAC large scale wet deposition only works with GOCART - end select - - case default - end select - - ! -- replace first default wet scavenging coefficients with input values if - ! available - if (any(wetdep_ls_alpha > 0._kind_phys)) then - n = min(size(data%alpha), size(wetdep_ls_alpha)) - data%alpha(1:n) = real(wetdep_ls_alpha(1:n)) - end if - - end subroutine dep_wet_ls_init - - - - subroutine wetdep_ls(data,dt,var,rain,moist,rho,var_rmv, & - num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - - INTEGER, INTENT(IN ) :: num_chem,num_moist,p_qc, p_qi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - real(kind_phys), INTENT(IN ) :: dt - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: rho,dz8w,vvel - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem), & - INTENT(INOUT) :: var - REAL(kind_phys), DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: rain - REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & - INTENT(INOUT ) :: var_rmv - REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: var_sum - REAL(kind_phys), DIMENSION( its:ite , kts:kte, jts:jte ) :: var_rmvl - REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: frc,var_sum_clw,rain_clw - real(kind_phys) :: dvar,factor,rho_water - integer :: nv,i,j,k - - rho_water = 1000. - var_rmv (:,:,:)=0. - - do nv=1,num_chem -! -! simple LS removal -! - -! -! proportionality constant -! - frc(:,:)=0.1 - do i=its,ite - do j=jts,jte - var_sum_clw(i,j)=0. - var_sum(i,j)=0. - var_rmvl(i,:,j)=0. - rain_clw(i,j)=0. - if(rain(i,j).gt.1.e-6)then -! convert rain back to rate -! - rain_clw(i,j)=rain(i,j)/dt -! total cloud water -! - do k=1,kte - dvar=max(0.,(moist(i,k,j,p_qc)+moist(i,k,j,p_qi))) - var_sum_clw(i,j)=var_sum_clw(i,j)+dvar - enddo - endif - enddo - enddo -! -! get rid of it -! - do i=its,ite - do j=jts,jte - if(rain(i,j).gt.1.e-6 .and. var_sum_clw(i,j).gt.1.e-10 ) then - do k=kts,kte - if(var(i,k,j,nv).gt.1.e-08 .and. (moist(i,k,j,p_qc)+moist(i,k,j,p_qi)).gt.1.e-8)then - factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) - dvar=max(0.,data%alpha(nv)*factor/(1+factor)*var(i,k,j,nv)) - dvar=min(dvar,var(i,k,j,nv)) - var_rmvl(i,k,j)=dvar - if((var(i,k,j,nv)-dvar).lt.1.e-16)then - dvar=var(i,k,j,nv)-1.e-16 - var_rmvl(i,k,j)=dvar !lzhang - var(i,k,j,nv)=var(i,k,j,nv)-dvar - else - var(i,k,j,nv)=var(i,k,j,nv)-dvar - endif - !var_rmv(i,j,nv)=var_rmv(i,j,nv)+var_rmvl(i,k,j) - !!convert wetdeposition into ug/m2/s - var_rmv(i,j,nv)=var_rmv(i,j,nv)+(var_rmvl(i,k,j)*rho(i,k,j)*dz8w(i,k,j)/dt) !lzhang - endif - enddo - var_rmv(i,j,nv)=max(0.,var_rmv(i,j,nv)) - endif - enddo - enddo - enddo - - end subroutine wetdep_ls - -!------------------------------------------------------------------------- -! NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3 ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: WetRemovalGOCART - Calculate aerosol wet removal due -! to large scale processes. -! -! !INTERFACE: -! - - subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & - num_chem, var_rmv, chem, ple, tmpu, & - rhoa, dqcond, precc, precl, grav, & - ims, ime, jms, jme, kms, kme) -! ims, ime, jms, jme, kms, kme, rc ) - -! !USES: - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! !INPUT PARAMETERS: - integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & - ims, ime, jms, jme, kms, kme - real(kind_phys), intent(in) :: cdt, grav - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& - INTENT(INOUT) :: chem - REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & - INTENT(INOUT ) :: var_rmv !! tracer loss flux [kg m-2 s-1] - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme),& - INTENT(IN) :: ple, tmpu, rhoa, dqcond - real(kind_phys), dimension(ims:ime , jms:jme) , & - INTENT(IN) :: precc, precl ! cv, ls precip [mm day-1] - -! !OUTPUT PARAMETERS: -! integer, intent(out) :: rc ! Error return code: - ! 0 - all is well - ! 1 - - -! !DESCRIPTION: Calculates the updated species concentration due to wet -! removal. As written, intended to function for large -! scale (not convective) wet removal processes - -! -! !REVISION HISTORY: -! -! 08Jan2010 - Colarco, based on GOCART implementation, does not -! include any size dependent term -! -!EOP -!------------------------------------------------------------------------- - -! !Local Variables - character(len=*), parameter :: myname = 'WetRemovalGOCART' - integer :: i, j, k, n, nbins, LH, kk, ios,nv - real(kind_phys) :: pdog(i1:i2,k1:k2,j1:j2) ! air mass factor dp/g [kg m-2] - real(kind_phys) :: pls, pcv, pac ! ls, cv, tot precip [mm day-1] - real(kind_phys) :: qls(k1:k2), qcv(k1:k2) ! ls, cv portion dqcond [kg m-3 s-1] - real(kind_phys) :: qmx, qd, A ! temporary variables on moisture - real(kind_phys) :: F, B, BT ! temporary variables on cloud, freq. - real(kind_phys), allocatable :: fd(:,:) ! flux across layers [kg m-2] - real(kind_phys), allocatable :: DC(:) ! scavenge change in mass mixing ratio -! Rain parameters from Liu et al. - real(kind_phys), parameter :: B0_ls = 1.0e-4 - real(kind_phys), parameter :: F0_ls = 1.0 - real(kind_phys), parameter :: XL_ls = 5.0e-4 - real(kind_phys), parameter :: B0_cv = 1.5e-3 - real(kind_phys), parameter :: F0_cv = 0.3 - real(kind_phys), parameter :: XL_cv = 2.0e-3 -! Duration of rain: ls = model timestep, cv = 1800 s (<= cdt) - real(kind_phys) :: Td_ls - real(kind_phys) :: Td_cv - - -! Efficiency of dust wet removal (since dust is really not too hygroscopic) -! Applied only to in-cloud scavenging - real(kind_phys) :: effRemoval -! real(kind_phys),dimension(20) ::fwet -! tracer: p_so2=1 p_sulf=2 p_dms=3 p_msa=4 p_p25=5 p_bc1=6 p_bc2=7 p_oc1=8 -! p_oc2=9 p_dust_1=10 p_dust_2=11 p_dust_3=12 p_dust_4=13 p_dust_5=14 -! p_seas_1=15 p_seas_2=16 p_seas_3=17 p_seas_4=18 p_seas_5=19 p_p10 =20 -! data fwet /0.,1.5,0.,0.,1.,0.7,0.7,0.4,0.4,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1./ -! rc=0. - -! Initialize local variables -! -------------------------- -! rc = CHEM_RC_SUCCESS - - Td_ls = cdt - Td_cv = cdt - nbins = n2-n1+1 - var_rmv = 0.0 - -! Allocate the dynamic arrays - allocate(fd(k1:k2,nbins),stat=ios) -! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & -! file=__FILE__, line=__LINE__, rc=rc)) return - allocate(dc(nbins),stat=ios) -! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & -! file=__FILE__, line=__LINE__, rc=rc)) return - -! Accumulate the 3-dimensional arrays of rhoa and pdog - do j = j1, j2 - do i = i1, i2 - !pdog(i,k1:k2,j) = (ple(i,k1+1:k2+1,j)-ple(i,k1:k2,j)) / grav - pdog(i,k1:k2,j) = (ple(i,k1:k2,j)-ple(i,k1+1:k2+1,j)) / grav !lzhang - enddo - enddo - - do nv=1, num_chem -! Loop over spatial indices - do j = j1, j2 - big_i_loop: do i = i1, i2 - -! Check for total precipitation amount -! Assume no precip in column if precl+precc = 0 - pac = precl(i,j) + precc(i,j) - if(pac .le. 0.) cycle big_i_loop - pls = precl(i,j) - pcv = precc(i,j) - -! Initialize the precipitation fields - qls(:) = 0. - qcv(:) = 0. - fd(:,:) = 0. - -! Find the highest model layer experiencing rainout. Assumes no -! scavenging if T < 258 K - !LH = 0 - LH = k2+1 !lzhang - !do k = k1, k2 - do k = k2, k1,-1 !lzhang - if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then - LH = k - exit - endif - end do - if(LH .gt. k2) cycle big_i_loop !lzhang - -! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse -! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. - !do k = LH, k2 - do k = LH, k1, -1 !lzhang - qls(k) = -dqcond(i,k,j)*pls/pac*rhoa(i,k,j) - qcv(k) = -dqcond(i,k,j)*pcv/pac*rhoa(i,k,j) - end do - -! Loop over vertical to do the scavenging! - !do k = LH, k2 - do k = LH, k1, -1 !lzhang - -!----------------------------------------------------------------------------- -! (1) LARGE-SCALE RAINOUT: -! Tracer loss by rainout = TC0 * F * exp(-B*dt) -! where B = precipitation frequency, -! F = fraction of grid box covered by precipitating clouds. -! We assume that tracer scavenged by rain is falling down to the -! next level, where a fraction could be re-evaporated to gas phase -! if Qls is less then 0 in that level. -!----------------------------------------------------------------------------- - if (qls(k) .gt. 0.) then - F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(qls(k)*cdt/Td_ls)) - B = B0_ls/F0_ls +1./(F0_ls*XL_ls/qls(k)) - BT = B * Td_ls - if (BT.gt.10.) BT = 10. !< Avoid overflow > -! Adjust du level: - do n = 1, nbins - effRemoval = data%alpha(nv) - DC(n) = chem(i,k,j,nv) * F * effRemoval *(1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 - end do -! Flux down: unit is kg m-2 -! Formulated in terms of production in the layer. In the revaporation step -! we consider possibly adding flux from above... - do n = 1, nbins - Fd(k,n) = DC(n)*pdog(i,k,j) - end do - - end if ! if Qls > 0 >>> - -!----------------------------------------------------------------------------- -! * (2) LARGE-SCALE WASHOUT: -! * Occurs when rain at this level is less than above. -!----------------------------------------------------------------------------- - !if(k .gt. LH .and. qls(k) .ge. 0.) then - if(k .lt. LH .and. qls(k) .ge. 0.) then !lzhang - !if(qls(k) .lt. qls(k-1)) then - if(qls(k) .lt. qls(k+1)) then !lzhang -! Find a maximum F overhead until the level where Qls<0. - Qmx = 0. - !do kk = k-1,LH,-1 - do kk = k+1,LH !lzhang - if (Qls(kk).gt.0.) then - Qmx = max(Qmx,Qls(kk)) - else - exit - end if - end do - - F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) - if (F.lt.0.01) F = 0.01 -!----------------------------------------------------------------------------- -! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order -! to use the Harvard formula. Convert back to mixing ratio by multiplying -! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density -! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives -! units of mm/s (omit the multiply and divide by 1000). -!----------------------------------------------------------------------------- - - Qd = Qmx /rhoa(i,k,j)*pdog(i,k,j) - if (Qd.ge.50.) then - B = 0. - else - B = Qd * 0.1 - end if - BT = B * cdt - if (BT.gt.10.) BT = 10. - -! Adjust du level: - do n = 1, nbins - DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) & - chem(i,k,j,nv) = 1.0E-32 - var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s - end do - - end if - end if ! if ls washout >>> -#if 0 -!----------------------------------------------------------------------------- -! (3) CONVECTIVE RAINOUT: -! Tracer loss by rainout = dd0 * F * exp(-B*dt) -! where B = precipitation frequency, -! F = fraction of grid box covered by precipitating clouds. -!----------------------------------------------------------------------------- - - if (qcv(k) .gt. 0.) then - F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qcv(k)*cdt/Td_cv)) - B = B0_cv - BT = B * Td_cv - if (BT.gt.10.) BT = 10. !< Avoid overflow > - -! Adjust du level: - do n = 1, nbins - effRemoval = data%alpha(nv) - DC(n) = chem(i,k,j,nv) * F * effRemoval * (1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 - end do - -!------ Flux down: unit is kg. Including both ls and cv. - do n = 1, nbins - Fd(k,n) = Fd(k,n) + DC(n)*pdog(i,k,j) - end do - - end if ! if Qcv > 0 >>> - -!----------------------------------------------------------------------------- -! (4) CONVECTIVE WASHOUT: -! Occurs when rain at this level is less than above. -!----------------------------------------------------------------------------- - - !if (k.gt.LH .and. Qcv(k).ge.0.) then - if (k.lt.LH .and. Qcv(k).ge.0.) then !lzhang - !if (Qcv(k).lt.Qcv(k-1)) then - if (Qcv(k).lt.Qcv(k+1)) then !lzhang -!----- Find a maximum F overhead until the level where Qls<0. - Qmx = 0. - !do kk = k-1, LH, -1 - do kk = k+1, LH !lzhang - if (Qcv(kk).gt.0.) then - Qmx = max(Qmx,Qcv(kk)) - else - exit - end if - end do - - F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) - if (F.lt.0.01) F = 0.01 -!----------------------------------------------------------------------------- -! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order -! to use the Harvard formula. Convert back to mixing ratio by multiplying -! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density -! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives -! units of mm/s (omit the multiply and divide by 1000). -!----------------------------------------------------------------------------- - - Qd = Qmx / rhoa(i,k,j)*pdog(i,k,j) - if (Qd.ge.50.) then - B = 0. - else - B = Qd * 0.1 - end if - BT = B * cdt - if (BT.gt.10.) BT = 10. - -! Adjust du level: - do n = 1, nbins - DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) & - chem(i,k,j,nv) = 1.0E-32 - var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s - end do - - end if - end if ! if cv washout >>> -#endif -!----------------------------------------------------------------------------- -! (5) RE-EVAPORATION. Assume that SO2 is re-evaporated as SO4 since it -! has been oxidized by H2O2 at the level above. -!----------------------------------------------------------------------------- -! Add in the flux from above, which will be subtracted if reevaporation occurs - !if(k .gt. LH) then - if(k .lt. LH) then !lzhang - do n = 1, nbins - !Fd(k,n) = Fd(k,n) + Fd(k-1,n) - Fd(k,n) = Fd(k,n) + Fd(k+1,n) !lzhang - end do - -! Is there evaporation in the currect layer? - if (-dqcond(i,k,j) .lt. 0.) then -! Fraction evaporated = H2O(k)evap / H2O(next condensation level). - !if (-dqcond(i,k-1,j) .gt. 0.) then - if (-dqcond(i,k+1,j) .gt. 0.) then !lzhang - - A = abs( dqcond(i,k,j) * pdog(i,k,j) & - !/ ( dqcond(i,k-1,j) * pdog(i,k-1,j)) ) - / ( dqcond(i,k+1,j) * pdog(i,k+1,j)) ) !lzhang - if (A .gt. 1.) A = 1. - -! Adjust tracer in the level - do n = 1, nbins - !DC(n) = Fd(k-1,n) / pdog(i,k,j) * A - DC(n) = Fd(k+1,n) / pdog(i,k,j) * A !lzhang - chem(i,k,j,nv) = chem(i,k,j,nv) + DC(n) - chem(i,k,j,nv) = max(chem(i,k,j,nv),1.e-32) -! Adjust the flux out of the bottom of the layer - Fd(k,n) = Fd(k,n) - DC(n)*pdog(i,k,j) - end do - - endif - endif ! if -moistq < 0 - endif - end do ! k - - do n = 1, nbins - !var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k2,n)/cdt !lzhang - var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s - end do - - end do big_i_loop ! i - end do ! j - end do !nv for num_chem - - deallocate(fd,DC,stat=ios) -! if (chem_rc_test((ios .ne. 0), msg="Failed to deallocate memory", & -! file=__FILE__, line=__LINE__, rc=rc)) return - - end subroutine WetRemovalGOCART - -end module dep_wet_ls_mod diff --git a/physics/smoke/dust_data_mod.F90 b/physics/smoke/dust_data_mod.F90 index 9e9713e22d..a710701f1f 100755 --- a/physics/smoke/dust_data_mod.F90 +++ b/physics/smoke/dust_data_mod.F90 @@ -3,7 +3,6 @@ module dust_data_mod - use rrfs_smoke_data use machine , only : kind_phys use rrfs_smoke_config, only : p_dust_1, p_dust_2, p_dust_3, p_dust_4, p_dust_5, & p_edust1, p_edust2, p_edust3, p_edust4, p_edust5 @@ -80,8 +79,8 @@ module dust_data_mod ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) integer, parameter :: dust_calcdrag = 1 - real(kind_phys), parameter :: dust_alpha = 2.2 - real(kind_phys), parameter :: dust_gamma = 1.0 + real(kind_phys) :: dust_alpha = 2.2 + real(kind_phys) :: dust_gamma = 1.0 ! -- sea salt parameters diff --git a/physics/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 index fbf87aa560..46ff58a8b9 100755 --- a/physics/smoke/dust_fengsha_mod.F90 +++ b/physics/smoke/dust_fengsha_mod.F90 @@ -9,7 +9,6 @@ module dust_fengsha_mod ! 07/16/2019 - Adapted for NUOPC/GOCART, R. Montuoro ! 02/01/2020 - Adapted for FV3/CCPP, Haiqin Li - use rrfs_smoke_data use machine , only : kind_phys use dust_data_mod @@ -21,7 +20,7 @@ module dust_fengsha_mod contains - subroutine gocart_dust_fengsha_driver(data, dt, & + subroutine gocart_dust_fengsha_driver(dt, & chem,rho_phy,smois,p8w,ssm, & isltyp,vegfra,snowh,xland,area,g,emis_dust, & ust,znt,clay,sand,rdrag,uthr, & @@ -30,47 +29,56 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) IMPLICIT NONE - type(smoke_data), intent(inout) :: data INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & num_emis_dust,num_moist,num_chem,num_soil_layers - INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp + + ! 2d input variables + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm ! Sediment supply map + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra ! vegetative fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: snowh ! snow height (m) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: xland ! dominant land use type + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: area ! area of grid cell + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ust ! friction velocity + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: znt ! Surface Roughness length (m) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: clay ! Clay Fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: sand ! Sand Fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: rdrag ! Drag Partition (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: uthr ! Dry Threshold Velocity (m/s) + + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp ! soil type + + ! 3d input variables + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: p8w + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: rho_phy REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra, & - snowh, & - xland, & - area, & - ust, & - znt, & - clay, & - sand, & - rdrag, & - uthr - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & - p8w, & - rho_phy - REAL(kind_phys), INTENT(IN) :: dt,g - ! Local variables + !0d input variables + REAL(kind_phys), INTENT(IN) :: dt ! time step + REAL(kind_phys), INTENT(IN) :: g ! gravity (m/s**2) + ! Local variables integer :: nmx,smx,i,j,k,imx,jmx,lmx - integer,dimension (1,1) :: ilwi - real(kind_phys), DIMENSION (1,1) :: erodtot - REAL(kind_phys), DIMENSION (1,1) :: gravsm - REAL(kind_phys), DIMENSION (1,1) :: drylimit - real(kind_phys), DIMENSION (5) :: tc,bems - real(kind_phys), dimension (1,1) :: airden,airmas,ustar - real(kind_phys), dimension (1) :: dxy + integer :: ilwi + real(kind_phys) :: airden ! air density + REAL(kind_phys) :: airmas ! dry air mass + real(kind_phys) :: dxy + real(kind_phys) :: conver,converi ! conversion values + real(kind_phys) :: R ! local drag partition + real(kind_phys) :: ustar + real(kind_phys), DIMENSION (num_emis_dust) :: tc + real(kind_phys), DIMENSION (num_emis_dust) :: bems + real(kind_phys), DIMENSION (num_emis_dust) :: distribution real(kind_phys), dimension (3) :: massfrac - real(kind_phys) :: conver,converi - real(kind_phys) :: R + real(kind_phys) :: erodtot + REAL(kind_phys) :: gravsm + REAL(kind_phys) :: drylimit - ! threshold values + ! conversion values conver=1.e-9 converi=1.e9 @@ -88,9 +96,9 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Don't do dust over water!!! - ilwi(1,1)=0 + ilwi=0 if(xland(i,j).lt.1.5)then - ilwi(1,1)=1 + ilwi=1 ! Total concentration at lowest model level. This is still hardcoded for 5 bins. @@ -106,10 +114,10 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Air mass and density at lowest model level. - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g - airden(1,1)=rho_phy(i,kts,j) - ustar(1,1)=ust(i,j) - dxy(1)=area(i,j) + airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g + airden=rho_phy(i,kts,j) + ustar=ust(i,j) + dxy=area(i,j) ! Mass fractions of clay, silt, and sand. massfrac(1)=clay(i,j) @@ -119,7 +127,7 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Total erodibility. - erodtot(1,1) = ssm(i,j) ! SUM(erod(i,j,:)) + erodtot = ssm(i,j) ! SUM(erod(i,j,:)) ! Don't allow roughness lengths greater than 20 cm to be lofted. ! This kludge accounts for land use types like urban areas and @@ -129,39 +137,39 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Forthcoming... IF (znt(i,j) .gt. 0.2) then - ilwi(1,1)=0 + ilwi=0 endif ! limit where there is lots of vegetation if (vegfra(i,j) .gt. .17) then - ilwi(1,1) = 0 + ilwi = 0 endif ! limit where there is snow on the ground if (snowh(i,j) .gt. 0) then - ilwi(1,1) = 0 + ilwi = 0 endif ! Do not allow areas with bedrock, lava, or land-ice to loft IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & isltyp(i,j) .eq. 18) then - ilwi(1,1)=0 + ilwi=0 ENDIF IF (isltyp(i,j) .eq. 0)then - ilwi(1,1)=0 + ilwi=0 endif - if(ilwi(1,1) == 0 ) cycle + if(ilwi == 0 ) cycle ! Calculate gravimetric soil moisture and drylimit. - gravsm(1,1)=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) - drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + gravsm=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) + drylimit=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) ! get drag partition ! FENGSHA uses the drag partition correction of MacKinnon et al 2004 ! doi:10.1016/j.geomorph.2004.03.009 if (dust_calcdrag .ne. 1) then - call fengsha_drag(data,znt(i,j),R) + call fengsha_drag(znt(i,j),R) else ! use the precalculated version derived from ASCAT; Prigent et al. (2012,2015) ! doi:10.1109/TGRS.2014.2338913 & doi:10.5194/amt-5-2703-2012 @@ -174,9 +182,14 @@ subroutine gocart_dust_fengsha_driver(data, dt, & endif ! Call dust emission routine. - call source_dust(data, imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & - erodtot, dxy, gravsm, airden, airmas, & - bems, g, drylimit, dust_alpha, dust_gamma, R, uthr(i,j)) + + call source_dust(imx,jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & + erodtot, dxy, smois(i,1,j), airden, airmas, bems, g, dust_alpha, dust_gamma, & + R, uthr(i,j)) + +! call source_dust(imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & +! erodtot, dxy, gravsm, airden, airmas, & +! bems, g, drylimit, dust_alpha, dust_gamma, R, uthr(i,j)) ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then ! dustin(i,j,1:5)=tc(1:5)*converi @@ -209,17 +222,20 @@ subroutine gocart_dust_fengsha_driver(data, dt, & end subroutine gocart_dust_fengsha_driver - SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & - erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & - gamma, R, uthres) + ! SUBROUTINE source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + ! erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & + ! gamma, R, uthres) + + subroutine source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + erod, dxy, smois, airden, airmas, bems, g0, alpha, gamma, & + R, uthres) ! **************************************************************************** ! * Evaluate the source of each dust particles size bin by soil emission ! * ! * Input: ! * EROD Fraction of erodible grid cell (-) - ! * GRAVSM Gravimetric soil moisture (g/g) - ! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) + ! * smois Volumetric soil moisture (m3/m3) ! * ALPHA Constant to fudge the total emission of dust (1/m) ! * GAMMA Tuning constant for erodibility (-) ! * DXY Surface of each grid cell (m2) @@ -236,8 +252,7 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) ! * ! * Data: - ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) - ! * SPOINT Pointer to 3 soil classes (-) + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) (clay silt sand) ! * DEN_DUST Dust density (kg/m3) ! * DEN_SALT Saltation particle density (kg/m3) ! * REFF_SALT Reference saltation particle diameter (m) @@ -269,6 +284,9 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! * EMIT Total vertical mass flux (kg/m2/s) ! * EMIT_VOL Total vertical volume flux (m/s) ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * RHOSOIL Density of Soil (kg/m3) + ! * SALT total saltation + ! * SALTBIN total saltation in bin ! * ! * Output: ! * TC Total concentration of dust (kg/kg/timestep/cell) @@ -276,52 +294,56 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! * ! **************************************************************************** implicit none - type(smoke_data), intent(inout) :: data + ! Input INTEGER, INTENT(IN) :: imx,jmx,lmx,nmx,smx REAL(kind_phys), INTENT(IN) :: dt1 - REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ustar REAL(kind_phys), INTENT(IN) :: massfrac(3) - REAL(kind_phys), INTENT(IN) :: erod(imx,jmx) - REAL(kind_phys), INTENT(IN) :: dxy(jmx) - REAL(kind_phys), INTENT(IN) :: gravsm(imx,jmx) - REAL(kind_phys), INTENT(IN) :: airden(imx,jmx,lmx) - REAL(kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) - REAL(kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + REAL(kind_phys), INTENT(IN) :: erod + REAL(kind_phys), INTENT(IN) :: dxy + REAL(kind_phys), INTENT(IN) :: smois + REAL(kind_phys), INTENT(IN) :: airden + REAL(kind_phys), INTENT(IN) :: airmas REAL(kind_phys), INTENT(IN) :: g0 - REAL(kind_phys), INTENT(IN) :: drylimit(imx,jmx) - !! Sandblasting mass efficiency, aka "fudge factor" (based on Tegen et al, - !! 2006 and Hemold et al, 2007) - ! - ! REAL, PARAMETER :: alpha=1.8E-8 ! (m^-1) REAL(kind_phys), INTENT(IN) :: alpha - ! Experimental optional exponential tuning constant for erodibility. - ! 0 < gamma < 1 -> more relative impact by low erodibility regions. REAL(kind_phys), INTENT(IN) :: gamma REAL(kind_phys), INTENT(IN) :: R REAL(kind_phys), INTENT(IN) :: uthres - REAL(kind_phys) :: den(smx), diam(smx) - REAL(kind_phys) :: dvol(nmx), distr_dust(nmx), dlndp(nmx) - REAL(kind_phys) :: dsurface(smx), ds_rel(smx) - REAL(kind_phys) :: u_ts0, u_ts, dsrc, dmass, dvol_tot - REAL(kind_phys) :: salt,emit, emit_vol, stotal - REAL(kind_phys) :: rhoa, g + ! Output + REAL(kind_phys), INTENT(INOUT) :: tc(nmx) + + ! Local Variables + REAL(kind_phys), INTENT(OUT) :: bems(nmx) + + REAL(kind_phys) :: saltbin(smx) + REAL(kind_phys) :: den(smx) + REAL(kind_phys) :: diam(smx) + REAL(kind_phys) :: dvol(nmx) + REAL(kind_phys) :: distr_dust(nmx) + REAL(kind_phys) :: dlndp(nmx) + REAL(kind_phys) :: dsurface(smx) + REAL(kind_phys) :: ds_rel(smx) + REAL(kind_phys) :: u_ts0 + REAL(kind_phys) :: u_ts + REAL(kind_phys) :: dsrc + REAL(kind_phys) :: dmass + REAL(kind_phys) :: dvol_tot + REAL(kind_phys) :: salt + REAL(kind_phys) :: emit + REAL(kind_phys) :: emit_vol + REAL(kind_phys) :: stotal + REAL(kind_phys) :: rhoa + REAL(kind_phys) :: g INTEGER :: i, j, n - ! Sandblasting mass efficiency, beta. - ! Beta maxes out for clay fractions above 0.2 = betamax. - - REAL(kind_phys), PARAMETER :: betamax=5.25E-4 - REAL(kind_phys) :: beta - integer :: styp - ! Constant of proportionality from Marticorena et al, 1997 (unitless) ! Arguably more ~consistent~ fudge than alpha, which has many walnuts ! sprinkled throughout the literature. - GC REAL(kind_phys), PARAMETER :: cmb=1.0 + REAL(kind_phys), PARAMETER :: kvhmax=2.0e-4 ! REAL, PARAMETER :: cmb=2.61 ! from White,1979 ! Parameters used in Kok distribution function. Advise not to play with @@ -332,6 +354,7 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, REAL(kind_phys), PARAMETER :: gsd_dust=3.0 ! geom. std deviation REAL(kind_phys), PARAMETER :: lambda=12.0D-6 ! crack propagation length (m) REAL(kind_phys), PARAMETER :: cv=12.62D-6 ! normalization constant + REAL(kind_phys), PARAMETER :: RHOSOIL=2650. ! Calculate saltation surface area distribution from sand, silt, and clay ! mass fractions and saltation bin fraction. This will later become a @@ -371,63 +394,16 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, DO n = 1, smx den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) - DO i = 1,imx - DO j = 1,jmx - rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) - - ! FENGSHA uses the 13 category soil type from the USDA - ! call calc_fengsha_styp(massfrac(1),massfrac(3),massfrac(2),styp) - ! Fengsha uses threshold velocities based on dale gilletes data - ! call fengsha_utst(styp,uthres,u_ts0) - - ! Friction velocity threshold correction function based on physical - ! properties related to moisture tension. Soil moisture greater than - ! dry limit serves to increase threshold friction velocity (making - ! it more difficult to loft dust). When soil moisture has not reached - ! dry limit, treat as dry - - IF (gravsm(i,j) > drylimit(i,j)) THEN - u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68)) / R) - ELSE - u_ts = u_ts0 / R - END IF - - ! Calculate total vertical mass flux (note beta has units of m^-1) - ! Beta acts to tone down dust in areas with so few dust-sized particles that the - ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust - ! producers, which is generally not the case. Equation derived from wind-tunnel - ! experiments (see MB95). - - beta=10**(13.6*massfrac(1)-6.0) ! (unitless) - if (massfrac(1) <= 0.2) then - beta=10**(13.4*massfrac(1)-6.0) - else - beta = 2.E-4 - endif - - !--------------------------------------------------------------------- - ! formula of Draxler & Gillette (2001) Atmos. Environ. - ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) - ! - ! where: - ! F = vertical emission flux [g/m**2-s] - ! K = constant 2.0E-04 [1/m] - ! A = 0~3.5 mean = 2.8 (fudge factor) - ! U* = friction velocity [m/s] - ! Ut* = threshold friction velocity [m/s] - ! - !-------------------------------------------------------------------- - - IF (ustar(i,j) .gt. u_ts) then - call fengsha_hflux(data,ustar(i,j),u_ts,beta, salt) - salt = alpha * cmb * ds_rel(n) * airden(i,j,1) / g0 * salt * (erod(i,j)**gamma) * beta - else - salt = 0. - endif - ! EROD is taken into account above - emit = emit + salt - END DO - END DO + rhoa = airden*1.0D-3 ! (g cm^-3) + + call DustEmissionFENGSHA(smois,massfrac(1),massfrac(3), massfrac(2), & + erod, R, rhoa, ustar, uthres, alpha, gamma, kvhmax, & + g, RHOSOIL, salt) + + saltbin(n) = salt * cmb * ds_rel(n) + + ! EROD is taken into account above + emit = emit + salt END DO ! Now that we have the total dust emission, distribute into dust bins using @@ -460,92 +436,23 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! Now distribute total vertical emission into dust bins and update concentration. DO n=1,nmx - DO i=1,imx - DO j=1,jmx - ! Calculate total mass emitted - dsrc = emit*distr_dust(n)*dxy(j)*dt1 ! (kg) - IF (dsrc < 0.0) dsrc = 0.0 - - ! Update dust mixing ratio at first model level. - tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) - ! bems(i,j,n) = dsrc ! diagnostic - !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) - bems(i,j,n) = 1.e+9*dsrc/(dxy(j)*dt1) ! diagnostic (ug/m2/s) !lzhang - END DO - END DO + ! Calculate total mass emitted + dsrc = emit*distr_dust(n)*dxy*dt1 ! (kg) + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + tc(n) = tc(n) + dsrc / airmas ! (kg/kg) + ! bems(i,j,n) = dsrc ! diagnostic + !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) + bems(n) = 1.e+9*dsrc/(dxy*dt1) ! diagnostic (ug/m2/s) !lzhang + END DO END SUBROUTINE source_dust - subroutine fengsha_utst(data,styp,uth, ut) - implicit none - type(smoke_data), intent(inout) :: data - - integer, intent(in) :: styp - real(kind_phys), dimension(fengsha_maxstypes), intent(in) :: uth - real(kind_phys), intent(out) :: ut - ut = uth(styp) -! real (kind_phys) :: uth(13) = & -! (/ 0.08, & ! Sand - 1 -! 0.20, & ! Loamy Sand - 2 -! 0.30, & ! Sandy Loam - 3 -! 0.30, & ! Silt Loam - 4 -! 0.35, & ! Silt - 5 -! 0.60, & ! Loam - 6 -! 0.30, & ! Sandy Clay Loam - 7 -! 0.35, & ! Silty Clay Loam - 8 -! 0.45, & ! Clay Loam - 9 -! 0.45, & ! Sandy Clay - 10 -! 0.45, & ! Silty Clay - 11 -! 0.60, & ! Clay - 12 -! 9.999 /) ! Other - 13 - return - end subroutine fengsha_utst - - subroutine calc_fengsha_styp(data, clay, sand, silt, type) - implicit none - type(smoke_data), intent(inout) :: data - - !--------------------------------------------------------------- - ! Function: calculate soil type based on USDA definition. - ! Source: USDA soil texture calculator - ! - ! Defintion of soil types: - ! - ! - ! NOAH 1 2 3 4 5 6 7 8 9 10 11 12 - ! PX 1 2 3 4 - 5 6 7 8 9 10 11 - ! Soil "Sand" "Loamy Sand" "Sandy Loam" "Silt Loam" "Silt" "Loam" "Sandy Clay Loam" "Silt Clay Loam" "Clay Loam" "Sandy Clay" "Silty Clay" "Clay" - !--------------------------------------------------------------- - REAL(kind_phys), intent(in) :: clay, sand, silt - integer, intent(out) :: type - real(kind_phys) :: cly, snd, slt - - type = 0 - - snd = sand * 100. - cly = clay * 100. - slt = silt * 100. - if (slt+1.5*cly .lt. 15) type = 1 ! snd - if (slt+1.5*cly .ge. 15 .and.slt+1.5*cly .lt. 30) type = 2 ! loamy snd - if (cly .ge. 7 .and. cly .lt. 20 .and. snd .gt. 52 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 1) - if (cly .lt. 7 .and. slt .lt. 50 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 2) - if (slt .ge. 50 .and. cly .ge. 12 .and.cly .lt. 27 ) type = 4 ! slt loam (cond 1) - if (slt .ge. 50 .and. slt .lt. 80 .and.cly .lt. 12) type = 4 ! slt loam (cond 2) - if (slt .ge. 80 .and. cly .lt. 12) type = 5 ! slt - if (cly .ge. 7 .and. cly .lt. 27 .and.slt .ge. 28 .and. slt .lt. 50 .and.snd .le. 52) type = 6 ! loam - if (cly .ge. 20 .and. cly .lt. 35 .and.slt .lt. 28 .and. snd .gt. 45) type = 7 ! sndy cly loam - if (cly .ge. 27 .and. cly .lt. 40 .and.snd .lt. 20) type = 8 ! slt cly loam - if (cly .ge. 27 .and. cly .lt. 40 .and.snd .ge. 20 .and. snd .le. 45) type = 9 ! cly loam - if (cly .ge. 35 .and. snd .gt. 45) type = 10 ! sndy cly - if (cly .ge. 40 .and. slt .ge. 40) type = 11 ! slty cly - if (cly .ge. 40 .and. snd .le. 45 .and.slt .lt. 40) type = 12 ! clay - return - end subroutine calc_fengsha_styp - subroutine fengsha_drag(data,z0,R) + subroutine fengsha_drag(z0,R) implicit none - type(smoke_data), intent(inout) :: data real(kind_phys), intent(in) :: z0 real(kind_phys), intent(out) :: R @@ -567,35 +474,198 @@ subroutine fengsha_drag(data,z0,R) return end subroutine fengsha_drag - subroutine fengsha_hflux(data,ust,utst, kvh, salt) - !--------------------------------------------------------------------- - ! Function: Calculates the Horizontal Saltation Flux, Q, and then - ! calculates the vertical flux. - ! - ! formula of Draxler & Gillette (2001) Atmos. Environ. - ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & + ssm, rdrag, airdens, ustar, uthrs, alpha, gamma, & + kvhmax, grav, rhop, emissions) + + ! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of soil layer, volumetric fraction [1] + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] + REAL(kind_phys), intent(in) :: silt ! fractional silt content [1] + REAL(kind_phys), intent(in) :: ssm ! erosion map [1] + REAL(kind_phys), intent(in) :: rdrag ! drag partition [1/m] + REAL(kind_phys), intent(in) :: airdens ! air density at lowest level [kg/m^3] + REAL(kind_phys), intent(in) :: ustar ! friction velocity [m/sec] + REAL(kind_phys), intent(in) :: uthrs ! threshold velocity [m/2] + REAL(kind_phys), intent(in) :: alpha ! scaling factor [1] + REAL(kind_phys), intent(in) :: gamma ! scaling factor [1] + REAL(kind_phys), intent(in) :: kvhmax ! max. vertical to horizontal mass flux ratio [1] + REAL(kind_phys), intent(in) :: grav ! gravity [m/sec^2] + REAL(kind_phys), intent(in) :: rhop ! soil class density [kg/m^3] + + ! !OUTPUT PARAMETERS: + REAL(kind_phys), intent(inout) :: emissions ! binned surface emissions [kg/(m^2 sec)] + + ! !DESCRIPTION: Compute dust emissions using NOAA/ARL FENGSHA model ! - ! where: - ! F = vertical emission flux [g/m**2-s] - ! K = constant 2.0E-04 [1/m] - ! A = 0~3.5 mean = 2.8 (fudge factor) - ! U* = friction velocity [m/s] - ! Ut* = threshold friction velocity [m/s] + ! !REVISION HISTORY: ! - !-------------------------------------------------------------------- - implicit none - type(smoke_data), intent(inout) :: data - real(kind_phys), intent(in) :: ust, & ! friction velocity - utst, & ! threshold friction velocity - kvh ! vertical to horizontal mass flux ratio + ! 22Feb2020 B.Baker/NOAA - Original implementation + ! 29Mar2021 R.Montuoro/NOAA - Refactored for process library + ! 09Aug2022 B.Baker/NOAA - Adapted for CCPP-Physics + + ! !Local Variables + real(kind_phys) :: alpha_grav + real(kind_phys) :: h + real(kind_phys) :: kvh + real(kind_phys) :: q + real(kind_phys) :: rustar + real(kind_phys) :: total_emissions + real(kind_phys) :: u_sum, u_thresh + +!EOP +!------------------------------------------------------------------------- +! Begin + +! Initialize emissions +! -------------------- + emissions = 0. + +! Prepare scaling factor +! ---------------------- + alpha_grav = alpha / grav + + ! Compute vertical-to-horizontal mass flux ratio + ! ---------------------------------------------- + kvh = DustFluxV2HRatioMB95(clay, kvhmax) + + ! Compute total emissions + ! ----------------------- + emissions = alpha_grav * (ssm ** gamma) * airdens * kvh + + ! Compute threshold wind friction velocity using drag partition + ! ------------------------------------------------------------- + rustar = rdrag * ustar + + ! Now compute size-dependent total emission flux + ! ---------------------------------------------- + ! Fecan moisture correction + ! ------------------------- + h = moistureCorrectionFecan(slc, sand, clay, rhop) + + ! Adjust threshold + ! ---------------- + u_thresh = uthrs * h + + u_sum = rustar + u_thresh + + ! Compute Horizontal Saltation Flux according to Eq (9) in Webb et al. (2020) + ! --------------------------------------------------------------------------- + q = max(0., rustar - u_thresh) * u_sum * u_sum + + ! Distribute emissions to bins and convert to mass flux (kg s-1) + ! -------------------------------------------------------------- + emissions = emissions * q + + + end subroutine DustEmissionFENGSHA +!----------------------------------------------------------------- + real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: vsoil ! volumetric soil moisture fraction [1] + REAL(kind_phys), intent(in) :: sandfrac ! fractional sand content [1] + REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] + +! !DESCRIPTION: Convert soil moisture fraction from volumetric to gravimetric. +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library - real(kind_phys), intent(out) :: salt - real(kind_phys) :: Q - Q = ust * (ust * ust - utst * utst) - salt = Q ! sdep * kvh * Q +! !Local Variables + real :: vsat - return - end subroutine fengsha_hflux +! !CONSTANTS: + REAL(kind_phys), parameter :: rhow = 1000. ! density of water [kg m-3] + +!EOP +!------------------------------------------------------------------------- +! Begin... + +! Saturated volumetric water content (sand-dependent) ! [m3 m-3] + vsat = 0.489 - 0.00126 * ( 100. * sandfrac ) + +! Gravimetric soil content + soilMoistureConvertVol2Grav = vsoil * rhow / (rhop * (1. - vsat)) + + end function soilMoistureConvertVol2Grav +!---------------------------------------------------------------- + real function moistureCorrectionFecan(slc, sand, clay, rhop) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] + REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] + +! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library + +! !Local Variables + real :: grvsoilm + real :: drylimit + +!EOP +!--------------------------------------------------------------- +! Begin... + +! Convert soil moisture from volumetric to gravimetric + grvsoilm = soilMoistureConvertVol2Grav(slc, sand, 2650.) + +! Compute fecan dry limit + drylimit = clay * (14.0 * clay + 17.0) + +! Compute soil moisture correction + moistureCorrectionFecan = sqrt(1.0 + 1.21 * max(0., grvsoilm - drylimit)**0.68) + end function moistureCorrectionFecan +!--------------------------------------------------------------- + real function DustFluxV2HRatioMB95(clay, kvhmax) +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: kvhmax ! maximum flux ratio [1] + +! !CONSTANTS: + REAL(kind_phys), parameter :: clay_thresh = 0.2 ! clay fraction above which the maximum flux ratio is returned + +! !DESCRIPTION: Computes the vertical-to-horizontal dust flux ratio according to +! B.Marticorena, G.Bergametti, J.Geophys.Res., 100(D8), 164! doi:10.1029/95JD00690 +! +! !REVISION HISTORY: +! +! 22Feb2020 B.Baker/NOAA - Original implementation +! 01Apr2021 R.Montuoro/NOAA - Adapted for GOCART process library +! +!EOP +!------------------------------------------------------------------------- +! Begin... + + if (clay > clay_thresh) then + DustFluxV2HRatioMB95 = kvhmax + else + DustFluxV2HRatioMB95 = 10.0**(13.4*clay-6.0) + end if + + end function DustFluxV2HRatioMB95 + end module dust_fengsha_mod diff --git a/physics/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 index da35535f75..2f57341d0d 100755 --- a/physics/smoke/module_add_emiss_burn.F90 +++ b/physics/smoke/module_add_emiss_burn.F90 @@ -4,15 +4,14 @@ module module_add_emiss_burn !RAR: significantly modified for the new BB emissions use machine , only : kind_phys - use rrfs_smoke_data use rrfs_smoke_config CONTAINS - subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & + subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & chem,julday,gmt,xlat,xlong, & !luf_igbp,lu_fire1, & vegtype,vfrac,peak_hr, & time_int,ebu, & ! RAR - r_q,fhist,aod3d_smoke,aod3d_dust, & + r_q,fhist,ext3d_smoke,ext3d_dust, & ! nwfa,nifa, & rainc,rainnc, swdown,smoke_forecast, & ids,ide, jds,jde, kds,kde, & @@ -22,7 +21,6 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & ! USE module_configure, only: grid_config_rec_type ! USE module_state_description IMPLICIT NONE - type(smoke_data), intent(inout) :: data ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -40,7 +38,7 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: - real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: aod3d_smoke, aod3d_dust ! RAR: + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: ext3d_smoke, ext3d_dust ! RAR: integer, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: vegtype real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy,rel_hum @@ -204,8 +202,8 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & chem(i,k,j,p_smoke)=1.e-16 END IF - aod3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) - aod3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) + ext3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) + ext3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) enddo enddo enddo @@ -213,8 +211,8 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & IF ( ktau<2000 .and. dbg_opt ) then WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) - WRITE(*,*) 'add_emis_burn: aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) ',aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) - WRITE(*,*) 'add_emis_burn: aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) ',aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) ',ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) ',ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) END IF ! CASE DEFAULT diff --git a/physics/smoke/module_plumerise1.F90 b/physics/smoke/module_plumerise1.F90 index 47bb4e74a3..e03e60bc23 100755 --- a/physics/smoke/module_plumerise1.F90 +++ b/physics/smoke/module_plumerise1.F90 @@ -3,7 +3,6 @@ module module_plumerise1 - use rrfs_smoke_data use machine , only : kind_phys real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) !- Implementing the fire radiative power (FRP) methodology for biomass burning @@ -35,7 +34,7 @@ module module_plumerise1 ! 'aggr' /) ! grassland CONTAINS -subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & +subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & z_at_w,z,ktau,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags @@ -49,7 +48,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & USE module_zero_plumegen_coms USE module_smoke_plumerise IMPLICIT NONE - type(smoke_data), intent(inout) :: data REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise @@ -98,7 +96,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! write(0,*)'plumerise' ! RAR: -! if (config_flags%biomass_burn_opt == BIOMASSB_SMOKE) then ! do j=jts,jte: ! do i=its,ite ! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) @@ -120,7 +117,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu WRITE(*,*) 'module_plumerise1: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) - END IF + END IF !endif ! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated @@ -151,7 +148,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! RAR: new FRP based approach !check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise ! Haiqin: plumerise_flag is added to the namelist options -!check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise +check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise do j=jts,jte do i=its,ite ! k_min(i,j)=0 @@ -185,7 +182,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & END IF ! RAR: the plume rise calculation step: - CALL plumerise(data,kte,1,1,1,1,1,1, & + CALL plumerise(kte,1,1,1,1,1,1, & !firesize,mean_fct, & !num_ebu, eburn_in, eburn_out, & u_in, v_in, w_in, theta_in ,pi_in, & @@ -213,7 +210,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & enddo enddo -! ENDIF check_pl + ENDIF check_pl end subroutine ebu_driver diff --git a/physics/smoke/module_smoke_plumerise.F90 b/physics/smoke/module_smoke_plumerise.F90 index 247b09f923..d1f30e57e3 100755 --- a/physics/smoke/module_smoke_plumerise.F90 +++ b/physics/smoke/module_smoke_plumerise.F90 @@ -14,8 +14,6 @@ module module_smoke_plumerise use machine , only : kind_phys - use rrfs_smoke_data - use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & !tropical_forest, boreal_forest, savannah, grassland, & wind_eff @@ -26,7 +24,7 @@ module module_smoke_plumerise CONTAINS ! RAR: - subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & + subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & @@ -34,7 +32,6 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & cpor, errmsg, errflg ) implicit none - type(smoke_data), intent(inout) :: data LOGICAL, INTENT (IN) :: dbg_opt diff --git a/physics/smoke/module_wetdep_ls.F90 b/physics/smoke/module_wetdep_ls.F90 new file mode 100755 index 0000000000..87212920bd --- /dev/null +++ b/physics/smoke/module_wetdep_ls.F90 @@ -0,0 +1,79 @@ +!>\file module_wetdep_ls.F90 +!! This file contains aerosol wet deposition module. + +module module_wetdep_ls + use machine , only : kind_phys + use rrfs_smoke_config, only : p_qc, alpha => wetdep_ls_alpha + +contains +subroutine wetdep_ls(dt,var,rain,moist, & + rho,nchem,num_moist,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none + + integer, intent(in) :: nchem, num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys), intent(in) :: dt + real(kind_phys), dimension( ims:ime, kms:kme, jms:jme, num_moist),intent(in) :: moist + real(kind_phys), dimension( ims:ime, kms:kme, jms:jme),intent(in) :: rho,dz8w,vvel + real(kind_phys), dimension( ims:ime, kms:kme, jms:jme,1:nchem),intent(inout) :: var + real(kind_phys), dimension( ims:ime, jms:jme),intent(in) :: rain + real(kind_phys), dimension( its:ite, jts:jte) :: var_sum,var_rmv + real(kind_phys), dimension( its:ite, kts:kte, jts:jte) :: var_rmvl + real(kind_phys), dimension( its:ite, jts:jte) :: frc,var_sum_clw,rain_clw + real(kind_phys) :: dvar,factor,clsum + integer :: nv,i,j,k,km,kb,kbeg + !real(kind_phys), parameter :: alpha = .5 ! scavenging factor + + + do nv=1,nchem + do i=its,ite + do j=jts,jte + var_sum_clw(i,j)=0. + var_sum(i,j)=0. + var_rmvl(i,:,j)=0. + frc(i,j)=0. + rain_clw(i,j)=0. + if(rain(i,j).gt.1.e-10)then +! convert rain back to rate +! + rain_clw(i,j)=rain(i,j)/dt +! total cloud water +! + do k=1,kte-1 + dvar=max(0.,moist(i,k,j,p_qc)*rho(i,k,j)*vvel(i,k,j)*dz8w(i,k,j)) + var_sum_clw(i,j)=var_sum_clw(i,j)+dvar + var_sum(i,j)=var_sum(i,j)+var(i,k,j,nv)*rho(i,k,j) + enddo + if(var_sum(i,j).gt.1.e-10 .and. var_sum_clw(i,j).gt.1.e-10 ) then +! assuming that frc is onstant, it is my conversion factor +! (just like in convec. parameterization) + frc(i,j)=rain_clw(i,j)/var_sum_clw(i,j) + frc(i,j)=max(1.e-6,min(frc(i,j),.005)) + endif + endif + enddo + enddo +! +! get rid of it +! + do i=its,ite + do j=jts,jte + if(rain(i,j).gt.1.e-10 .and. var_sum(i,j).gt.1.e-10 .and. var_sum_clw(i,j).gt.1.e-10)then + do k=kts,kte-2 + if(var(i,k,j,nv).gt.1.e-16 .and. moist(i,k,j,p_qc).gt.0.)then + factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) + dvar=alpha*factor/(1+factor)*var(i,k,j,nv) + var(i,k,j,nv)=max(1.e-16,var(i,k,j,nv)-dvar) + endif + enddo + endif + enddo + enddo + enddo ! nv +end subroutine wetdep_ls +end module module_wetdep_ls diff --git a/physics/smoke/rrfs_smoke_config.F90 b/physics/smoke/rrfs_smoke_config.F90 index 43b3aee144..6adac1c6bb 100755 --- a/physics/smoke/rrfs_smoke_config.F90 +++ b/physics/smoke/rrfs_smoke_config.F90 @@ -16,59 +16,29 @@ module rrfs_smoke_config !-- constant paramters real(kind=kind_phys), parameter :: epsilc = 1.e-12 - !-- chemistyr module configurations + !-- aerosol module configurations integer :: chem_opt = 1 integer :: kemit = 1 integer :: dust_opt = 5 - integer :: dmsemis_opt = 1 integer :: seas_opt = 2 - integer :: biomass_burn_opt=1 logical :: do_plumerise = .true. integer :: addsmoke_flag = 1 integer :: plumerisefire_frq=60 ! Let's add to the namelist - integer :: chem_conv_tr = 0 - integer :: aer_ra_feedback=1 !0 - integer :: aer_ra_frq = 60 integer :: wetdep_ls_opt = 1 integer :: drydep_opt = 1 logical :: bb_dcycle = .false. logical :: smoke_forecast = .false. logical :: aero_ind_fdb = .false. logical :: dbg_opt = .true. - - real(kind=kind_phys), parameter :: depo_fact=0. - integer, parameter :: CHEM_OPT_GOCART= 1 - INTEGER, PARAMETER :: gocartracm_kpp = 301 - integer, parameter :: chem_tune_tracers = 20 - integer, parameter :: DUST_OPT_NONE = 0 - integer, parameter :: SEAS_OPT_NONE = 0 - ! -- DMS emissions - integer, parameter :: DMSE_OPT_NONE = 0 - integer, parameter :: DMSE_OPT_ENABLE = 1 - ! -- subgrid convective transport - integer, parameter :: CTRA_OPT_NONE = 0 - integer, parameter :: CTRA_OPT_GRELL = 2 - ! -- large scale wet deposition - integer, parameter :: WDLS_OPT_NONE = 0 - integer, parameter :: WDLS_OPT_GSD = 1 - integer, parameter :: WDLS_OPT_NGAC = 2 + real(kind_phys) :: wetdep_ls_alpha = .5 ! scavenging factor ! -- + integer, parameter :: CHEM_OPT_GOCART= 1 integer, parameter :: call_chemistry = 1 integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 - integer, parameter :: num_emis_ant = 7 - integer, parameter :: SEAS_OPT_DEFAULT = 1 - - integer, parameter :: DUST_OPT_GOCART = 1 - integer, parameter :: DUST_OPT_AFWA = 3 integer, parameter :: DUST_OPT_FENGSHA = 5 - ! -- biomass burning emissions - integer, parameter :: BURN_OPT_ENABLE = 1 - integer, parameter :: FIRE_OPT_MODIS = 1 - integer, parameter :: FIRE_OPT_GBBEPx = 2 - ! -- hydrometeors integer, parameter :: p_qv=1 integer, parameter :: p_qc=2 @@ -81,8 +51,6 @@ module rrfs_smoke_config integer :: numgas = 0 - real(kind=kind_phys) :: wetdep_ls_alpha(chem_tune_tracers)=-999. - !-- tracers integer, parameter :: p_so2=1 integer, parameter :: p_sulf=2 diff --git a/physics/smoke/rrfs_smoke_data.F90 b/physics/smoke/rrfs_smoke_data.F90 deleted file mode 100755 index cb9cc25e66..0000000000 --- a/physics/smoke/rrfs_smoke_data.F90 +++ /dev/null @@ -1,651 +0,0 @@ -!>\file rrfs_smoke_data.F90 -!! This file contains data for the RRFS-Smoke modules. - -module rrfs_smoke_data - use machine , only : kind_phys - implicit none - INTEGER, PARAMETER :: dep_seasons = 5 - INTEGER, PARAMETER :: nlu = 25 - - type wesely_pft - integer :: npft - integer :: months - INTEGER, pointer :: seasonal_wes(:,:,:,:) => NULL() - contains - final :: wesely_pft_destructor - end type wesely_pft - - interface wesely_pft - procedure :: wesely_pft_constructor - end interface wesely_pft - -!-------------------------------------------------- -! many of these parameters will depend on the RADM mechanism! -! if you change it, lets talk about it and get it done!!! -!-------------------------------------------------- - - REAL(kind_phys), parameter :: small_value = 1.e-36 - REAL(kind_phys), parameter :: large_value = 1.e36 - -!-------------------------------------------------- -! following currently hardwired to USGS -!-------------------------------------------------- - integer, parameter :: isice_temp = 24 - integer, parameter :: iswater_temp = 16 - integer, parameter :: wrf2mz_lt_map(nlu) = (/ 1, 2, 2, 2, 2, & - 4, 3, 3, 3, 3, & - 4, 5, 4, 5, 6, & - 7, 9, 6, 8, 9, & - 6, 6, 8, 0, 0 /) - real(kind_phys), parameter :: wh2o = 18.0153 - real(kind_phys), parameter :: wpan = 121.04793 - real(kind_phys), PARAMETER :: KARMAN=0.4 - INTEGER, parameter :: luse2usgs(21) = (/14,13,12,11,15,8,9,10,10,7, & - 17,4,1,5,24,19,16,21,22,23,16 /) - character(len=4), parameter :: mminlu = 'USGS' - - ! integer, parameter :: pan_seasons = 5 - ! integer, parameter :: pan_lands = 11 - - type smoke_data - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Taken from dep_simple_mod - INTEGER :: ixxxlu(nlu) - REAL(KIND_PHYS) :: kpart(nlu) - REAL(KIND_PHYS) :: rac(nlu,dep_seasons), rclo(nlu,dep_seasons), rcls(nlu,dep_seasons) - REAL(KIND_PHYS) :: rgso(nlu,dep_seasons), rgss(nlu,dep_seasons) - REAL(KIND_PHYS) :: ri(nlu,dep_seasons), rlu(nlu,dep_seasons) - ! REAL(KIND_PHYS) :: ri_pan(pan_seasons,pan_lands) - ! never used: real(kind_phys) :: c0_pan(pan_lands) - ! never used: real(kind_phys) :: k_pan (pan_lands) - - ! never used: integer :: month - REAL(KIND_PHYS) :: dratio(1000), hstar(1000), hstar4(1000) - REAL(KIND_PHYS) :: f0(1000), dhr(1000), scpr23(1000) - - ! Note: scpr23 is only read, never written - - ! never used: type(wesely_pft) :: seasonal_pft - - ! never used: logical, pointer :: is_aerosol(:) => NULL() - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Taken from dep_wet_ls_mod - real(kind_phys), dimension(:), pointer :: alpha => NULL() - contains - final :: smoke_data_destructor - procedure :: dep_init - end type smoke_data - - interface smoke_data - procedure :: smoke_data_constructor - end interface smoke_data - - type(smoke_data), target, private :: private_thread_data - logical, private :: rrfs_smoke_data_initialized = .false. - - !$OMP THREADPRIVATE(private_thread_data) - !$OMP THREADPRIVATE(rrfs_smoke_data_initialized) - -contains - - function get_thread_smoke_data() result(data) - implicit none - class(smoke_data), pointer :: data - if(.not. rrfs_smoke_data_initialized) then - private_thread_data = smoke_data() - rrfs_smoke_data_initialized = .true. - endif - data => private_thread_data - end function get_thread_smoke_data - - subroutine wesely_pft_destructor(this) - implicit none - type(wesely_pft) :: this - if(associated(this%seasonal_wes)) then - deallocate(this%seasonal_wes) - nullify(this%seasonal_wes) - endif - end subroutine wesely_pft_destructor - - function wesely_pft_constructor() result(this) - implicit none - class(wesely_pft), pointer :: this - nullify(this%seasonal_wes) - end function wesely_pft_constructor - - function smoke_data_constructor() result(this) - implicit none - type(smoke_data) :: this - ! These are never used: - ! this%c0_pan = (/ 0.000, 0.006, 0.002, 0.009, 0.015, & - ! 0.006, 0.000, 0.000, 0.000, 0.002, 0.002 /) - ! this%k_pan = (/ 0.000, 0.010, 0.005, 0.004, 0.003, & - ! 0.005, 0.000, 0.000, 0.000, 0.075, 0.002 /) - ! this%month = 0 - ! this%seasonal_pft = wesely_pft() - ! nullify(this%is_aerosol) - nullify(this%alpha) - ! This is not called in the original non-thread-safe code: - ! call this%dep_init() - end function smoke_data_constructor - - subroutine smoke_data_destructor(this) - implicit none - type(smoke_data) :: this - if(associated(this%alpha)) then - deallocate(this%alpha) - nullify(this%alpha) - endif - ! Never used: - ! if(associated(this%is_aerosol)) then - ! deallocate(this%is_aerosol) - ! nullify(this%is_aerosolo) - ! endif - end subroutine smoke_data_destructor - - -! SUBROUTINE dep_init( id, numgas, mminlu_loc, & -! ips, ipe, jps, jpe, ide, jde ) - SUBROUTINE dep_init(this,errmsg,errflg) - ! Lifted out of dep_simple_mod, this initializes - ! member variables that were module variables in - ! that module. -!-- - implicit none - class(smoke_data) :: this - character(*), intent(inout) :: errmsg - integer, intent(inout) :: errflg - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - ! Unused: - ! integer, intent(in) :: numgas - ! integer, intent(in) :: ips, ipe, jps, jpe - ! integer, intent(in) :: ide, jde - ! mmin_lu_loc had no definition, but is also unused - -!-------------------------------------------------- -! .. Local Scalars -!-------------------------------------------------- - INTEGER :: iland, iseason, l - integer :: iprt - integer :: astat - integer :: ncid - integer :: dimid - integer :: varid - integer :: cpos, slen - integer :: lon_e, lat_e - integer :: iend, jend - integer :: chem_opt - integer, allocatable :: input_wes_seasonal(:,:,:,:) - REAL(KIND_PHYS) :: sc - character(len=128) :: err_msg - character(len=128) :: filename - character(len=3) :: id_num -!-------------------------------------------------- -! .. Local Arrays -!-------------------------------------------------- - REAL(KIND_PHYS) :: dat1(nlu,dep_seasons), dat2(nlu,dep_seasons), & - dat3(nlu,dep_seasons), dat4(nlu,dep_seasons), & - dat5(nlu,dep_seasons), dat6(nlu,dep_seasons), & - dat7(nlu,dep_seasons) - ! REAL(KIND_PHYS) :: dat8(pan_seasons,pan_lands) - chem_opt = chem_opt - -!-------------------------------------------------- -! .. Data Statements .. -! THIS%RI for stomatal resistance -! data ((this%ri(ILAND,ISEASON),ILAND=1,nlu),ISEASON=1,dep_seasons)/0.10E+11, & - DATA ((dat1(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.60E+02, 0.60E+02, 0.60E+02, 0.60E+02, 0.70E+02, 0.12E+03, & - 0.12E+03, 0.12E+03, 0.12E+03, 0.70E+02, 0.13E+03, 0.70E+02, & - 0.13E+03, 0.10E+03, 0.10E+11, 0.80E+02, 0.10E+03, 0.10E+11, & - 0.80E+02, 0.10E+03, 0.10E+03, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, 0.10E+11, & - 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, & - 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, & - 0.10E+11, 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, & - 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.70E+02, 0.40E+03, 0.80E+03, 0.10E+11, & - 0.10E+11, 0.80E+03, 0.10E+11, 0.10E+11, 0.80E+03, 0.80E+03, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.12E+03, & - 0.12E+03, 0.12E+03, 0.14E+03, 0.24E+03, 0.24E+03, 0.24E+03, & - 0.12E+03, 0.14E+03, 0.25E+03, 0.70E+02, 0.25E+03, 0.19E+03, & - 0.10E+11, 0.16E+03, 0.19E+03, 0.10E+11, 0.16E+03, 0.19E+03, & - 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ -! .. - IF (nlu/=25) THEN - errmsg='number of land use classifications not correct ' - errflg=1 - return - END IF - IF (dep_seasons/=5) THEN - errmsg='number of dep_seasons not correct ' - errflg=1 - return - END IF - -! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF -! M. L. WESELY, ATMOSPHERIC ENVIRONMENT 23 (1989) 1293-1304 - -! Seasonal categories: -! 1: midsummer with lush vegetation -! 2: autumn with unharvested cropland -! 3: late autumn with frost, no snow -! 4: winter, snow on ground and subfreezing -! 5: transitional spring with partially green short annuals - -! Land use types: -! USGS type Wesely type -! 1: Urban and built-up land 1 -! 2: Dryland cropland and pasture 2 -! 3: Irrigated cropland and pasture 2 -! 4: Mix. dry/irrg. cropland and pasture 2 -! 5: Cropland/grassland mosaic 2 -! 6: Cropland/woodland mosaic 4 -! 7: Grassland 3 -! 8: Shrubland 3 -! 9: Mixed shrubland/grassland 3 -! 10: Savanna 3, always summer -! 11: Deciduous broadleaf forest 4 -! 12: Deciduous needleleaf forest 5, autumn and winter modi -! 13: Evergreen broadleaf forest 4, always summer -! 14: Evergreen needleleaf forest 5 -! 15: Mixed Forest 6 -! 16: Water Bodies 7 -! 17: Herbaceous wetland 9 -! 18: Wooded wetland 6 -! 19: Barren or sparsely vegetated 8 -! 20: Herbaceous Tundra 9 -! 21: Wooded Tundra 6 -! 22: Mixed Tundra 6 -! 23: Bare Ground Tundra 8 -! 24: Snow or Ice -, always winter -! 25: No data 8 - - -! Order of data: -! | -! | seasonal category -! \|/ -! ---> landuse type -! 1 2 3 4 5 6 7 8 9 -! THIS%RLU for outer surfaces in the upper canopy - DO iseason = 1, dep_seasons - this%ri(1:nlu,iseason) = dat1(1:nlu,iseason) - END DO -! data ((this%rlu(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & - DATA ((dat2(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & - 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & - 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, & - 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & - 0.90E+04, 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, & - 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.20E+04, 0.60E+04, 0.90E+04, 0.10E+11, & - 0.90E+04, 0.90E+04, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & - 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & - 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & - 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & - 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ - DO iseason = 1, dep_seasons - this%rlu(1:nlu,iseason) = dat2(1:nlu,iseason) - END DO -! THIS%RAC for transfer that depends on canopy height and density -! data ((this%rac(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+03, & - DATA ((dat3(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+04, 0.10E+03, & - 0.10E+03, 0.10E+03, 0.10E+03, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.00E+00, 0.30E+03, 0.20E+04, 0.00E+00, & - 0.30E+03, 0.20E+04, 0.20E+04, 0.00E+00, 0.00E+00, 0.00E+00, & - 0.10E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+04, & - 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.15E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.17E+04, 0.00E+00, 0.20E+03, 0.17E+04, & - 0.00E+00, 0.20E+03, 0.17E+04, 0.17E+04, 0.00E+00, 0.00E+00, & - 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & - 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+04, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, 0.10E+03, & - 0.15E+04, 0.00E+00, 0.10E+03, 0.15E+04, 0.15E+04, 0.00E+00, & - 0.00E+00, 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, & - 0.10E+02, 0.10E+04, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & - 0.10E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, & - 0.50E+02, 0.15E+04, 0.00E+00, 0.50E+02, 0.15E+04, 0.15E+04, & - 0.00E+00, 0.00E+00, 0.00E+00, 0.10E+03, 0.50E+02, 0.50E+02, & - 0.50E+02, 0.50E+02, 0.12E+04, 0.80E+02, 0.80E+02, 0.80E+02, & - 0.10E+03, 0.12E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, & - 0.00E+00, 0.20E+03, 0.15E+04, 0.00E+00, 0.20E+03, 0.15E+04, & - 0.15E+04, 0.00E+00, 0.00E+00, 0.00E+00/ - DO iseason = 1, dep_seasons - this%rac(1:nlu,iseason) = dat3(1:nlu,iseason) - END DO -! THIS%RGSS for ground surface SO2 -! data ((this%rgss(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.40E+03, & - DATA ((dat4(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.40E+03, & - 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, & - 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, & - 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, 0.10E+04, & - 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+04, & - 0.40E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.50E+03, & - 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, & - 0.50E+03, 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, & - 0.10E+04, 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, & - 0.10E+04, 0.40E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & - 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, & - 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, 0.10E+01, 0.10E+01, & - 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, 0.20E+03, 0.10E+04, & - 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & - 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & - 0.10E+03, 0.10E+03, 0.50E+03, 0.10E+03, 0.10E+03, 0.10E+01, & - 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, & - 0.10E+04, 0.10E+03, 0.10E+04, 0.50E+03, 0.15E+03, 0.15E+03, & - 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, & - 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, & - 0.10E+01, 0.10E+01, 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, & - 0.20E+03, 0.10E+04, 0.10E+03, 0.10E+04/ - DO iseason = 1, dep_seasons - this%rgss(1:nlu,iseason) = dat4(1:nlu,iseason) - END DO -! THIS%RGSO for ground surface O3 -! data ((this%rgso(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.30E+03, & - DATA ((dat5(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.30E+03, & - 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, & - 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03, & - 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.80E+03, 0.30E+03, & - 0.40E+03, 0.80E+03, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, & - 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, & - 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, & - 0.35E+04, 0.40E+03, 0.60E+03, 0.35E+04, 0.35E+04, 0.35E+04, & - 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, & - 0.35E+04, 0.35E+04, 0.20E+03, 0.35E+04, 0.35E+04, 0.20E+04, & - 0.35E+04, 0.35E+04, 0.40E+03, 0.35E+04, 0.35E+04, 0.35E+04, & - 0.40E+03, 0.35E+04, 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, & - 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, & - 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, & - 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03/ - DO iseason = 1, dep_seasons - this%rgso(1:nlu,iseason) = dat5(1:nlu,iseason) - END DO -! THIS%RCLS for exposed surfaces in the lower canopy SO2 -! data ((this%rcls(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & - DATA ((dat6(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & - 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & - 0.20E+04, 0.20E+04, 0.40E+04, 0.10E+11, 0.90E+04, 0.40E+04, & - 0.10E+11, 0.90E+04, 0.40E+04, 0.40E+04, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & - 0.90E+04, 0.20E+04, 0.30E+04, 0.60E+04, 0.10E+11, 0.90E+04, & - 0.60E+04, 0.10E+11, 0.90E+04, 0.60E+04, 0.60E+04, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.90E+04, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.90E+04, 0.90E+04, 0.20E+04, 0.20E+03, 0.40E+03, 0.10E+11, & - 0.90E+04, 0.40E+03, 0.10E+11, 0.90E+04, 0.40E+03, 0.40E+03, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & - 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & - 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & - 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & - 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ - DO iseason = 1, dep_seasons - this%rcls(1:nlu,iseason) = dat6(1:nlu,iseason) - END DO -! THIS%RCLO for exposed surfaces in the lower canopy O3 -! data ((this%rclo(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & - DATA ((dat7(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+11, & - 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, & - 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, 0.40E+03, & - 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.40E+03, 0.60E+03, & - 0.10E+11, 0.40E+03, 0.60E+03, 0.60E+03, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, & - 0.40E+03, 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.80E+03, & - 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.40E+03, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.40E+03, 0.40E+03, 0.10E+04, 0.15E+04, 0.60E+03, 0.10E+11, & - 0.80E+03, 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.10E+04, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, & - 0.10E+04, 0.50E+03, 0.15E+04, 0.10E+04, 0.15E+04, 0.70E+03, & - 0.10E+11, 0.60E+03, 0.70E+03, 0.10E+11, 0.60E+03, 0.70E+03, & - 0.70E+03, 0.10E+11, 0.10E+11, 0.10E+11/ - - DO iseason = 1, dep_seasons - this%rclo(1:nlu,iseason) = dat7(1:nlu,iseason) - END DO - - ! data ((dat8(iseason,iland),iseason=1,pan_seasons),iland=1,pan_lands) / & - ! 1.e36, 60., 120., 70., 130., 100.,1.e36,1.e36, 80., 100., 150., & - ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & - ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & - ! 1.e36,1.e36,1.e36,1.e36, 400., 800.,1.e36,1.e36,1.e36,1.e36,1.e36, & - ! 1.e36, 120., 240., 140., 250., 190.,1.e36,1.e36, 160., 200., 300. / - ! this%ri_pan(:,:) = dat8(:,:) - -!-------------------------------------------------- -! Initialize parameters -!-------------------------------------------------- - this%hstar = 0. - this%hstar4 = 0. - this%dhr = 0. - this%f0 = 0. - this%dratio = 1.0 ! FIXME: IS THIS RIGHT? - this%scpr23 = 1.0 ! FIXME: IS THIS RIGHT? - -!-------------------------------------------------- -! HENRY''S LAW COEFFICIENTS -! Effective Henry''s law coefficient at pH 7 -! [KH298]=mole/(l atm) -!-------------------------------------------------- - -! DATA FOR AEROSOL PARTICLE DEPOSITION FOR THE MODEL OF -! J. W. ERISMAN, A. VAN PUL AND P. WYERS -! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 - -! vd = (u* / k) * CORRECTION FACTORS - -! CONSTANT K FOR LANDUSE TYPES: -! urban and built-up land - this%kpart(1) = 500. -! dryland cropland and pasture - this%kpart(2) = 500. -! irrigated cropland and pasture - this%kpart(3) = 500. -! mixed dryland/irrigated cropland and past - this%kpart(4) = 500. -! cropland/grassland mosaic - this%kpart(5) = 500. -! cropland/woodland mosaic - this%kpart(6) = 100. -! grassland - this%kpart(7) = 500. -! shrubland - this%kpart(8) = 500. -! mixed shrubland/grassland - this%kpart(9) = 500. -! savanna - this%kpart(10) = 500. -! deciduous broadleaf forest - this%kpart(11) = 100. -! deciduous needleleaf forest - this%kpart(12) = 100. -! evergreen broadleaf forest - this%kpart(13) = 100. -! evergreen needleleaf forest - this%kpart(14) = 100. -! mixed forest - this%kpart(15) = 100. -! water bodies - this%kpart(16) = 500. -! herbaceous wetland - this%kpart(17) = 500. -! wooded wetland - this%kpart(18) = 500. -! barren or sparsely vegetated - this%kpart(19) = 500. -! herbaceous tundra - this%kpart(20) = 500. -! wooded tundra - this%kpart(21) = 100. -! mixed tundra - this%kpart(22) = 500. -! bare ground tundra - this%kpart(23) = 500. -! snow or ice - this%kpart(24) = 500. -! Comments: - this%kpart(25) = 500. -! Erisman et al. (1994) give -! k = 500 for low vegetation and k = 100 for forests. - -! For desert k = 500 is taken according to measurements -! on bare soil by -! J. Fontan, A. Lopez, E. Lamaud and A. Druilhet (1997) -! Vertical Flux Measurements of the Submicronic Aerosol Particles -! and Parametrisation of the Dry Deposition Velocity -! in: Biosphere-Atmosphere Exchange of Pollutants -! and Trace Substances -! Editor: S. Slanina. Springer-Verlag Berlin, Heidelberg, 1997 -! pp. 381-390 - -! For coniferous forest the Erisman value of k = 100 is taken. -! Measurements of Erisman et al. (1997) in a coniferous forest -! in the Netherlands, lead to values of k between 20 and 38 -! (Atmospheric Environment 31 (1997), 321-332). -! However, these high values of vd may be reached during -! instable cases. The eddy correlation measurements -! of Gallagher et al. (1997) made during the same experiment -! show for stable cases (L>0) values of k between 200 and 250 -! at minimum (Atmospheric Environment 31 (1997), 359-373). -! Fontan et al. (1997) found k = 250 in a forest -! of maritime pine in southwestern France. - -! For gras, model calculations of Davidson et al. support -! the value of 500. -! C. I. Davidson, J. M. Miller and M. A. Pleskov -! The Influence of Surface Structure on Predicted Particles -! Dry Deposition to Natural Gras Canopies -! Water, Air, and Soil Pollution 18 (1982) 25-43 - -! Snow covered surface: The experiment of Ibrahim et al. (1983) -! gives k = 436 for 0.7 um diameter particles. -! The deposition velocity of Milford and Davidson (1987) -! gives k = 154 for continental sulfate aerosol. -! M. Ibrahim, L. A. Barrie and F. Fanaki -! Atmospheric Environment 17 (1983), 781-788 - -! J. B. Milford and C. I. Davidson -! The Sizes of Particulate Sulfate and Nitrate in the Atmosphere -! - A Review -! JAPCA 37 (1987), 125-134 -! no data -! WRITE (0,*) ' return from rcread ' -! ********************************************************* - -! Simplified landuse scheme for deposition and biogenic emission -! subroutines -! (ISWATER and ISICE are already defined elsewhere, -! therefore water and ice are not considered here) - -! 1 urban or bare soil -! 2 agricultural -! 3 grassland -! 4 deciduous forest -! 5 coniferous and mixed forest -! 6 other natural landuse categories - - - IF (mminlu=='OLD ') THEN - this%ixxxlu(1) = 1 - this%ixxxlu(2) = 2 - this%ixxxlu(3) = 3 - this%ixxxlu(4) = 4 - this%ixxxlu(5) = 5 - this%ixxxlu(6) = 5 - this%ixxxlu(7) = 0 - this%ixxxlu(8) = 6 - this%ixxxlu(9) = 1 - this%ixxxlu(10) = 6 - this%ixxxlu(11) = 0 - this%ixxxlu(12) = 4 - this%ixxxlu(13) = 6 - END IF - IF (mminlu=='USGS') THEN - this%ixxxlu(1) = 1 - this%ixxxlu(2) = 2 - this%ixxxlu(3) = 2 - this%ixxxlu(4) = 2 - this%ixxxlu(5) = 2 - this%ixxxlu(6) = 4 - this%ixxxlu(7) = 3 - this%ixxxlu(8) = 6 - this%ixxxlu(9) = 3 - this%ixxxlu(10) = 6 - this%ixxxlu(11) = 4 - this%ixxxlu(12) = 5 - this%ixxxlu(13) = 4 - this%ixxxlu(14) = 5 - this%ixxxlu(15) = 5 - this%ixxxlu(16) = 0 - this%ixxxlu(17) = 6 - this%ixxxlu(18) = 4 - this%ixxxlu(19) = 1 - this%ixxxlu(20) = 6 - this%ixxxlu(21) = 4 - this%ixxxlu(22) = 6 - this%ixxxlu(23) = 1 - this%ixxxlu(24) = 0 - this%ixxxlu(25) = 1 - END IF - IF (mminlu=='SiB ') THEN - this%ixxxlu(1) = 4 - this%ixxxlu(2) = 4 - this%ixxxlu(3) = 4 - this%ixxxlu(4) = 5 - this%ixxxlu(5) = 5 - this%ixxxlu(6) = 6 - this%ixxxlu(7) = 3 - this%ixxxlu(8) = 6 - this%ixxxlu(9) = 6 - this%ixxxlu(10) = 6 - this%ixxxlu(11) = 1 - this%ixxxlu(12) = 2 - this%ixxxlu(13) = 6 - this%ixxxlu(14) = 1 - this%ixxxlu(15) = 0 - this%ixxxlu(16) = 0 - this%ixxxlu(17) = 1 - END IF - - END SUBROUTINE dep_init -end module rrfs_smoke_data diff --git a/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 old mode 100644 new mode 100755 index 1fd7a2d3fa..dc52f6a3fb --- a/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -1,14 +1,13 @@ !>\file rrfs_smoke_lsdep_wrapper.F90 !! This file is RRFS-smoke large-scale wet deposition wrapper with CCPP -!! Haiqin.Li@noaa.gov 04/2021 +!! Haiqin.Li@noaa.gov 08/2022 module rrfs_smoke_lsdep_wrapper use machine , only : kind_phys use rrfs_smoke_config - use dep_wet_ls_mod + use module_wetdep_ls use dust_data_mod - use rrfs_smoke_data implicit none @@ -29,16 +28,16 @@ module rrfs_smoke_lsdep_wrapper subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & rain_cpl, rainc_cpl, g, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & - w, dqdt, ntrac,ntsmoke,ntdust, & - gq0,qgrs,wetdep_ls_opt_in, & + w, dqdt, ntrac,ntsmoke,ntdust,nchem,gq0, & + wetdep_ls_opt_in,wetdep_ls_alpha_in, rrfs_sd, & errmsg,errflg) implicit none integer, intent(in) :: im,kte,kme,ktau - integer, intent(in) :: ntrac,ntsmoke,ntdust - real(kind_phys),intent(in) :: dt,g + integer, intent(in) :: ntrac,ntsmoke,ntdust,nchem + real(kind_phys),intent(in) :: dt,g,wetdep_ls_alpha_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 @@ -48,8 +47,9 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & us3d, vs3d, spechum, w, dqdt - real(kind_phys), dimension(:,:,:), intent(inout) :: gq0, qgrs + real(kind_phys), dimension(:,:,:), intent(inout) :: gq0 integer, intent(in) :: wetdep_ls_opt_in + logical, intent(in) :: rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -60,25 +60,22 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & !>- vapor & chemistry variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist - real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem - real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: var_rmv + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:nchem ) :: chem integer :: ide, ime, ite, kde real(kind_phys) :: dtstep - real(kind_phys), dimension(1:num_chem) :: ppm2ugkg - - type(smoke_data), pointer :: data !>-- local variables integer :: i, j, jp, k, kp, n - data=>get_thread_smoke_data() - errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + wetdep_ls_opt = wetdep_ls_opt_in + wetdep_ls_alpha = wetdep_ls_alpha_in !print*,'hli wetdep_ls_opt',wetdep_ls_opt ! -- set domain @@ -87,16 +84,6 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & ite=im kde=kte - ! -- volume to mass fraction conversion table (ppm -> ug/kg) - ppm2ugkg = 1._kind_phys - !ppm2ugkg(p_so2 ) = 1.e+03_kind_phys * mw_so2_aer / mwdry - ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry - - ! -- initialize large-sacle wet depostion - if (ktau==1) then - call dep_wet_ls_init(data) - endif - ! -- set control flags ! -- compute accumulated large-scale and convective rainfall since last call @@ -115,69 +102,49 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & !!! !>- get ready for chemistry run - call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + if (wetdep_ls_opt == 1) then + call rrfs_smoke_prep_lsdep(ktau,dtstep, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,dqdti,z_at_w,vvel,g, & ntsmoke,ntdust, & - ntrac,gq0,num_chem, num_moist, & - ppm2ugkg,moist,chem, & + ntrac,gq0,nchem, num_moist, & + moist,chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) ! -- ls wet deposition - select case (wetdep_ls_opt) - case (WDLS_OPT_GSD) - call wetdep_ls(data,dt,chem,rnav,moist,rho_phy,var_rmv, & - num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - case (WDLS_OPT_NGAC) - call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & - num_chem,var_rmv,chem,p_phy,t_phy, & - rho_phy,dqdti,rcav,rnav, g, & - ims,ime, jms,jme, kms,kme) - !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & - ! file=__FILE__, line=__LINE__, rc=rc)) return - case default - ! -- no further option implemented - end select - + call wetdep_ls(dt,chem,rcav,moist, & + rho_phy,nchem,num_moist,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) ! -- put chem stuff back into tracer array - do k=kts,kte + do k=kts,kte do i=its,ite - gq0(i,k,ntsmoke)=ppm2ugkg(p_oc1 ) * max(epsilc,chem(i,k,1,p_oc1)) - gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + gq0(i,k,ntsmoke)=max(epsilc,chem(i,k,1,1)) + gq0(i,k,ntdust )=max(epsilc,chem(i,k,1,2)) enddo - enddo - - do k=kts,kte - do i=its,ite - qgrs(i,k,ntsmoke)=gq0(i,k,ntsmoke) - qgrs(i,k,ntdust )=gq0(i,k,ntdust ) enddo - enddo - + endif ! end subroutine rrfs_smoke_lsdep_wrapper_run !> @} - subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + subroutine rrfs_smoke_prep_lsdep(ktau,dtstep, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,dqdti,z_at_w,vvel,g, & ntsmoke,ntdust, & - ntrac,gq0,num_chem, num_moist, & - ppm2ugkg,moist,chem, & + ntrac,gq0,nchem, num_moist, & + moist,chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) implicit none - type(smoke_data), intent(inout) :: data !Chem input configuration integer, intent(in) :: ktau @@ -192,17 +159,16 @@ subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & !GSD Chem variables - integer,intent(in) :: num_chem, num_moist + integer,intent(in) :: nchem, num_moist integer,intent(in) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, dqdti real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, nchem ), intent(out) :: chem real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w @@ -312,8 +278,8 @@ subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & do k=kms,kte do i=ims,ime - chem(i,k,jts,p_oc1 )=max(epsilc,gq0(i,k,ntsmoke)/ppm2ugkg(p_oc1)) - chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + chem(i,k,jts,1)=max(epsilc,gq0(i,k,ntsmoke)) + chem(i,k,jts,2)=max(epsilc,gq0(i,k,ntdust )) enddo enddo diff --git a/physics/smoke/rrfs_smoke_lsdep_wrapper.meta b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta index 23c71fce8a..dbd1669c96 100755 --- a/physics/smoke/rrfs_smoke_lsdep_wrapper.meta +++ b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_lsdep_wrapper type = scheme - dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 ######################################################################## [ccpp-arg-table] @@ -168,6 +168,13 @@ dimensions = () type = integer intent = in +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical vertically mixed + units = count + dimensions = () + type = integer + intent = in [gq0] standard_name = tracer_concentration_of_new_state long_name = tracer concentration updated by physics @@ -176,14 +183,6 @@ type = real kind = kind_phys intent = inout -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout [wetdep_ls_opt_in] standard_name = control_for_smoke_wet_deposition long_name = rrfs smoke large scale wet deposition option @@ -191,6 +190,21 @@ dimensions = () type = integer intent = in +[wetdep_ls_alpha_in] + standard_name = alpha_for_ls_wet_depoistion + long_name = alpha paramter for ls wet deposition + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/smoke/rrfs_smoke_postpbl.F90 b/physics/smoke/rrfs_smoke_postpbl.F90 index f83aaf7953..93fed46bfc 100755 --- a/physics/smoke/rrfs_smoke_postpbl.F90 +++ b/physics/smoke/rrfs_smoke_postpbl.F90 @@ -15,16 +15,11 @@ module rrfs_smoke_postpbl contains -!>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module -!> \ingroup gsd_chem_group -!! This is the GSD Chem emission driver Module -!! \section arg_table_rrfs_smoke_postpbl_run Argument Table +!> \section arg_table_rrfs_smoke_postpbl_run Argument Table !! \htmlinclude rrfs_smoke_postpbl_run.html !! -!>\section rrfs_smoke_postpbl GSD Chemistry Scheme General Algorithm -!> @{ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & - qgrs, chem3d, errmsg, errflg) + qgrs, chem3d, rrfs_sd, errmsg, errflg) implicit none @@ -35,6 +30,7 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + logical, intent(in) :: rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -44,6 +40,8 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + !--- put smoke stuff back into tracer array do k=kts,kte @@ -53,7 +51,8 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & enddo enddo - end subroutine rrfs_smoke_postpbl_run + return + + end subroutine rrfs_smoke_postpbl_run -!> @} end module rrfs_smoke_postpbl diff --git a/physics/smoke/rrfs_smoke_postpbl.meta b/physics/smoke/rrfs_smoke_postpbl.meta index 99aae69f2f..df841be8cd 100755 --- a/physics/smoke/rrfs_smoke_postpbl.meta +++ b/physics/smoke/rrfs_smoke_postpbl.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrfs_smoke_wrapper + name = rrfs_smoke_postpbl type = scheme - dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 ######################################################################## [ccpp-arg-table] - name = rrfs_smoke_wrapper_run + name = rrfs_smoke_postpbl_run type = scheme [ite] standard_name = horizontal_loop_extent @@ -58,6 +58,13 @@ type = real kind = kind_phys intent = inout +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 index ac32e1ad45..990a2d686f 100755 --- a/physics/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -13,7 +13,6 @@ module rrfs_smoke_wrapper use module_plumerise1 !plume_rise_mod use module_add_emiss_burn use dep_dry_mod - use rrfs_smoke_data implicit none @@ -31,26 +30,27 @@ module rrfs_smoke_wrapper !! !>\section rrfs_smoke_wrapper GSD Chemistry Scheme General Algorithm !> @{ - subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & - u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & - pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & - nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & + subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & + u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & + nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & - ntsmoke, ntdust, imp_physics, imp_physics_thompson, & - nwfa, nifa, emanoc, & - emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & - coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, & - smoke_ext, dust_ext, & - seas_opt_in, dust_opt_in, biomass_burn_opt_in, drydep_opt_in, & - do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + ntsmoke, ntdust, imp_physics, imp_physics_thompson, & + nwfa, nifa, emanoc, & + emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & + coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, wetness, & + smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd, & + dust_alpha_in, dust_gamma_in, & + seas_opt_in, dust_opt_in, drydep_opt_in, & + do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) implicit none integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) - integer, intent(in) :: ntrac, ntsmoke, ntdust + integer, intent(in) :: ntrac, ntsmoke, ntdust, ndvel real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in @@ -79,10 +79,13 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:), intent( out) :: hwp real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa + real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout + real (kind=kind_phys), dimension(:), intent(in) :: wetness integer, intent(in ) :: imp_physics, imp_physics_thompson - integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & + real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in + integer, intent(in) :: seas_opt_in, dust_opt_in, & drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in - logical, intent(in ) :: do_plumerise_in + logical, intent(in ) :: do_plumerise_in, rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -97,7 +100,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas - real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: dry_fall real(kind_phys), dimension(ims:im, jms:jme) :: seashelp integer :: ide, ime, ite, kde, julday @@ -115,22 +117,18 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & fire_hist, peak_hr - real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: aod3d_smoke, aod3d_dust + real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: ext3d_smoke, ext3d_dust integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 real(kind_phys) :: dtstep - logical :: call_plume, scale_fire_emiss + logical :: call_fire !>- optical variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum + real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel !>-- anthropogentic variables -! real(kind_phys), dimension(ims:im, kms:kemit, jms:jme, 1:num_emis_ant) :: emis_ant real(kind_phys), dimension(ims:im) :: emis_anoc - real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ac3, ahno3, anh3, asulf, cor3, h2oai, h2oaj, nu3 - real(kind_phys), dimension(ims:im, jms:jme) :: dep_vel_o3, e_co - real(kind_phys) :: gmt - real(kind_phys), dimension(1:num_chem) :: ppm2ugkg !> -- parameter to caluclate wfa&ifa (m) real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 @@ -151,17 +149,14 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer :: nbegin, nv, nvv integer :: i, j, jp, k, kp, n - type(smoke_data), pointer :: data - - data => get_thread_smoke_data() - errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + !>-- options to turn on/off sea-salt, dust, plume-rising seas_opt = seas_opt_in dust_opt = dust_opt_in - biomass_burn_opt = biomass_burn_opt_in drydep_opt = drydep_opt_in do_plumerise = do_plumerise_in plumerisefire_frq = plumerisefire_frq_in @@ -177,25 +172,14 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ite=im kde=kte - h2oai = 0. - h2oaj = 0. - nu3 = 0. - ac3 = 0. - cor3 = 0. - asulf = 0. - ahno3 = 0. - anh3 = 0. - e_co = 0. - dep_vel_o3 = 0. - min_fplume2 = 0 max_fplume2 = 0 emis_seas = 0. emis_dust = 0. peak_hr = 0. flam_frac = 0. - aod3d_smoke = 0. - aod3d_dust = 0. + ext3d_smoke = 0. + ext3d_dust = 0. rcav = 0. rnav = 0. @@ -203,12 +187,14 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, curr_secs = ktau * dt current_month=jdate(2) current_hour =jdate(5)+1 - gmt = real(idat(5)) + gmt = real(mod(idat(5)+jdate(5),24)) julday = int(julian) - ! -- volume to mass fraction conversion table (ppm -> ug/kg) - ppm2ugkg = 1._kind_phys - ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + do nv=1,ndvel + do i=its,ite + ddvel(i,1,nv)=ddvel_inout(i,nv) + enddo + enddo ! -- compute incremental convective and large-scale rainfall do i=its,ite @@ -220,13 +206,9 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! plumerise frequency in minutes set up by the namelist input - call_plume = (biomass_burn_opt == BURN_OPT_ENABLE) .and. (plumerisefire_frq > 0) - if (call_plume) & - call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) & - .or. (ktau == 2) + call_fire = (do_plumerise .and. (plumerisefire_frq > 0)) + if (call_fire) call_fire = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) .or. (ktau == 2) - !scale_fire_emiss = .false. - ! -- compute accumulated large-scale and convective rainfall since last call if (ktau > 1) then dtstep = call_chemistry * dt @@ -236,7 +218,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- get ready for chemistry run call rrfs_smoke_prep( & - ktau, current_month, current_hour, & + ktau, current_month, current_hour, gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & @@ -247,7 +229,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, t8w,exch_h, & z_at_w,vvel,zmid, & ntrac,gq0, & - num_chem, num_moist, ppm2ugkg, & + num_chem,num_moist, & ntsmoke, ntdust, & moist,chem,plume_frp,ebu_in, & ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & @@ -299,8 +281,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- compute sea-salt - ! -- compute sea salt - if (seas_opt >= SEAS_OPT_DEFAULT) then + ! -- compute sea salt (opt=2) + if (seas_opt == 2) then call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & xland,xlat,xlong,dxy,g,emis_seas,pi, & @@ -310,18 +292,19 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, its,ite, jts,jte, kts,kte) endif - !-- compute dust - select case (dust_opt) - case (DUST_OPT_FENGSHA) + !-- compute dust (opt=5) + if (dust_opt==DUST_OPT_FENGSHA) then ! Set at compile time in dust_data_mod: - call gocart_dust_fengsha_driver(data,dt,chem,rho_phy,smois,p8w,ssm, & + dust_alpha = dust_alpha_in + dust_gamma = dust_gamma_in + call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, & isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & clayf,sandf,rdrag,uthr, & num_emis_dust,num_moist,num_chem,nsoil, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) - end select + end if ! compute wild-fire plumes !-- to add a namelist option to turn on/off plume raising @@ -329,10 +312,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !-- /scratch2/BMC/ap-fc/Ravan/rapid-refresh/WRFV3.9/smoke ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but ! the plumerise is controlled by the namelist option of plumerise_flag - if (call_plume) then + if (call_fire) then ! WRITE(*,*) 'plumerise is called at ktau= ',ktau call ebu_driver ( & - data,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,ktau,g,con_cp,con_rd, & @@ -345,11 +328,11 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then - call add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & + call add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & julday,gmt,xlat,xlong, & ivgtyp, vegfrac, peak_hr, & ! RAR curr_secs,ebu, & - coef_bb_dc,fire_hist,aod3d_smoke,aod3d_dust, & + coef_bb_dc,fire_hist,ext3d_smoke,ext3d_dust, & ! scalar(ims,kms,jms,P_QNWFA),scalar(ims,kms,jms,P_QNIFA), ! & rcav, rnav,swdown,smoke_forecast, & ids,ide, jds,jde, kds,kde, & @@ -360,17 +343,18 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>-- compute dry deposition if (drydep_opt == 1) then - call dry_dep_driver(data,ktau,dt,julday,current_month,t_phy,p_phy, & - moist,p8w,rmol,rri,gmt,t8w,rcav, & - chem,rho_phy,dz8w,exch_h,hfx, & - ivgtyp,tsk,swdown,vegfrac,pbl,ust,znt,zmid,z_at_w, & - xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & - anh3,dry_fall,dep_vel_o3,g, & - e_co,kemit,snowh,numgas, & - num_chem,num_moist, & + call dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) + + do nv=1,ndvel + do i=its,ite + ddvel_inout(i,nv)=ddvel(i,1,nv) + enddo + enddo + else + ddvel_inout(:,:)=0. endif ! WRITE(*,*) 'dry depostion is done at ktau= ',ktau @@ -384,25 +368,24 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !---- diagnostic output of hourly wildfire potential (07/2021) hwp = 0. do i=its,ite - wdgust(i)=1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2) + wdgust(i)=max(1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2),3.) snoweq(i)=max((25.-snow(i)*1000.)/25.,0.) - !hwp(i)=44.09*wdgust(i)**1.82*max(0.,t2m(i)-dpt2m(i))**0.61*max(0.,1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) - hwp(i)=44.09*wdgust(i)**1.82*(t2m(i)-dpt2m(i))**0.61*(1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + hwp(i)=0.237*wdgust(i)**1.11*max(t2m(i)-dpt2m(i),15.)**0.92*((1.-wetness(i))**6.95)*snoweq(i) ! Eric 08/2022 enddo !---- diagnostic output of smoke & dust optical extinction (12/2021) do k=kts,kte do i=its,ite - smoke_ext(i,k) = aod3d_smoke(i,k,1) - dust_ext (i,k) = aod3d_dust (i,k,1) + smoke_ext(i,k) = ext3d_smoke(i,k,1) + dust_ext (i,k) = ext3d_dust (i,k,1) enddo enddo !------------------------------------- !---- put smoke stuff back into tracer array do k=kts,kte do i=its,ite - gq0(i,k,ntsmoke )=ppm2ugkg(p_smoke ) * max(epsilc,chem(i,k,1,p_smoke)) ! - gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + gq0(i,k,ntsmoke )= max(epsilc,chem(i,k,1,p_smoke )) + gq0(i,k,ntdust )= max(epsilc,chem(i,k,1,p_dust_1)) enddo enddo @@ -458,7 +441,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, end subroutine rrfs_smoke_wrapper_run subroutine rrfs_smoke_prep( & - ktau,current_month,current_hour, & + ktau,current_month,current_hour,gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & @@ -469,10 +452,8 @@ subroutine rrfs_smoke_prep( & t8w,exch_h, & z_at_w,vvel,zmid, & ntrac,gq0, & - num_chem, num_moist, ppm2ugkg, & + num_chem, num_moist, & ntsmoke, ntdust, & - !num_emis_ant, & - !emis_ant, & moist,chem,plume_frp,ebu_in, & ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & @@ -488,7 +469,7 @@ subroutine rrfs_smoke_prep( & integer, intent(in) :: nsoil integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp integer, intent(in) :: ntrac - real(kind=kind_phys), intent(in) :: g, pi + real(kind=kind_phys), intent(in) :: g, pi, gmt real(kind=kind_phys), dimension(ims:ime), intent(in) :: & u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & zorl, snow_cpl, pb2d, hf2d @@ -503,15 +484,12 @@ subroutine rrfs_smoke_prep( & !GSD Chem variables - !integer,intent(in) :: num_emis_ant integer,intent(in) :: num_chem, num_moist, ntsmoke, ntdust integer,intent(in) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - !real(kind_phys), dimension(ims:ime, kms:kemit, jms:jme, num_emis_ant), intent(inout) :: emis_ant - real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp @@ -617,11 +595,6 @@ subroutine rrfs_smoke_prep( & enddo enddo - !if (ktau <= 1) then - ! emis_ant = 0. - ! !emis_vol = 0. - !end if - do j=jts,jte jp = j - jts + 1 do i=its,ite @@ -705,7 +678,6 @@ subroutine rrfs_smoke_prep( & enddo enddo - ! -- only used in phtolysis.... do j=jts,jte do i=its,ite t8w(i,1,j)=t_phy(i,1,j) @@ -718,27 +690,25 @@ subroutine rrfs_smoke_prep( & emis_anoc(i) = emi_in(i,1) enddo - ! select case (plumerise_flag) - ! case (FIRE_OPT_GBBEPx) + if (current_hour<=24) then do j=jts,jte do i=its,ite - ebb_smoke_hr(i) = smoke_GBBEPx(i,current_hour,1) ! smoke - frp_hr (i) = smoke_GBBEPx(i,current_hour,2) ! frp - frp_std_hr (i) = smoke_GBBEPx(i,current_hour,3) ! std frp + ebb_smoke_hr(i) = smoke_GBBEPx(i,int(gmt)+1,1) ! smoke + frp_hr (i) = smoke_GBBEPx(i,int(gmt)+1,2) ! frp + frp_std_hr (i) = smoke_GBBEPx(i,int(gmt)+1,3) ! std frp ebu_in (i,j) = ebb_smoke_hr(i) plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) enddo enddo - ! case default - ! end select + endif ! We will add a namelist variable, real :: flam_frac_global do k=kms,kte do i=ims,ime - chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )/ppm2ugkg(p_smoke)) - chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )) enddo enddo diff --git a/physics/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta index ef46b04eaf..8168bf9b40 100755 --- a/physics/smoke/rrfs_smoke_wrapper.meta +++ b/physics/smoke/rrfs_smoke_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_wrapper type = scheme - dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 ######################################################################## [ccpp-arg-table] @@ -551,6 +551,14 @@ type = real kind = kind_phys intent = out +[wetness] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [smoke_ext] standard_name = extinction_coefficient_in_air_due_to_smoke long_name = extinction coefficient in air due to smoke @@ -567,6 +575,44 @@ type = real kind = kind_phys intent = out +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer + intent = in +[ddvel_inout] + standard_name = dry_deposition_velocity_mynn_pbl_transport + long_name = dry deposition velocity by mynn pbl transport + units = m s-1 + dimensions = (horizontal_loop_extent,2) + type = real + kind = kind_phys + intent = inout +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dust_alpha_in] + standard_name = alpha_fengsha_dust_scheme + long_name = alpha paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dust_gamma_in] + standard_name = gamma_fengsha_dust_scheme + long_name = gamma paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [seas_opt_in] standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option @@ -581,13 +627,6 @@ dimensions = () type = integer intent = in -[biomass_burn_opt_in] - standard_name = control_for_smoke_biomass_burn - long_name = rrfs smoke biomass burning option - units = index - dimensions = () - type = integer - intent = in [drydep_opt_in] standard_name = control_for_smoke_dry_deposition long_name = rrfs smoke dry deposition option diff --git a/physics/smoke/seas_mod.F90 b/physics/smoke/seas_mod.F90 index 85c8611564..6d58b65079 100755 --- a/physics/smoke/seas_mod.F90 +++ b/physics/smoke/seas_mod.F90 @@ -13,7 +13,6 @@ module seas_mod implicit none - integer, parameter :: SEAS_OPT_DEFAULT = 1 integer, parameter :: CHEM_OPT_GOCART = 300 integer, parameter :: chem_opt = 300 @@ -22,8 +21,6 @@ module seas_mod private - public :: SEAS_OPT_DEFAULT - public :: gocart_seasalt_driver CONTAINS From 4c355ebe7e916c8341eca59898f33764f8bf9973 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 2 Sep 2022 17:52:03 +0000 Subject: [PATCH 33/50] "Update to use 3 bins for fine dust" --- physics/smoke/dust_fengsha_mod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 index 46ff58a8b9..7f0fc96fb0 100755 --- a/physics/smoke/dust_fengsha_mod.F90 +++ b/physics/smoke/dust_fengsha_mod.F90 @@ -447,6 +447,7 @@ subroutine source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & bems(n) = 1.e+9*dsrc/(dxy*dt1) ! diagnostic (ug/m2/s) !lzhang END DO + tc(1)=tc(1)+tc(2)+tc(3) ! This is just for RRFS-SD. DO NOT use in other models!!! END SUBROUTINE source_dust From 7c9ca8cb7c4deb59a6d72ce043ad73b9de61a1af Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Tue, 6 Sep 2022 15:40:06 +0000 Subject: [PATCH 34/50] "update to correct a typo of dry deposition velocity comments" --- physics/module_bl_mynn.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 9c44ded7a5..31789c98c8 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1054,7 +1054,7 @@ SUBROUTINE mynn_bl_driver( & !initialize smoke/chem arrays (if used): IF ( rrfs_sd .and. mix_chem ) then do ic = 1,ndvel - vd1(ic) = vdep(i,ic) ! dry deposition veolocity + vd1(ic) = vdep(i,ic) ! dry deposition velocity chem1(kts,ic) = chem3d(i,kts,ic) s_awchem1(kts,ic)=0. enddo @@ -1066,7 +1066,7 @@ SUBROUTINE mynn_bl_driver( & enddo ELSE do ic = 1,ndvel - vd1(ic) = 0. ! dry deposition veolocity + vd1(ic) = 0. ! dry deposition velocity chem1(kts,ic) = 0. s_awchem1(kts,ic)=0. enddo From 8e093ce7bf892956953c43e52c4ed26e81435290 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Tue, 6 Sep 2022 23:25:52 +0000 Subject: [PATCH 35/50] "update MYNN following Joe's suggestions" --- physics/module_bl_mynn.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 31789c98c8..d0a6ac16fe 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1052,7 +1052,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF ( rrfs_sd .and. mix_chem ) then + IF ( mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) ! dry deposition velocity chem1(kts,ic) = chem3d(i,kts,ic) @@ -1349,7 +1349,7 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( rrfs_sd .and. mix_chem ) THEN + IF ( mix_chem ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1359,7 +1359,7 @@ SUBROUTINE mynn_bl_driver( & &dfh, & &s_aw1,s_awchem1, & &emis_ant_no(i), & - &frp(i), & + &frp(i), rrfs_sd, & &enh_mix, smoke_dbg ) DO ic = 1,nchem @@ -5251,7 +5251,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & flt, tcd, qcd, & dfh, & s_aw, s_awchem, & - emis_ant_no,frp, & + emis_ant_no, frp, rrfs_sd, & enh_mix, smoke_dbg ) !------------------------------------------------------------------- @@ -5266,7 +5266,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 REAL, INTENT(IN) :: emis_ant_no,frp,pblh - LOGICAL, INTENT(IN) :: enh_mix,smoke_dbg + LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars REAL, DIMENSION(kts:kte) :: dtz @@ -5315,7 +5315,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & ENDDO !Enhanced mixing over fires - IF ( enh_mix ) THEN + IF ( rrfs_sd .and. enh_mix ) THEN kmaxfire = ceiling(log(frp)) DO k=kts+1,kte-1 khdz_old = khdz(k) From 6383c779d765390ba06df5c13982585321c21584 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Thu, 8 Sep 2022 20:28:25 +0000 Subject: [PATCH 36/50] "update to use 2 bins for dust emission" --- physics/smoke/dust_fengsha_mod.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/physics/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 index 7f0fc96fb0..82aec9b7c2 100755 --- a/physics/smoke/dust_fengsha_mod.F90 +++ b/physics/smoke/dust_fengsha_mod.F90 @@ -388,14 +388,15 @@ subroutine source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & ! Set DRY threshold friction velocity to input value u_ts0 = uthres - g = g0*1.0E2 + ! g = g0*1.0E2 + g = g0 emit=0.0 DO n = 1, smx den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) - rhoa = airden*1.0D-3 ! (g cm^-3) - + !rhoa = airden*1.0D-3 ! (g cm^-3) + rhoa = airden call DustEmissionFENGSHA(smois,massfrac(1),massfrac(3), massfrac(2), & erod, R, rhoa, ustar, uthres, alpha, gamma, kvhmax, & g, RHOSOIL, salt) @@ -447,7 +448,7 @@ subroutine source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & bems(n) = 1.e+9*dsrc/(dxy*dt1) ! diagnostic (ug/m2/s) !lzhang END DO - tc(1)=tc(1)+tc(2)+tc(3) ! This is just for RRFS-SD. DO NOT use in other models!!! + tc(1)=tc(1)+tc(2) ! This is just for RRFS-SD. DO NOT use in other models!!! END SUBROUTINE source_dust From 5e8df2d17f3a5ae6bd3134cc61da3a358d48da1a Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Mon, 19 Sep 2022 14:21:03 +0000 Subject: [PATCH 37/50] "following Sam's suggestion to fix a bug for enhanced mixing" --- physics/module_bl_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index d0a6ac16fe..8dce1a7b5f 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -5316,7 +5316,6 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & !Enhanced mixing over fires IF ( rrfs_sd .and. enh_mix ) THEN - kmaxfire = ceiling(log(frp)) DO k=kts+1,kte-1 khdz_old = khdz(k) khdz_back = pblh * 0.15 / dz(k) @@ -5327,6 +5326,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF IF ( frp > frp_threshold ) THEN + kmaxfire = ceiling(log(frp)) khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF From f0e2f0d9c76c5c6378c1a2722a4c33f5355e8cb6 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 22 Sep 2022 20:29:45 +0000 Subject: [PATCH 38/50] module_sf_ruclsm workaround needed for subnormal numbers (gfortran issue during DEBUG=ON) --- physics/module_sf_ruclsm.F90 | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 6dda912c47..32231c3615 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -584,6 +584,15 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO i=its,ite + IF(ABS(SNOWH(I,J))<1e-20) THEN + ! Workaround needed for subnormal numbers (gfortran issue) + SNOWH(I,J)=0 + ENDIF + IF(ABS(SNOW(I,J))<1e-20) THEN + ! Workaround needed for subnormal numbers (gfortran issue) + SNOW(I,J)=0 + ENDIF + IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then From 9086330cbe61faf2c1a0a8286775fb53dba652cc Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 23 Sep 2022 16:26:59 +0000 Subject: [PATCH 39/50] "further clean smoke codes and module_sf_ruclsm.F90 update" --- physics/GFS_rrtmg_pre.F90 | 15 +- physics/GFS_rrtmg_pre.meta | 7 - physics/module_sf_ruclsm.F90 | 9 + physics/smoke/module_add_emiss_burn.F90 | 4 +- physics/smoke/rrfs_smoke_config.F90 | 5 +- physics/smoke/rrfs_smoke_lsdep_wrapper.F90 | 289 -------------------- physics/smoke/rrfs_smoke_lsdep_wrapper.meta | 222 --------------- physics/smoke/rrfs_smoke_wrapper.F90 | 152 +++++----- physics/smoke/rrfs_smoke_wrapper.meta | 35 ++- 9 files changed, 124 insertions(+), 614 deletions(-) delete mode 100755 physics/smoke/rrfs_smoke_lsdep_wrapper.F90 delete mode 100755 physics/smoke/rrfs_smoke_lsdep_wrapper.meta diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 106007cdc9..e9a301a8f6 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -41,7 +41,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, rrfs_smoke_band, errmsg, errflg) + spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -109,8 +109,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & iovr_exprand, & ! Flag for exponential-random cloud overlap method idcor_con, & idcor_hogan, & - idcor_oreopoulos, & - rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke + idcor_oreopoulos character(len=3), dimension(:), intent(in) :: lndp_var_list @@ -620,16 +619,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo - !> Aerosol direct feedback effect by smoke and dust - if(aero_dir_fdb) then ! add smoke/dust extinctions - do k = 1, LMK - do i = 1, IM - ! 550nm (~18000/cm) - faersw1(i,k,rrfs_smoke_band) = faersw1(i,k,rrfs_smoke_band) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) - enddo - enddo - endif - do j = 1,NBDLW do k = 1, LMK do i = 1, IM diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 2543cf58ea..79e3050d26 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1232,13 +1232,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke_band] - standard_name = index_of_shortwave_band_affected_by_smoke - long_name = rrtmg band number that smoke and dust should affect - units = count - dimensions = () - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 6dda912c47..32231c3615 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -584,6 +584,15 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO i=its,ite + IF(ABS(SNOWH(I,J))<1e-20) THEN + ! Workaround needed for subnormal numbers (gfortran issue) + SNOWH(I,J)=0 + ENDIF + IF(ABS(SNOW(I,J))<1e-20) THEN + ! Workaround needed for subnormal numbers (gfortran issue) + SNOW(I,J)=0 + ENDIF + IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then diff --git a/physics/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 index 2f57341d0d..f93e813ab7 100755 --- a/physics/smoke/module_add_emiss_burn.F90 +++ b/physics/smoke/module_add_emiss_burn.F90 @@ -49,7 +49,7 @@ subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & real(kind_phys), INTENT(IN) :: dtstep, gmt real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation - logical, INTENT(IN) :: smoke_forecast + integer, INTENT(IN) :: smoke_forecast integer :: i,j,k,n,m real(kind_phys) :: conv_rho, conv, ext2, dm_smoke, daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 @@ -146,7 +146,7 @@ subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & ! r_q(i,j)= fhist(i,j) ! no diurnal cycle !END IF - !IF (.NOT. smoke_forecast) THEN + !IF (smoke_forecast == 0) THEN r_q(i,j)= 1. !END IF diff --git a/physics/smoke/rrfs_smoke_config.F90 b/physics/smoke/rrfs_smoke_config.F90 index 6adac1c6bb..cdcf8fc8f6 100755 --- a/physics/smoke/rrfs_smoke_config.F90 +++ b/physics/smoke/rrfs_smoke_config.F90 @@ -23,13 +23,13 @@ module rrfs_smoke_config integer :: seas_opt = 2 logical :: do_plumerise = .true. integer :: addsmoke_flag = 1 - integer :: plumerisefire_frq=60 ! Let's add to the namelist + integer :: plumerisefire_frq=60 integer :: wetdep_ls_opt = 1 integer :: drydep_opt = 1 logical :: bb_dcycle = .false. - logical :: smoke_forecast = .false. logical :: aero_ind_fdb = .false. logical :: dbg_opt = .true. + integer :: smoke_forecast = 0 ! 0 read in ebb_smoke(i,24) real(kind_phys) :: wetdep_ls_alpha = .5 ! scavenging factor ! -- @@ -47,7 +47,6 @@ module rrfs_smoke_config ! -- FV3 GFDL microphysics integer, parameter :: p_atm_shum = 1 integer, parameter :: p_atm_cldq = 2 - integer, parameter :: p_atm_o3mr = 7 integer :: numgas = 0 diff --git a/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 deleted file mode 100755 index dc52f6a3fb..0000000000 --- a/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ /dev/null @@ -1,289 +0,0 @@ -!>\file rrfs_smoke_lsdep_wrapper.F90 -!! This file is RRFS-smoke large-scale wet deposition wrapper with CCPP -!! Haiqin.Li@noaa.gov 08/2022 - - module rrfs_smoke_lsdep_wrapper - - use machine , only : kind_phys - use rrfs_smoke_config - use module_wetdep_ls - use dust_data_mod - - implicit none - - private - - public :: rrfs_smoke_lsdep_wrapper_run - -contains - -!>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module -!> \ingroup gsd_chem_group -!! This is the GSD Chem driver Module -!! \section arg_table_rrfs_smoke_lsdep_wrapper_run Argument Table -!! \htmlinclude rrfs_smoke_lsdep_wrapper_run.html -!! -!>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm -!> @{ - subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & - rain_cpl, rainc_cpl, g, & - pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & - w, dqdt, ntrac,ntsmoke,ntdust,nchem,gq0, & - wetdep_ls_opt_in,wetdep_ls_alpha_in, rrfs_sd, & - errmsg,errflg) - - implicit none - - - integer, intent(in) :: im,kte,kme,ktau - integer, intent(in) :: ntrac,ntsmoke,ntdust,nchem - real(kind_phys),intent(in) :: dt,g,wetdep_ls_alpha_in - - integer, parameter :: ids=1,jds=1,jde=1, kds=1 - integer, parameter :: ims=1,jms=1,jme=1, kms=1 - integer, parameter :: its=1,jts=1,jte=1, kts=1 - - real(kind_phys), dimension(:), intent(in) :: rain_cpl, rainc_cpl - real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & - us3d, vs3d, spechum, w, dqdt - real(kind_phys), dimension(:,:,:), intent(inout) :: gq0 - integer, intent(in) :: wetdep_ls_opt_in - logical, intent(in) :: rrfs_sd - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & - p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, dqdti - - real(kind_phys), dimension(ims:im, jms:jme) :: rcav, rnav - -!>- vapor & chemistry variables - real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist - real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:nchem ) :: chem - - integer :: ide, ime, ite, kde - - real(kind_phys) :: dtstep - -!>-- local variables - integer :: i, j, jp, k, kp, n - - errmsg = '' - errflg = 0 - - if (.not. rrfs_sd) return - - wetdep_ls_opt = wetdep_ls_opt_in - wetdep_ls_alpha = wetdep_ls_alpha_in - !print*,'hli wetdep_ls_opt',wetdep_ls_opt - - ! -- set domain - ide=im - ime=im - ite=im - kde=kte - - ! -- set control flags - - ! -- compute accumulated large-scale and convective rainfall since last call - if (ktau > 1) then - dtstep = call_chemistry * dt - else - dtstep = dt - end if - - ! -- compute incremental convective and large-scale rainfall - do i=its,ite - rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm - rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm - enddo - -!!! - -!>- get ready for chemistry run - if (wetdep_ls_opt == 1) then - call rrfs_smoke_prep_lsdep(ktau,dtstep, & - pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel,g, & - ntsmoke,ntdust, & - ntrac,gq0,nchem, num_moist, & - moist,chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - - ! -- ls wet deposition - call wetdep_ls(dt,chem,rcav,moist, & - rho_phy,nchem,num_moist,dz8w,vvel, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - - ! -- put chem stuff back into tracer array - do k=kts,kte - do i=its,ite - gq0(i,k,ntsmoke)=max(epsilc,chem(i,k,1,1)) - gq0(i,k,ntdust )=max(epsilc,chem(i,k,1,2)) - enddo - enddo - endif - -! - end subroutine rrfs_smoke_lsdep_wrapper_run -!> @} - - subroutine rrfs_smoke_prep_lsdep(ktau,dtstep, & - pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel,g, & - ntsmoke,ntdust, & - ntrac,gq0,nchem, num_moist, & - moist,chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - implicit none - - !Chem input configuration - integer, intent(in) :: ktau - real(kind=kind_phys), intent(in) :: dtstep,g - - !FV3 input variables - integer, intent(in) :: ntrac,ntsmoke,ntdust - real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d - real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & - phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt - real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 - - - !GSD Chem variables - integer,intent(in) :: nchem, num_moist - integer,intent(in) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & - rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, dqdti - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, nchem ), intent(out) :: chem - - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w - - ! -- local variables -! real(kind=kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: p_phy - real(kind_phys) :: factor,factor2,pu,pl,aln,pwant - real(kind_phys) :: xhour,xmin,xlonn,xtime,real_time - real(kind_phys), DIMENSION (1,1) :: sza,cosszax - integer i,ip,j,jp,k,kp,kk,kkp,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour - - ! -- initialize output arrays - rri = 0._kind_phys - t_phy = 0._kind_phys - u_phy = 0._kind_phys - v_phy = 0._kind_phys - p_phy = 0._kind_phys - rho_phy = 0._kind_phys - dz8w = 0._kind_phys - p8w = 0._kind_phys - t8w = 0._kind_phys - vvel = 0._kind_phys - dqdti = 0._kind_phys - moist = 0._kind_phys - chem = 0._kind_phys - z_at_w = 0._kind_phys - - - do j=jts,jte - jp = j - jts + 1 - do i=its,ite - ip = i - its + 1 - z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) - enddo - enddo - - do j=jts,jte - jp = j - jts + 1 - do k=kts,kte - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g - z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) - enddo - enddo - enddo - - do j=jts,jte - jp = j - jts + 1 - do k=kts,kte+1 - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - p8w(i,k,j)=pr3d(ip,kp) - enddo - enddo - enddo - - do j=jts,jte - jp = j - jts + 1 - do k=kts,kte+1 - kk=min(k,kte) - kkp = kk - kts + 1 - do i=its,ite - ip = i - its + 1 - dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) - t_phy(i,k,j)=tk3d(ip,kkp) - p_phy(i,k,j)=prl3d(ip,kkp) - u_phy(i,k,j)=us3d(ip,kkp) - dqdti(i,k,j)=dqdt(ip,kkp) - v_phy(i,k,j)=vs3d(ip,kkp) - rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) - rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g - moist(i,k,j,:)=0. - moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) - if (t_phy(i,k,j) > 265.) then - moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) - moist(i,k,j,3)=0. - if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. - else - moist(i,k,j,2)=0. - moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) - if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. - endif - !-- - enddo - enddo - enddo - - do j=jts,jte - do k=2,kte - do i=its,ite - t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) - enddo - enddo - enddo - - ! -- only used in phtolysis.... - do j=jts,jte - do i=its,ite - t8w(i,1,j)=t_phy(i,1,j) - t8w(i,kte+1,j)=t_phy(i,kte,j) - enddo - enddo - - - do k=kms,kte - do i=ims,ime - chem(i,k,jts,1)=max(epsilc,gq0(i,k,ntsmoke)) - chem(i,k,jts,2)=max(epsilc,gq0(i,k,ntdust )) - enddo - enddo - - - end subroutine rrfs_smoke_prep_lsdep -!> @} - end module rrfs_smoke_lsdep_wrapper diff --git a/physics/smoke/rrfs_smoke_lsdep_wrapper.meta b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta deleted file mode 100755 index dbd1669c96..0000000000 --- a/physics/smoke/rrfs_smoke_lsdep_wrapper.meta +++ /dev/null @@ -1,222 +0,0 @@ -[ccpp-table-properties] - name = rrfs_smoke_lsdep_wrapper - type = scheme - dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_lsdep_wrapper_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[kte] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[kme] - standard_name = vertical_interface_dimension - long_name = number of vertical levels plus one - units = count - dimensions = () - type = integer - intent = in -[ktau] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - 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 -[rain_cpl] - standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total rain at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[rainc_cpl] - standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep - long_name = convective rain at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[pr3d] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[ph3d] - standard_name = geopotential_at_interface - long_name = geopotential at model layer interfaces - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[phl3d] - standard_name = geopotential - long_name = geopotential at model layer centers - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prl3d] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tk3d] - standard_name = air_temperature_of_new_state - long_name = updated temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[us3d] - standard_name = x_wind_of_new_state - long_name = updated x-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vs3d] - standard_name = y_wind_of_new_state - long_name = updated y-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[spechum] - standard_name = specific_humidity_of_new_state - long_name = water vapor specific humidity updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[w] - standard_name = lagrangian_tendency_of_air_pressure - long_name = layer mean vertical velocity - units = Pa s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dqdt] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntsmoke] - standard_name = index_for_smoke_in_tracer_concentration_array - long_name = tracer index for smoke - units = index - dimensions = () - type = integer - intent = in -[ntdust] - standard_name = index_for_dust_in_tracer_concentration_array - long_name = tracer index for dust - units = index - dimensions = () - type = integer - intent = in -[nchem] - standard_name = number_of_chemical_species_vertically_mixed - long_name = number of chemical vertically mixed - units = count - dimensions = () - type = integer - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[wetdep_ls_opt_in] - standard_name = control_for_smoke_wet_deposition - long_name = rrfs smoke large scale wet deposition option - units = index - dimensions = () - type = integer - intent = in -[wetdep_ls_alpha_in] - standard_name = alpha_for_ls_wet_depoistion - long_name = alpha paramter for ls wet deposition - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[rrfs_sd] - standard_name = do_smoke_coupling - long_name = flag controlling rrfs_sd collection (default off) - 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 diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 index 990a2d686f..03dedaff1a 100755 --- a/physics/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -1,5 +1,5 @@ !>\file rrfs_smoke_wrapper.F90 -!! This file is CCPP RRFS smoke driver +!! This file is CCPP driver of RRFS Smoke and Dust !! Haiqin.Li@noaa.gov 02/2021 module rrfs_smoke_wrapper @@ -13,6 +13,7 @@ module rrfs_smoke_wrapper use module_plumerise1 !plume_rise_mod use module_add_emiss_burn use dep_dry_mod + use module_wetdep_ls implicit none @@ -35,15 +36,16 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & - dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & + dust12m_in, emi_in, smoke_RRFS, ntrac, qgrs, gq0, chem3d, tile_num, & ntsmoke, ntdust, imp_physics, imp_physics_thompson, & nwfa, nifa, emanoc, & emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, wetness, & smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd, & - dust_alpha_in, dust_gamma_in, & + dust_alpha_in, dust_gamma_in, fire_in, & seas_opt_in, dust_opt_in, drydep_opt_in, & do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + wetdep_ls_opt_in,wetdep_ls_alpha_in, & smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) implicit none @@ -52,7 +54,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) integer, intent(in) :: ntrac, ntsmoke, ntdust, ndvel real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd - logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in + logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in + integer, intent(in) :: smoke_forecast_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 @@ -61,7 +64,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, dimension(:), intent(in) :: land, vegtype, soiltyp real(kind_phys), dimension(:,:), intent(in) :: smc real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in - real(kind_phys), dimension(:,:,:), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_RRFS real(kind_phys), dimension(:,:), intent(in) :: emi_in real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & @@ -75,6 +78,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr 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(inout) :: max_fplume, min_fplume real(kind_phys), dimension(:), intent( out) :: hwp real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext @@ -82,9 +86,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout real (kind=kind_phys), dimension(:), intent(in) :: wetness integer, intent(in ) :: imp_physics, imp_physics_thompson - real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in + real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in integer, intent(in) :: seas_opt_in, dust_opt_in, & - drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in + drydep_opt_in, plumerisefire_frq_in, & + addsmoke_flag_in, wetdep_ls_opt_in logical, intent(in ) :: do_plumerise_in, rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -119,7 +124,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, fire_hist, peak_hr real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: ext3d_smoke, ext3d_dust integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 - real(kind_phys) :: dtstep logical :: call_fire !>- optical variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum @@ -143,11 +147,11 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys) :: daero_emis_wfa, daero_emis_ifa !>-- local variables real(kind_phys), dimension(im) :: wdgust, snoweq - integer :: current_month, current_hour + integer :: current_month, current_hour, hour_int real(kind_phys) :: curr_secs real(kind_phys) :: factor, factor2, factor3 integer :: nbegin, nv, nvv - integer :: i, j, jp, k, kp, n + integer :: i, j, k, kp, n errmsg = '' errflg = 0 @@ -164,6 +168,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, smoke_forecast = smoke_forecast_in aero_ind_fdb = aero_ind_fdb_in dbg_opt = dbg_opt_in + wetdep_ls_opt = wetdep_ls_opt_in + wetdep_ls_alpha = wetdep_ls_alpha_in !print*,'hli ktau',ktau ! -- set domain @@ -185,9 +191,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, rnav = 0. curr_secs = ktau * dt - current_month=jdate(2) - current_hour =jdate(5)+1 - gmt = real(mod(idat(5)+jdate(5),24)) + current_month=jdate(2) ! needed for the dust input data + current_hour =jdate(5)+1 ! =1 at 00Z + hour_int=ktau*dt/3600. ! hours since the simulation start + gmt = real(mod(idat(5)+hour_int,24)) julday = int(julian) do nv=1,ndvel @@ -209,21 +216,14 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, call_fire = (do_plumerise .and. (plumerisefire_frq > 0)) if (call_fire) call_fire = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) .or. (ktau == 2) - ! -- compute accumulated large-scale and convective rainfall since last call - if (ktau > 1) then - dtstep = call_chemistry * dt - else - dtstep = dt - end if - !>- get ready for chemistry run call rrfs_smoke_prep( & ktau, current_month, current_hour, gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & - snow,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, g, pi, & + snow,dust12m_in,emi_in,smoke_RRFS, & + hf2d, pb2d, g, pi, hour_int, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & @@ -241,7 +241,14 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! Make this global, calculate at 1st time step only !>-- for plumerise -- -!IF (ktau==1) THEN + + do j=jts,jte + do i=its,ite + peak_hr(i,j)= fire_in(i,10) + enddo + enddo + + IF (ktau==1) THEN do j=jts,jte do i=its,ite if (xlong(i,j)<-130.) then @@ -259,7 +266,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, endif enddo enddo -!END IF + ENDIF IF (ktau==1) THEN ebu = 0. @@ -328,12 +335,11 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then - call add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & + call add_emis_burn(dt,ktau,dz8w,rho_phy,rel_hum,chem, & julday,gmt,xlat,xlong, & ivgtyp, vegfrac, peak_hr, & ! RAR curr_secs,ebu, & coef_bb_dc,fire_hist,ext3d_smoke,ext3d_dust, & - ! scalar(ims,kms,jms,P_QNWFA),scalar(ims,kms,jms,P_QNIFA), ! & rcav, rnav,swdown,smoke_forecast, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -358,6 +364,15 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, endif ! WRITE(*,*) 'dry depostion is done at ktau= ',ktau +!>- large-scale wet deposition + if (wetdep_ls_opt == 1) then + call wetdep_ls(dt,chem,rnav,moist, & + rho_phy,num_chem,num_moist,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif + do k=kts,kte do i=its,ite ebu_smoke(i,k)=ebu(i,k,1) @@ -410,6 +425,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, max_fplume (i) = real(max_fplume2(i,1)) enddo + do i = 1, im + fire_in(i,10) = peak_hr(i,1) + enddo + ! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau !-- to provide real aerosol emission for Thompson MP if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then @@ -445,8 +464,8 @@ subroutine rrfs_smoke_prep( & u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & - snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, g, pi, & + snow_cpl,dust12m_in,emi_in,smoke_RRFS, & + hf2d, pb2d, g, pi, hour_int, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & @@ -463,7 +482,7 @@ subroutine rrfs_smoke_prep( & its,ite, jts,jte, kts,kte) !Chem input configuration - integer, intent(in) :: ktau, current_month, current_hour + integer, intent(in) :: ktau, current_month, current_hour, hour_int !FV3 input variables integer, intent(in) :: nsoil @@ -475,7 +494,7 @@ subroutine rrfs_smoke_prep( & zorl, snow_cpl, pb2d, hf2d real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in - real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_GBBEPx + real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_RRFS real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & @@ -512,7 +531,7 @@ subroutine rrfs_smoke_prep( & real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) ! -- local variables - integer i,ip,j,jp,k,kp,kk,kkp,nv,l,ll,n + integer i,ip,j,k,kp,kk,kkp,nv,l,ll,n ! -- initialize fire emissions !plume = 0._kind_phys @@ -520,6 +539,8 @@ subroutine rrfs_smoke_prep( & ebu_in = 0._kind_phys ebb_smoke_hr = 0._kind_phys emis_anoc = 0._kind_phys + frp_hr = 0._kind_phys + frp_std_hr = 0._kind_phys ! -- initialize output arrays isltyp = 0._kind_phys @@ -596,69 +617,56 @@ subroutine rrfs_smoke_prep( & enddo do j=jts,jte - jp = j - jts + 1 - do i=its,ite - ip = i - its + 1 - z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) - enddo + do i=its,ite + z_at_w(i,kts,j)=max(0.,ph3d(i,1)/g) + enddo enddo do j=jts,jte - jp = j - jts + 1 - do k=kts,kte - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g - z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) - enddo + do k=kts,kte + do i=its,ite + dz8w(i,k,j)=abs(ph3d(i,k+1)-ph3d(i,k))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) enddo + enddo enddo do j=jts,jte - jp = j - jts + 1 - do k=kts,kte+1 - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - p8w(i,k,j)=pr3d(ip,kp) - enddo + do k=kts,kte+1 + do i=its,ite + p8w(i,k,j)=pr3d(i,k) enddo + enddo enddo do j=jts,jte - jp = j - jts + 1 do k=kts,kte+1 kk=min(k,kte) kkp = kk - kts + 1 do i=its,ite - ip = i - its + 1 dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) - t_phy(i,k,j)=tk3d(ip,kkp) - p_phy(i,k,j)=prl3d(ip,kkp) - u_phy(i,k,j)=us3d(ip,kkp) - v_phy(i,k,j)=vs3d(ip,kkp) - rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + t_phy(i,k,j)=tk3d(i,kkp) + p_phy(i,k,j)=prl3d(i,kkp) + u_phy(i,k,j)=us3d(i,kkp) + v_phy(i,k,j)=vs3d(i,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(i,kkp))) rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. - moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + moist(i,k,j,1)=gq0(i,kkp,p_atm_shum) if (t_phy(i,k,j) > 265.) then - moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,2)=gq0(i,kkp,p_atm_cldq) moist(i,k,j,3)=0. if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. else moist(i,k,j,2)=0. - moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=gq0(i,kkp,p_atm_cldq) if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. endif - rel_hum(i,k,j) = .95 - rel_hum(i,k,j) = MIN( .95, moist(i,k,j,1) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rel_hum(i,k,j)=max(0.1,rel_hum(i,k,j)) + rel_hum(i,k,j) = min(0.95,spechum(i,kkp)) + rel_hum(i,k,j) = max(0.1,rel_hum(i,k,j)) !-- - zmid(i,k,j)=phl3d(ip,kkp)/g + zmid(i,k,j)=phl3d(i,kkp)/g enddo enddo enddo @@ -690,12 +698,12 @@ subroutine rrfs_smoke_prep( & emis_anoc(i) = emi_in(i,1) enddo - if (current_hour<=24) then + if (hour_int<=24) then do j=jts,jte do i=its,ite - ebb_smoke_hr(i) = smoke_GBBEPx(i,int(gmt)+1,1) ! smoke - frp_hr (i) = smoke_GBBEPx(i,int(gmt)+1,2) ! frp - frp_std_hr (i) = smoke_GBBEPx(i,int(gmt)+1,3) ! std frp + ebb_smoke_hr(i) = smoke_RRFS(i,int(gmt)+1,1) ! smoke + frp_hr (i) = smoke_RRFS(i,int(gmt)+1,2) ! frp + frp_std_hr (i) = smoke_RRFS(i,int(gmt)+1,3) ! std frp ebu_in (i,j) = ebb_smoke_hr(i) plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) diff --git a/physics/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta index 8168bf9b40..d7ca92e43f 100755 --- a/physics/smoke/rrfs_smoke_wrapper.meta +++ b/physics/smoke/rrfs_smoke_wrapper.meta @@ -365,9 +365,9 @@ type = real kind = kind_phys intent = in -[smoke_GBBEPx] - standard_name = emission_smoke_GBBEPx - long_name = emission fire GBBEPx +[smoke_RRFS] + standard_name = emission_smoke_RRFS + long_name = emission fire RRFS units = various dimensions = (horizontal_loop_extent,24,3) type = real @@ -613,6 +613,14 @@ type = real kind = kind_phys intent = in +[fire_in] + standard_name = smoke_fire_auxeliary_input + long_name = smoke fire auxeliary input variables + units = various + dimensions = (horizontal_loop_extent,10) + type = real + kind = kind_phys + intent = inout [seas_opt_in] standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option @@ -634,6 +642,21 @@ dimensions = () type = integer intent = in +[wetdep_ls_opt_in] + standard_name = control_for_smoke_wet_deposition + long_name = rrfs smoke large scale wet deposition option + units = index + dimensions = () + type = integer + intent = in +[wetdep_ls_alpha_in] + standard_name = alpha_for_ls_wet_depoistion + long_name = alpha paramter for ls wet deposition + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [do_plumerise_in] standard_name = do_smoke_plumerise long_name = rrfs smoke plumerise option @@ -657,10 +680,10 @@ intent = in [smoke_forecast_in] standard_name = do_smoke_forecast - long_name = flag for rrfs smoke forecast - units = flag + long_name = index for rrfs smoke forecast + units = index dimensions = () - type = logical + type = integer intent = in [aero_ind_fdb_in] standard_name = do_smoke_aerosol_indirect_feedback From fe57174580d786c82d22ebbf7ffba643755119e0 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 23 Sep 2022 20:40:23 +0000 Subject: [PATCH 40/50] move snow sanity check to sanity check regions of lsm_ruc, and apply to "snow on ice" as well --- physics/lsm_ruc.F90 | 27 +++++++++++++++++++++++++++ physics/module_sf_ruclsm.F90 | 9 --------- 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index d206308cb7..d32604d3f9 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -1115,6 +1115,20 @@ subroutine lsm_ruc_run & ! inputs z0_lnd(i,j) = z0rl_lnd(i)/100. znt_lnd(i,j) = z0rl_lnd(i)/100. + ! Workaround needed for subnormal numbers. This should be + ! done after all other sanity checks, in case a sanity check + ! results in subnormal numbers. + ! + ! This bug was caught by the UFS gfortran debug-mode + ! regression tests, and the fix is necessary to pass those + ! tests. + if(abs(snowh_lnd(i,j))<1e-20) then + snowh_lnd(i,j)=0 + endif + if(abs(sneqv_lnd(i,j))<1e-20) then + sneqv_lnd(i,j)=0 + endif + !if (debug_print) then !-- diagnostics for a land test point with known lat/lon if (kdt < 10) then @@ -1417,6 +1431,19 @@ subroutine lsm_ruc_run & ! inputs z0_ice(i,j) = z0rl_ice(i)/100. znt_ice(i,j) = z0rl_ice(i)/100. + ! Workaround needed for subnormal numbers. This should be + ! done after all other sanity checks, in case a sanity check + ! results in subnormal numbers. + ! + ! Although this bug has not been triggered yet, it is expected + ! to be, like the _lnd variants many lines up from here. + if(abs(snowh_ice(i,j))<1e-20) then + snowh_ice(i,j)=0 + endif + if(abs(sneqv_ice(i,j))<1e-20) then + sneqv_ice(i,j)=0 + endif + !> - Call RUC LSM lsmruc() for ice. call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 32231c3615..6dda912c47 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -584,15 +584,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO i=its,ite - IF(ABS(SNOWH(I,J))<1e-20) THEN - ! Workaround needed for subnormal numbers (gfortran issue) - SNOWH(I,J)=0 - ENDIF - IF(ABS(SNOW(I,J))<1e-20) THEN - ! Workaround needed for subnormal numbers (gfortran issue) - SNOW(I,J)=0 - ENDIF - IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then From 558c35e947eb67d891cf7857c80875f39db188a7 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 28 Sep 2022 16:39:16 +0000 Subject: [PATCH 41/50] "update for bugfix of fire peak_hr" --- physics/smoke/rrfs_smoke_wrapper.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 index 03dedaff1a..14e740837b 100755 --- a/physics/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -251,15 +251,15 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, IF (ktau==1) THEN do j=jts,jte do i=its,ite - if (xlong(i,j)<-130.) then + if (xlong(i,j)<230.) then peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska - elseif(xlong(i,j)<-115.) then + elseif(xlong(i,j)<245.) then peak_hr(i,j)= 23.0* 3600. - elseif (xlong(i,j)<-100.) then + elseif (xlong(i,j)<260.) then peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US - elseif (xlong(i,j)<-85.) then + elseif (xlong(i,j)<275.) then peak_hr(i,j)= 21.0* 3600. - elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US + elseif (xlong(i,j)<290.) then ! peak at 20 UTC, fires in the eastern US peak_hr(i,j)= 20.0* 3600. else peak_hr(i,j)= 19.0* 3600. From 5ded667940f81b8cc9597a796138d50378b9d57f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 28 Sep 2022 20:11:16 +0000 Subject: [PATCH 42/50] thread and other bug fixes --- physics/smoke/module_add_emiss_burn.F90 | 10 +++----- physics/smoke/module_plumerise1.F90 | 17 ++++++------- physics/smoke/module_smoke_plumerise.F90 | 28 +++++++++------------ physics/smoke/module_zero_plumegen_coms.F90 | 24 ++++++------------ physics/smoke/rrfs_smoke_wrapper.F90 | 19 +++++--------- physics/smoke/rrfs_smoke_wrapper.meta | 6 ++--- physics/smoke/seas_mod.F90 | 4 +-- 7 files changed, 42 insertions(+), 66 deletions(-) diff --git a/physics/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 index f93e813ab7..c5c650cb8a 100755 --- a/physics/smoke/module_add_emiss_burn.F90 +++ b/physics/smoke/module_add_emiss_burn.F90 @@ -6,7 +6,7 @@ module module_add_emiss_burn use machine , only : kind_phys use rrfs_smoke_config CONTAINS - subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & + subroutine add_emis_burn(dtstep,dz8w,rho_phy,rel_hum, & chem,julday,gmt,xlat,xlong, & !luf_igbp,lu_fire1, & vegtype,vfrac,peak_hr, & @@ -24,7 +24,7 @@ subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN ) :: ktau, julday, & + INTEGER, INTENT(IN ) :: julday, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -172,9 +172,8 @@ subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) - if (ktau<1000 .and. dbg_opt) then ! if ( k==kts ) then - ! WRITE(6,*) 'add_emiss_burn: ktau,gmt,dtstep,time_int ',ktau,gmt,dtstep,time_int + ! WRITE(6,*) 'add_emiss_burn: gmt,dtstep,time_int ',gmt,dtstep,time_int ! WRITE(*,*) 'add_emiss_burn: i,j,xlat(i,j),xlong(i,j) ',i,j,xlat(i,j),xlong(i,j) !WRITE(*,*) 'add_emiss_burn: luf_igbp(i,:,j) ',luf_igbp(i,:,j) !WRITE(*,*) 'add_emiss_burn: lu_fire1(i,j) ',lu_fire1(i,j) @@ -186,7 +185,6 @@ subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke endif - endif enddo enddo @@ -208,7 +206,7 @@ subroutine add_emis_burn(dtstep,ktau,dz8w,rho_phy,rel_hum, & enddo enddo - IF ( ktau<2000 .and. dbg_opt ) then + IF ( dbg_opt ) then WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) WRITE(*,*) 'add_emis_burn: ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) ',ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) diff --git a/physics/smoke/module_plumerise1.F90 b/physics/smoke/module_plumerise1.F90 index e03e60bc23..3c23faa6ab 100755 --- a/physics/smoke/module_plumerise1.F90 +++ b/physics/smoke/module_plumerise1.F90 @@ -37,7 +37,7 @@ module module_plumerise1 subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,z,ktau,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -56,8 +56,7 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg - INTEGER, INTENT(IN ) :: ktau, & - ids,ide, jds,jde, kds,kde, & + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & @@ -112,7 +111,7 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & cpor =con_cp/con_rd con_rocp=con_rd/con_cp - IF ( dbg_opt .and. ktau<2000) then + IF ( dbg_opt ) then WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu @@ -133,7 +132,6 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & ! For now the flammable fraction is constant, based on the namelist. The next ! step to use LU index and meteorology to parameterize it -! IF (ktau==2) THEN do j=jts,jte do i=its,ite flam_frac(i,j)= 0. @@ -142,7 +140,6 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & end if enddo enddo - ! ENDIF ! RAR: new FRP based approach @@ -172,7 +169,7 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp enddo - IF (dbg_opt .and. ktau<2000) then + IF (dbg_opt) then WRITE(*,*) 'module_plumerise1: i,j ',i,j WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) @@ -188,9 +185,9 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), ktau, dbg_opt, g, con_cp, & + k_max(i,j), dbg_opt, g, con_cp, & con_rd, cpor, errmsg, errflg ) - !k_max(i,j), ktau, config_flags%debug_chem ) + !k_max(i,j), config_flags%debug_chem ) if(errflg/=0) return kp1= k_min(i,j) @@ -202,7 +199,7 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & enddo ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) - IF ( dbg_opt .and. ktau<2000) then + IF ( dbg_opt ) then WRITE(*,*) 'module_plumerise1: i,j ',i,j WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) END IF diff --git a/physics/smoke/module_smoke_plumerise.F90 b/physics/smoke/module_smoke_plumerise.F90 index d1f30e57e3..a895b0b8ed 100755 --- a/physics/smoke/module_smoke_plumerise.F90 +++ b/physics/smoke/module_smoke_plumerise.F90 @@ -28,7 +28,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - frp_inst,k1,k2, ktau, dbg_opt, g, cp, rgas, & + frp_inst,k1,k2, dbg_opt, g, cp, rgas, & cpor, errmsg, errflg ) implicit none @@ -43,7 +43,6 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies - INTEGER, INTENT (IN) :: ktau INTEGER, INTENT (OUT) :: k1,k2 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -103,9 +102,6 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & !---------------------------------------------------------------------- ! print *,' Plumerise_scalar 1',ncall coms => get_thread_coms() - if (ktau==2) then - call coms%set_to_zero() - endif IF (frp_inst=k1+1 @@ -205,7 +199,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! enddo !enddo - IF (dbg_opt .AND. ktau<2000) then + IF (dbg_opt) then WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi !WRITE(*,*) 'plumerise after set_flam_vert: eburn_in(2) ', eburn_in(2) @@ -217,7 +211,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,g,cp,rgas,cpor,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants @@ -229,11 +223,11 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg, real(kind=kind_phys),parameter :: p00=p1000mb real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy !integer :: n_setgrid = 0 -integer :: wind_eff,ktau +integer :: wind_eff character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg -if(ktau==2) then +if(.not.coms%initialized) then ! n_setgrid = 1 call set_grid(coms) ! define vertical grid of plume model ! coms%zt(k) = thermo and water levels @@ -345,6 +339,8 @@ subroutine set_grid(coms) coms%dzt(k) = 1. / (coms%zm(k) - coms%zm(k-1)) enddo coms%dzt(1) = coms%dzt(2) * coms%dzt(2) / coms%dzt(3) + +coms%initialized = .true. ! coms%dzm(1) = 0.5/coms%dz ! coms%dzm(2:mzp) = 1./coms%dz diff --git a/physics/smoke/module_zero_plumegen_coms.F90 b/physics/smoke/module_zero_plumegen_coms.F90 index 622d6a813d..92b9ca2dcc 100755 --- a/physics/smoke/module_zero_plumegen_coms.F90 +++ b/physics/smoke/module_zero_plumegen_coms.F90 @@ -9,6 +9,8 @@ module module_zero_plumegen_coms integer, parameter :: nkp = 200, ntime = 200 type plumegen_coms + logical :: initialized = .false. + real(kind=kind_phys),dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob vth,vti,rho,txs, & est,qsat! never used: ,qpas,qtotal @@ -55,38 +57,28 @@ module module_zero_plumegen_coms procedure :: set_to_zero => plumegen_coms_zero end type plumegen_coms - interface plumegen_coms - procedure :: plumegen_coms_constructor - end interface plumegen_coms - - type(plumegen_coms), private, target :: private_thread_coms - logical, private :: mzpc_initialized = .false. + type(plumegen_coms), private, pointer :: private_thread_coms !$OMP THREADPRIVATE(private_thread_coms) -!$OMP THREADPRIVATE(mzpc_initialized) contains function get_thread_coms() result(coms) implicit none class(plumegen_coms), pointer :: coms - if(.not.mzpc_initialized) then - private_thread_coms = plumegen_coms() - mzpc_initialized = .true. + if(.not.associated(private_thread_coms)) then + allocate(private_thread_coms) + call plumegen_coms_zero(private_thread_coms) endif coms => private_thread_coms end function get_thread_coms - type(plumegen_coms) function plumegen_coms_constructor() result(this) - implicit none - call plumegen_coms_zero(this) - this%testval=3314 - end function plumegen_coms_constructor - subroutine plumegen_coms_zero(this) implicit none class(plumegen_coms) :: this + this%initialized = .false. + this%w=0.0 this%t=0.0 this%qv=0.0 diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 index 03dedaff1a..8bc7a638f9 100755 --- a/physics/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -171,7 +171,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, wetdep_ls_opt = wetdep_ls_opt_in wetdep_ls_alpha = wetdep_ls_alpha_in - !print*,'hli ktau',ktau ! -- set domain ide=im ime=im @@ -218,7 +217,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- get ready for chemistry run call rrfs_smoke_prep( & - ktau, current_month, current_hour, gmt, & + current_month, current_hour, gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & @@ -290,7 +289,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- compute sea-salt ! -- compute sea salt (opt=2) if (seas_opt == 2) then - call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & + call gocart_seasalt_driver(dt,rri,t_phy,moist, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & xland,xlat,xlong,dxy,g,emis_seas,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & @@ -320,12 +319,11 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but ! the plumerise is controlled by the namelist option of plumerise_flag if (call_fire) then -! WRITE(*,*) 'plumerise is called at ktau= ',ktau call ebu_driver ( & flam_frac,ebu_in,ebu, & t_phy,moist(:,:,:,p_qv), & rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,zmid,ktau,g,con_cp,con_rd, & + z_at_w,zmid,g,con_cp,con_rd, & plume_frp, min_fplume2, max_fplume2, & ! new approach ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -335,7 +333,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then - call add_emis_burn(dt,ktau,dz8w,rho_phy,rel_hum,chem, & + call add_emis_burn(dt,dz8w,rho_phy,rel_hum,chem, & julday,gmt,xlat,xlong, & ivgtyp, vegfrac, peak_hr, & ! RAR curr_secs,ebu, & @@ -345,7 +343,6 @@ 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 ) endif -! WRITE(*,*) 'after add_emis_burn at ktau= ',ktau !>-- compute dry deposition if (drydep_opt == 1) then @@ -362,7 +359,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, else ddvel_inout(:,:)=0. endif -! WRITE(*,*) 'dry depostion is done at ktau= ',ktau !>- large-scale wet deposition if (wetdep_ls_opt == 1) then @@ -414,7 +410,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, enddo !------------------------------------- !-- to output for diagnostics -! WRITE(*,*) 'rrfs nwfa/nifa 1 at ktau= ',ktau do i = 1, im emseas (i) = emis_seas (i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s emdust (i) = emis_dust (i,1,1,1) ! size bin 1 dust emission : ug/m2/s @@ -429,7 +424,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, fire_in(i,10) = peak_hr(i,1) enddo -! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau !-- to provide real aerosol emission for Thompson MP if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 @@ -455,12 +449,11 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, enddo enddo endif -! WRITE(*,*) 'rrfs smoke wrapper is done at ktau= ',ktau end subroutine rrfs_smoke_wrapper_run subroutine rrfs_smoke_prep( & - ktau,current_month,current_hour,gmt, & + current_month,current_hour,gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & @@ -482,7 +475,7 @@ subroutine rrfs_smoke_prep( & its,ite, jts,jte, kts,kte) !Chem input configuration - integer, intent(in) :: ktau, current_month, current_hour, hour_int + integer, intent(in) :: current_month, current_hour, hour_int !FV3 input variables integer, intent(in) :: nsoil diff --git a/physics/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta index d7ca92e43f..1a53981784 100755 --- a/physics/smoke/rrfs_smoke_wrapper.meta +++ b/physics/smoke/rrfs_smoke_wrapper.meta @@ -614,10 +614,10 @@ kind = kind_phys intent = in [fire_in] - standard_name = smoke_fire_auxeliary_input - long_name = smoke fire auxeliary input variables + standard_name = smoke_fire_auxiliary_input + long_name = smoke fire auxiliary input variables units = various - dimensions = (horizontal_loop_extent,10) + dimensions = (horizontal_loop_extent,fire_auxiliary_data_extent) type = real kind = kind_phys intent = inout diff --git a/physics/smoke/seas_mod.F90 b/physics/smoke/seas_mod.F90 index 6d58b65079..935b64513e 100755 --- a/physics/smoke/seas_mod.F90 +++ b/physics/smoke/seas_mod.F90 @@ -25,7 +25,7 @@ module seas_mod CONTAINS - subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & + subroutine gocart_seasalt_driver(dt,alt,t_phy,moist,u_phy, & v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & xland,xlat,xlong,area,g,emis_seas,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & @@ -33,7 +33,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & + INTEGER, INTENT(IN ) :: num_emis_seas,num_moist,num_chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte,seas_opt From b2070f2e54c33226dbfb904355c7ac9d79cc70ac Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 28 Sep 2022 21:50:27 +0000 Subject: [PATCH 43/50] module_bl_mynn was sending unallocated arrays to mynn_mix_chem when rrfs_sd=.false. --- physics/module_bl_mynn.F90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 8dce1a7b5f..464890ad66 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1350,6 +1350,7 @@ SUBROUTINE mynn_bl_driver( & IF ( mix_chem ) THEN + IF ( rrfs_sd ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1361,7 +1362,19 @@ SUBROUTINE mynn_bl_driver( & &emis_ant_no(i), & &frp(i), rrfs_sd, & &enh_mix, smoke_dbg ) - + ELSE + CALL mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + ENDIF DO ic = 1,nchem DO k = kts,kte chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) From 4561826cbd313e9a48dbcba71ca8881e07ce33ea Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 29 Sep 2022 16:03:00 +0000 Subject: [PATCH 44/50] put a wordy debug message behind dbg_opt --- physics/smoke/module_add_emiss_burn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 index c5c650cb8a..ff53f74139 100755 --- a/physics/smoke/module_add_emiss_burn.F90 +++ b/physics/smoke/module_add_emiss_burn.F90 @@ -180,7 +180,7 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,rel_hum, & ! WRITE(6,*) 'add_emiss_burn: timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ',timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ! WRITE(*,*) 'add_emiss_burn: rainc(i,j),rainnc(i,j) ', rainc(i,j),rainnc(i,j) ! endif - if ( k==kts .OR. k==kfire_max ) then + if ( dbg_opt .and. (k==kts .OR. k==kfire_max) ) then WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke From ac34369ab0d1e71b8b92572cc363a1ba83be6004 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 30 Sep 2022 21:37:06 +0000 Subject: [PATCH 45/50] remove old precision fix from physics/module_sf_ruclsm.F90 --- physics/module_sf_ruclsm.F90 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 32231c3615..6dda912c47 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -584,15 +584,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO i=its,ite - IF(ABS(SNOWH(I,J))<1e-20) THEN - ! Workaround needed for subnormal numbers (gfortran issue) - SNOWH(I,J)=0 - ENDIF - IF(ABS(SNOW(I,J))<1e-20) THEN - ! Workaround needed for subnormal numbers (gfortran issue) - SNOW(I,J)=0 - ENDIF - IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then From d400f4993a59a2cce0f8651b16f6453bb0b47dba Mon Sep 17 00:00:00 2001 From: "Ming.Hu" Date: Thu, 6 Oct 2022 21:05:25 +0000 Subject: [PATCH 46/50] ruclsm updates from Tanya: 1) add a special treatment to melting hail on the ground after hail storm. 2) moved parameter for snow over and conductivity definition to the top --- physics/lsm_ruc.F90 | 44 ++--- physics/module_sf_ruclsm.F90 | 320 ++++++++++++++++++----------------- 2 files changed, 188 insertions(+), 176 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index d32604d3f9..963a5af30b 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -453,7 +453,7 @@ subroutine lsm_ruc_run & ! inputs ! --- locals: real (kind=kind_phys), dimension(im) :: rho, & - & q0, qs1, albbcksol, & + & q0, qs1, albbcksol, srunoff_old, runoff_old, & & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land & weasd_lnd_old, snwdph_lnd_old, tskin_lnd_old, & @@ -684,6 +684,8 @@ subroutine lsm_ruc_run & ! inputs snowmt_lnd_old(i) = snowmt_lnd(i) acsnow_lnd_old(i) = acsnow_lnd(i) snowfallac_lnd_old(i) = snowfallac_lnd(i) + srunoff_old(i) = srunoff(i) + runoff_old(i) = runoff(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) @@ -747,18 +749,20 @@ subroutine lsm_ruc_run & ! inputs acceta(i,j) = 0.0 ssoil_lnd(i,j) = 0.0 ssoil_ice(i,j) = 0.0 - snomlt_lnd(i,j) = 0.0 - snomlt_ice(i,j) = 0.0 infiltr(i,j) = 0.0 - runoff1(i,j) = 0.0 - runoff2(i,j) = 0.0 - acrunoff(i,j) = 0.0 - snfallac_lnd(i,j) = 0.0 - acsn_lnd(i,j) = 0.0 - snfallac_ice(i,j) = 0.0 - acsn_ice(i,j) = 0.0 precipfr(i,j) = 0.0 rhosnfr(i,j) = -1.e3 + runoff1(i,j) = 0.0 + runoff2(i,j) = 0.0 + if(kdt == 1) then + acrunoff(i,j) = 0.0 + snfallac_lnd(i,j) = 0.0 + acsn_lnd(i,j) = 0.0 + snfallac_ice(i,j) = 0.0 + acsn_ice(i,j) = 0.0 + snomlt_lnd(i,j) = 0.0 + snomlt_ice(i,j) = 0.0 + endif endif enddo ! i=1,im enddo @@ -1041,11 +1045,7 @@ subroutine lsm_ruc_run & ! inputs sneqv_lnd(i,j) = weasd_lnd(i) snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - if(kdt == 1) then - snfallac_lnd(i,j) = 0. - acsn_lnd(i,j) = 0. - snomlt_lnd(i,j) = 0. - else + if(kdt > 1) then !-- run-total accumulation snfallac_lnd(i,j) = snowfallac_lnd(i) acsn_lnd(i,j) = acsnow_lnd(i) @@ -1294,7 +1294,8 @@ subroutine lsm_ruc_run & ! inputs ! --- ... accumulated total runoff and surface runoff runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt ! accum total kg m-2 - srunoff(i) = srunoff(i) + runof(i) * delt ! accum surface kg m-2 + !srunoff(i) = srunoff(i) + runof(i) * delt ! accum surface kg m-2 + srunoff(i) = acrunoff(i,j) ! accum surface kg m-2 ! --- ... accumulated frozen precipitation (accumulation in lsmruc) snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 @@ -1403,11 +1404,7 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] - if(kdt == 1) then - snfallac_ice(i,j) = 0. - acsn_ice(i,j) = 0. - snomlt_ice(i,j) = 0. - else + if(kdt > 1) then snfallac_ice(i,j) = snowfallac_ice(i) acsn_ice(i,j) = acsnow_ice(i) snomlt_ice(i,j) = snowmt_ice(i) @@ -1431,6 +1428,9 @@ subroutine lsm_ruc_run & ! inputs z0_ice(i,j) = z0rl_ice(i)/100. znt_ice(i,j) = z0rl_ice(i)/100. + runoff1(i,j) = 0. + runoff2(i,j) = 0. + ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check ! results in subnormal numbers. @@ -1574,6 +1574,8 @@ subroutine lsm_ruc_run & ! inputs z0rl_ice(i) = z0rl_ice_old(i) sncovr1_ice(i) = sncovr1_ice_old(i) snowmt_ice(i) = snowmt_ice_old(i) + srunoff(i) = srunoff_old(i) + runoff(i) = runoff_old(i) do k = 1, lsoil_ruc smois(i,k) = smois_old(i,k) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 6dda912c47..c879b0b399 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -525,49 +525,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & soilice(k)=0. soiliqw(k)=0. enddo - - else - !-- restart - DO J=jts,jte - DO i=its,ite - SMELT(i,j) = 0. - PRECIPFR(i,j) = 0. - RHOSNF(i,j) = -1.e3 ! non-zero flag - SNFLX(i,j) = 0. - DEW (i,j) = 0. - PC (i,j) = 0. - zntl (i,j) = 0. - RUNOFF1(i,j) = 0. - RUNOFF2(i,j) = 0. - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - emissl (i,j) = 0. - budget(i,j) = 0. - acbudget(i,j) = 0. - waterbudget(i,j) = 0. - acwaterbudget(i,j) = 0. - smtotold(i,j)=0. - canwatold(i,j)=0. - chklowq(i,j) = 1. - infiltr(i,j) = 0. - snoh (i,j) = 0. - edir (i,j) = 0. - ec (i,j) = 0. - ett (i,j) = 0. - sublim(i,j) = 0. - sflx (i,j) = 0. - smf (i,j) = 0. - evapl (i,j) = 0. - prcpl (i,j) = 0. - ENDDO - ENDDO - - infiltrp = 0. - do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. - enddo - endif ! cold start endif ! init==.true. @@ -1078,7 +1035,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + !ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. smtotold (I,J) = smtotold(I,J) * 1000. ! mm @@ -1582,7 +1540,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia acsnow=acsnow+newsn*1.e3 IF(NEWSN.GT.0.) THEN -! IF(NEWSN.GE.1.E-8) THEN IF (debug_print ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn @@ -1611,6 +1568,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) + if (debug_print) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,'snow_mosaic = ',snow_mosaic + print *,'new snow,newsnowratio,rhosnfall =',newsn,newsnowratio,rhosnfall + print *,'snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice',snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice + endif ! from now on rhonewsn is the density of falling frozen precipitation rhonewsn=rhosnfall @@ -1726,7 +1690,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !if(snowfrac < 0.9) snow_mosaic = 1. KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN + IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN ! new snow KEEP_SNOW_ALBEDO = 1. snow_mosaic=0. ! ??? @@ -1782,8 +1746,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia (emissn - emiss_snowfree) * snowfrac), emissn)) endif IF (debug_print ) THEN -! if(i.eq.279.and.j.eq.263) then - print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic ENDIF !28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is ! higher than patchy snow treshold - then snow albedo is not less than 0.55 @@ -1851,7 +1815,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1906,7 +1869,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1952,34 +1914,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia enddo endif ! seaice < 0.5 -!return gswnew to incoming solar - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb - ENDIF -! gswnew=gswnew/(1.-alb_snow_free) - - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Incoming GSWnew snowfrac<1 -',gswnew - ENDIF endif ! snow_mosaic=1. !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB gswnew=GSWin*(1.-alb) -! print *,'SNOW fraction GSWnew',gswnew,'alb=',alb !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT XINET = EMISS*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then -! if(i.eq.271.and.j.eq.242) then print *,'RNET=',rnet print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB + print *,'GSWnew',gswnew,'alb=',alb ENDIF if (SEAICE .LT. 0.5) then @@ -2068,10 +2017,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5) then ! LAND IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'SOILT snow on land', ktau, i,j,soilt - print *,'SOILT on snow-free land', i,j,soilts - print *,'ts1d,ts1ds',i,j,ts1d,ts1ds + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,' snowfrac = ',snowfrac + print *,' SOILT snow on land', ktau, i,j,soilt + print *,' SOILT on snow-free land', i,j,soilts + print *,' ts1d,ts1ds',i,j,ts1d,ts1ds print *,' SNOW flux',i,j, snflx print *,' Ground flux on snow-covered land',i,j, s print *,' Ground flux on snow-free land', i,j,ss @@ -2131,9 +2082,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac IF (debug_print ) THEN - print *,' Ground flux combined', i,j, s - print *,'SOILT combined on land', soilt - print *,'TS combined on land', ts1d + !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then + print *,' Ground flux combined', xlat,xlon, s + print *,' SOILT combined on land', soilt + print *,' TS combined on land', ts1d ENDIF else ! SEA ICE @@ -3670,14 +3622,14 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst ENDIF -! SNHEI=SNWE*1.e3/RHOSN +!-- Save SNWE from the previous time step SNWEPR=SNWE ! check if all snow can evaporate during DT BETA=1. - EPDT = EPOT * RAS *DELT*UMVEG + EPDT = EPOT * RAS *DELT IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) + BETA=SNWEPR/EPDT SNWE=0. ENDIF @@ -4423,10 +4375,10 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + !IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + IF(SOILT.GT.273.15.AND.BETA.EQ.1..AND.SNHEI.GT.0.) THEN ! nmelt = 1 -! soiltfrac=273.15 soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP @@ -4535,11 +4487,13 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE ELSE - if(snhei.ne.0.) then + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) ! BETA*EPOT*RAS*DELT*snowfrac)) + else + snwe = 0. endif ENDIF @@ -5485,10 +5439,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & BB=BB-SNOH/TDENOM IF (debug_print ) THEN - if (abs(xlat-42.05).lt.0.5 .and. & - abs(xlon-286.75).lt.0.5)then - print *,'1-', i,tn,aa1,bb,pp,ktau,newsnow,snwe,snhei,soilt,soilt1,tso,rhosn,rhonewcsn - print *,'2-', i,tdenom,fkq,vegfrac,can,tabs,R210,D10,R21,D9sn,D1sn,R22sn,R7,prcpms + if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1-', i,rnet,tabs,tn,aa1,bb,pp,ktau,newsnow,snwepr,snwe,snhei,snowfrac,soilt,soilt1,tso,rhosn + print *,'2-', i,tdenom,fkq,vegfrac,can,R210,D10,R21,D9sn,D1sn,R22sn,R7,prcpms endif ENDIF CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) @@ -5496,7 +5449,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TX2=TQ2*(1.-H) Q1=TX2+H*QS1 IF (debug_print ) THEN - print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1,xlat,xlon ENDIF IF(Q1.LT.QS1) GOTO 100 !--- if no saturation - goto 100 @@ -5513,6 +5467,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GT.QS1) GOTO 90 @@ -5547,21 +5502,21 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- SOILT - skin temperature SOILT=TS1 - if(nmelt==1 .and. snowfrac==1) then - !--7feb22 on the second iteration when SNOH is known, - !-- check if the snow skin temperature is <273.15K - !-- when a grid cells is fully covered with snow and snow_mosaic=0. - !-- or with partial snow cover and snow_mosaic=1. + if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > 273.15) then + !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, + !-- check if the snow skin temperature is =<273.15K + !-- when a grid cell is fully covered with snow (snowfrac=1) + !-- or with partial snow cover and snow_mosaic=1 (snowfrac=1). if (debug_print ) then - print *,'soilt is too high =',i,j,soilt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'soilt is too high =',soilt,xlat,xlon soilt = min(273.15,soilt) endif endif IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso -! endif + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snwe,snwepr,snhei,snowfr,soilt,soilt1,tso',i,j,snwe,snwepr,snhei,snowfrac,soilt,soilt1,tso ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface IF(SNHEI.GE.SNTH) THEN @@ -5616,16 +5571,18 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'SOILT,SOILT1,tso,TSOB,QSG',i,j,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Final SOILT,SOILT1,tso,TSOB,QSG',xlat,xlon,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + print *,'SNWEPR-BETA*EPOT*RAS*DELT',SNWEPR-BETA*EPOT*RAS*DELT,beta,snwepr,epot ENDIF if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN -! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN +! if all snow can evaporate (beta<1), then there is nothing to melt + IF(SOILT.GT.273.15.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN + !-- snow sublimation and melting nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) @@ -5637,6 +5594,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS + IF (Q1.LE.0..or.iter==1) THEN ! --- condensation DEW=-EPOT @@ -5695,69 +5653,110 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 IF (debug_print ) THEN - print *,'1- SMELT',i,j,smelt - ENDIF - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - IF (debug_print ) THEN - print *,'2- SMELT',i,j,smelt - ENDIF - SMELT=AMAX1(0.,SMELT) + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1- SMELT',smelt,snoh,xlat,xlon + ENDIF + + IF(EPOT.gt.0. .and. SNWEPR.LE.EPOT*RAS*DELT) THEN +!-- all snow can evaporate + BETA=SNWEPR/(EPOT*RAS*DELT) + SMELT=AMAX1(0.,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) + SNWE=0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon + ENDIF + goto 88 + ENDIF !18apr08 - Egglston limit -! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) + !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow + !-- (rhosn > 350.) with very warm surface temperatures (>10C) + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-273.15))) -! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP - IF (debug_print ) THEN - print *,'3- SMELT',i,j,smelt - ENDIF +! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon + ENDIF + endif ! rr - potential melting rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) - SMELT=min(SMELT,rr) - IF (debug_print ) THEN - print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr - ENDIF + if(smelt > rr) then + SMELT = min(SMELT,rr) + SNWE = 0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr + ENDIF + endif + 88 continue SNOHGNEW=SMELT*XLMELT*1.E3 SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW - IF (debug_print ) THEN - print *,'SNOH,SNODIF',SNOH,SNODIF - ENDIF + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'SNOH,SNODIF',SNOH,SNODIF + print *,' xlat, xlon', xlat, xlon + ENDIF + IF( smelt > 0.) then !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + if(snhei > 0.01 .and. rhosn < 350.) then rsm=min(snwe,rsmfrac*smelt*delt) else -! do not keep melted water if snow depth is less that 1 cm + ! do not keep melted water if snow depth is less that 1 cm + ! or if snow is dense rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=max(0.,SMELT-rsm/delt) - IF (debug_print ) THEN - print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + if(rsm > 0.) then + SMELT=max(0.,SMELT-rsm/delt) + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac - ENDIF + print *,' xlat, xlon', xlat, xlon + ENDIF + endif ! rsm + + ENDIF ! smelt > 0 !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & -! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & + if(snwe > 0.) then + SNWE = AMAX1(0.,(SNWEPR- & + (SMELT+BETA*EPOT*RAS)*DELT & ) ) -!--- If there is no snow melting then just evaporation -!--- or condensation cxhanges SNWE + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' Snow is melting and sublimating, snwe', xlat, xlon, SNWE + endif + else + !-- all snow is sublimated or melted + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' all snwe is sublimated or melted', xlat, xlon, SNWE + endif + endif ELSE - if(snhei.ne.0.) then +!--- If there is no snow melting then just evaporation +!--- or condensation changes SNWE + !-- no melting, only sublimation + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) + else + !-- all snow is sublibated + snwe = 0. endif ENDIF + !18apr08 - if snow melt occurred then go into iteration for energy budget ! solution if(nmelt.eq.1) goto 212 ! second interation @@ -5812,28 +5811,41 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- is above freezing snow can melt from the bottom. The following !-- piece of code will check if bottom melting is possible. - IF(TSO(1).GT.273.15 .and. snhei > 0.) THEN + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon + endif + + IF(TSO(1).GT.273.15 .and. snhei > 0. .and. beta == 1.) THEN + !-- melting in the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn - IF (debug_print ) THEN - print*,'2 layer snow - snhei,hsn',snhei,hsn - ENDIF + IF (debug_print ) THEN + print*,'2 layer snow - snhei,hsn',snhei,hsn + ENDIF else - IF (debug_print ) THEN - print*,'1 layer snow or blended - snhei',snhei - ENDIF + IF (debug_print ) THEN + print*,'1 layer snow or blended - snhei',snhei + ENDIF hsn = snhei endif soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) - SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & + SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 + SNOHG=AMAX1(0.,SNOHG) + SNODIF=0. + SMELTG=SNOHG/XLMELT*1.E-3 + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' SMELTG =',smeltg,xlat,xlon + endif ! Egglston - empirical limit on snow melt from the bottom of snow pack + !9jun22-- exclude summer hail from limiting snow melt + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELTG=AMIN1(SMELTG, 5.8e-9) + endif ! rr - potential melting rr=SNWE/delt @@ -5842,41 +5854,39 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SNOHGNEW=SMELTG*XLMELT*1.e3 SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then - print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,' xlat, xlon', xlat, xlon ENDIF -! snwe=max(0.,snwe-smeltg*delt*snowfrac) snwe=max(0.,snwe-smeltg*delt) SNHEI=SNWE *1.E3 / RHOSN if(snhei > 0.) TSO(1) = soiltfrac IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'Melt from the bottom snwe,snhei',snwe,snhei + print *,' xlat, xlon', xlat, xlon + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh + print *,' Final TSO ',tso if (snhei==0.) & print *,'Snow is all melted on the warm ground' ENDIF - ENDIF - IF (debug_print ) THEN - print *,'SNHEI,SNOH',i,j,SNHEI,SNOH - ENDIF -! & + ENDIF ! melt on snow/soil interface + snweprint=snwe snheiprint=snweprint*1.E3 / RHOSN - IF (debug_print ) THEN -print *, 'snweprint : ',snweprint -print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB - ENDIF - - X= (R21+D9SN*R22SN)*(soilt-TN) + & + X= (R21+D9SN*R22SN)*(soilt-TN) + & XLVM*R210*(QSG-QGOLD) IF (debug_print ) THEN - print *,'SNOWTEMP storage ',i,j,x + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'end SNOWTEMP storage ',xlat,xlon,x print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim + print *,'snwe, snhei ',snwe,snhei ENDIF X=X & From 08895ec573e2353d8b538ad23bc3e4a166438cdb Mon Sep 17 00:00:00 2001 From: "Ming.Hu" Date: Thu, 6 Oct 2022 23:12:03 +0000 Subject: [PATCH 47/50] Update Thompson MP for reducing the reflectivity bias. --- physics/module_mp_thompson.F90 | 216 +++++++++++---------------------- 1 file changed, 73 insertions(+), 143 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 6624e0dbbe..1800d8c54a 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2179,7 +2179,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ni(k) = MAX(R2, ni1d(k)*rho(k)) if (ni(k).le. R2) then lami = cie(2)/5.E-6 - ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi @@ -2187,7 +2187,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -2391,27 +2391,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ -! Ming Hu: go back to old version for Spring experiment 2021 - N0_min = gonv_max - k_0 = kts - do k = kte, kts, -1 - if (temp(k).ge.270.65) k_0 = MAX(k_0, k) - enddo do k = kte, kts, -1 - if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then - xslw1 = 4.01 + alog10(mvd_r(k)) - else - xslw1 = 0.01 - endif - ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) - zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 - if (rand1 .ne. 0.0) then - zans1 = MAX(2., MIN(zans1, 7.)) - endif + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -2437,12 +2421,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & do k = kts, kte !> - Rain self-collection follows Seifert, 1994 and drop break-up -!! follows Verlinde and Cotton, 1993. RAIN2M +!! follows Verlinde and Cotton, 1993. Updated after Saleeby et al 2022. RAIN2M if (L_qr(k) .and. mvd_r(k).gt. D0r) then -!-GT Ef_rr = 1.0 -!-GT if (mvd_r(k) .gt. 1500.0E-6) then - Ef_rr = 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6)) -!-GT endif + Ef_rr = MAX(-0.1, 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6))) pnr_rcr(k) = Ef_rr * 2.0*nr(k)*rr(k) endif @@ -2908,7 +2889,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if (is_aerosol_aware .AND. homogIce .AND. (xni.le.499.E3) & + if (is_aerosol_aware .AND. homogIce .AND. (xni.le.999.E3) & & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts @@ -3244,7 +3225,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(499.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -3255,8 +3236,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.499.E3) & - niten(k) = (499.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.999.E3) & + niten(k) = (999.E3-ni1d(k)*rho(k))*odts*orho !> - Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -3483,28 +3464,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ -! Ming Hu: go back to old version for Spring experiment 2021 - - N0_min = gonv_max - k_0 = kts do k = kte, kts, -1 - if (temp(k).ge.270.65) k_0 = MAX(k_0, k) - enddo - do k = kte, kts, -1 - if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then - xslw1 = 4.01 + alog10(mvd_r(k)) - else - xslw1 = 0.01 - endif - ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) - zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 - if (rand1 .ne. 0.0) then - zans1 = MAX(2., MIN(zans1, 7.)) - endif + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -3859,15 +3823,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t3_vts = Kap0*csg(1)*ils1**cse(1) t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (temp(k).gt. (T_0+0.1)) then -!Ming Hu: go back to old version for Spring experiment 2021 - vtsk(k) = MAX(vts*vts_boost(k), & - & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) ! -! DH* The version below is supposed to be a better formulation, -! but gave worse results in RAPv5/HRRRv4 than the line above. - ! this formulation for RAPv5/HRRRv4, reverted 20 Feb 2020 -! SR = rs(k)/(rs(k)+rr(k)) -! vtsk(k) = vts*SR + (1.-SR)*vtrk(k) + if (prr_sml(k) .gt. 0.0) then +! vtsk(k) = MAX(vts*vts_boost(k), & +! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) + SR = rs(k)/(rs(k)+rr(k)) + vtsk(k) = vts*SR + (1.-SR)*vtrk(k) + !vtsk1(k)=vtsk(k) else vtsk(k) = vts*vts_boost(k) !vtsk1(k)=vtsk(k) @@ -3951,7 +3912,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo - !if (rr(kts).gt.R1*10.) & if (rr(kts).gt.R1*1000.) & pptrain = pptrain + sed_r(kts)*DT*onstep(1) enddo @@ -4043,7 +4003,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo - !if (ri(kts).gt.R1*10.) & if (ri(kts).gt.R1*1000.) & pptice = pptice + sed_i(kts)*DT*onstep(2) enddo @@ -4071,8 +4030,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo - !if (rs(kts).gt.R1*10.) & - !-- 8apr22 communication with Greg if (rs(kts).gt.R1*1000.) & pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) enddo @@ -4101,8 +4058,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo - !if (rg(kts).gt.R1*10.) & - !-- 8apr22 - communication with Greg if (rg(kts).gt.R1*1000.) & pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) enddo @@ -4127,7 +4082,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtg = 0. if (rg(k).gt. R1) then ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + zans1 = 3.3 + 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 @@ -4227,7 +4182,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 499.D3/rho(k)) + 999.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) @@ -5692,7 +5647,7 @@ end FUNCTION iceKoop !+---+-----------------------------------------------------------------+ !>\ingroup aathompson -!! Helper routine for Phillips et al (2008) ice nucleation. Trude +!! Helper routine for Phillips et al (2008) ice nucleation. REAL FUNCTION delta_p (yy, y1, y2, aa, bb) IMPLICIT NONE @@ -5735,6 +5690,7 @@ END FUNCTION delta_p !! schemes. Since only the smallest snowflakes should impact !! radiation, compute from first portion of complicated Field number !! distribution, not the second part, which is the larger sizes. + subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & re_qc1d, re_qi1d, re_qs1d, kts, kte) @@ -5850,8 +5806,9 @@ end subroutine calc_effectRad !! library of routines. The meltwater fraction is simply the amount !! of frozen species remaining from what initially existed at the !! melting level interface. + subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti_org, & + t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, & vt_dBZ, first_time_step) IMPLICIT NONE @@ -5882,12 +5839,11 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg - REAL:: a_, b_, loga_, tc0 + REAL:: a_, b_, loga_, tc0, SR DOUBLE PRECISION:: fmelt_s, fmelt_g INTEGER:: i, k, k_0, kbot, n - LOGICAL, INTENT(IN):: melti_org - LOGICAL :: melti + LOGICAL, INTENT(IN):: melti LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg DOUBLE PRECISION:: cback, x, eta, f_d @@ -5906,14 +5862,9 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & else do_vt_dBZ = .false. allow_wet_snow = .true. - allow_wet_graupel = .true. + allow_wet_graupel = .false. endif -!Ming Hu hardwired for Spring Experiment testing - allow_wet_snow = .true. - allow_wet_graupel = .false. - melti=.true. - do k = kts, kte dBZ(k) = -35.0 enddo @@ -6025,34 +5976,16 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then -! Ming Hu: go back to old version for Spring experiment 2021 - - N0_min = gonv_max - k_0 = kts - do k = kte, kts, -1 - if (temp(k).ge.270.65) k_0 = MAX(k_0, k) - enddo do k = kte, kts, -1 - if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then - xslw1 = 4.01 + alog10(mvd_r(k)) - else - xslw1 = 0.01 - endif - ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) - zans1 = (3.1 +(100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1))) + rand1 - if (rand1 .ne. 0.0) then - zans1 = MAX(2., MIN(zans1, 7.)) - endif + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min 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 - endif !+---+-----------------------------------------------------------------+ @@ -6099,7 +6032,8 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..Reflectivity contributed by melting snow if (allow_wet_snow .and. L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.05d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) + SR = MAX(0.01, MIN(1.0 - rs(k)/(rs(k) + rr(k)), 0.99)) + fmelt_s = DBLE(SR*SR) eta = 0.d0 oM3 = 1./smoc(k) M0 = (smob(k)*oM3) @@ -6122,7 +6056,8 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..Reflectivity contributed by melting graupel if (allow_wet_graupel .and. L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.05d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) + SR = MAX(0.01, MIN(1.0 - rg(k)/(rg(k) + rr(k)), 0.99)) + fmelt_g = DBLE(SR*SR) eta = 0.d0 lamg = 1./ilamg(k) do n = 1, nrbins @@ -6193,27 +6128,27 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & end subroutine calc_refl10cm ! -!------------------------------------------------------------------- +!+---+-----------------------------------------------------------------+ +!>\ingroup aathompson +!! This routine is a semi-Lagrangain forward advection for hydrometeors +!! with mass conservation and positive definite advection 2nd order +!! interpolation with monotonic piecewise parabolic method is used. +!! This routine is under assumption of decfl < 1 for semi_Lagrangian +!! +!! dzl depth of model layer in meter +!! wwl terminal velocity at model layer m/s +!! rql dry air density*mixing ratio +!! precip precipitation at surface +!! dt time step +!! +!! author: hann-ming henry juang +!! implemented by song-you hong +!! reference: Juang, H.-M., and S.-Y. Hong, 2010: Forward semi-Lagrangian +!! advection with mass conservation and positive definiteness for +!! falling hydrometeors. Mon. Wea.Rev., 138, 1778-1791. + SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) -!------------------------------------------------------------------- -! -! This routine is a semi-Lagrangain forward advection for hydrometeors -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise parabolic method is used. -! This routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql dry air density*mixing ratio -! precip precipitation at surface -! dt time step -! -! author: hann-ming henry juang -! implemented by song-you hong -! reference: Juang, H.-M., and S.-Y. Hong, 2010: Forward semi-Lagrangian advection -! with mass conservation and positive definiteness for falling -! hydrometeors. *Mon. Wea. Rev.*, *138*, 1778-1791 -! + implicit none integer, intent(in) :: km @@ -6227,7 +6162,7 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) real zsum,qsum,dim,dip,con1,fa1,fa2 real allold, decfl real dz(km), ww(km), qq(km) - real wi(km+1), zi(km+1), za(km+2) !hmhj + real wi(km+1), zi(km+1), za(km+2) real qn(km) real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) ! @@ -6275,12 +6210,12 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) enddo wi(km) = 0.5*(ww(km)+ww(km-1)) wi(km+1) = ww(km) -! + ! terminate of top of raingroup do k=2,km if( ww(k).eq.0.0 ) wi(k)=ww(k-1) enddo -! + ! diffusivity of wi con1 = 0.05 do k=km,1,-1 @@ -6293,18 +6228,18 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) do k=1,km+1 za(k) = zi(k) - wi(k)*dt enddo - za(km+2) = zi(km+1) !hmhj -! - do k=1,km+1 !hmhj + za(km+2) = zi(km+1) + + do k=1,km+1 dza(k) = za(k+1)-za(k) enddo -! + ! computer deformation at arrival point do k=1,km qa(k) = qq(k)*dz(k)/dza(k) enddo qa(km+1) = 0.0 -! + ! estimate values at arrival cell interface with monotone do k=2,km dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) @@ -6325,7 +6260,7 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) qmi(1)=qa(1) qmi(km+1)=qa(km+1) qpi(km+1)=qa(km+1) -! + ! interpolation to regular point qn = 0.0 kb=1 @@ -6345,7 +6280,7 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) cycle find_kb endif enddo find_kb - find_kt : do kk=kt,km+2 !hmhj + find_kt : do kk=kt,km+2 if( zi(k+1).le.za(kk) ) then kt = kk exit find_kt @@ -6388,35 +6323,30 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,dt,R1) endif cycle intp endif -! + enddo intp -! + ! rain out sum_precip: do k=1,km if( za(k).lt.0.0 .and. za(k+1).le.0.0 ) then -!hmhj precip = precip + qa(k)*dza(k) cycle sum_precip else if ( za(k).lt.0.0 .and. za(k+1).gt.0.0 ) then -!hmhj -!hmhj precip(i) = precip(i) + qa(k)*(0.0-za(k)) - th = (0.0-za(k))/dza(k) !hmhj - th2 = th*th !hmhj - qqd = 0.5*(qpi(k)-qmi(k)) !hmhj - qqh = qqd*th2+qmi(k)*th !hmhj - precip = precip + qqh*dza(k) !hmhj + th = (0.0-za(k))/dza(k) + th2 = th*th + qqd = 0.5*(qpi(k)-qmi(k)) + qqh = qqd*th2+qmi(k)*th + precip = precip + qqh*dza(k) exit sum_precip endif exit sum_precip enddo sum_precip -! + ! replace the new values rql(:) = max(qn(:),R1) -! -! ---------------------------------- -! + END SUBROUTINE semi_lagrange_sedim -!+---+-----------------------------------------------------------------+ + !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson From 06cb687d5c57d90945e9db0cc40de68b4475edd5 Mon Sep 17 00:00:00 2001 From: "Ming.Hu" Date: Fri, 7 Oct 2022 16:56:51 +0000 Subject: [PATCH 48/50] MYNN code changes from Joe. --- physics/module_bl_mynn.F90 | 900 +++++++++++++++++++---------------- physics/module_sf_mynn.F90 | 441 +++++++++-------- physics/module_sf_ruclsm.F90 | 25 +- physics/mynnedmf_wrapper.F90 | 31 +- physics/mynnsfc_wrapper.F90 | 1 + physics/sgscloud_radpre.F90 | 25 +- 6 files changed, 761 insertions(+), 662 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 464890ad66..d1fae478d2 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -248,7 +248,7 @@ MODULE module_bl_mynn xlvcp , tv0 , tv1 , tref , & zero , half , one , two , & onethird , twothirds , tkmin , t0c , & - tice + tice , kind_phys IMPLICIT NONE @@ -301,6 +301,7 @@ MODULE module_bl_mynn ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 @@ -383,32 +384,30 @@ MODULE module_bl_mynn SUBROUTINE mynn_bl_driver( & &initflag,restart,cycling, & &delt,dz,dx,znt, & - &u,v,w,th,sqv3D,sqc3D,sqi3D, & + &u,v,w,th,sqv3d,sqc3d,sqi3d, & &qnc,qni, & &qnwfa,qnifa,ozone, & - &p,exner,rho,T3D, & + &p,exner,rho,t3d, & &xland,ts,qsfc,ps, & &ust,ch,hfx,qfx,rmol,wspd, & &uoce,voce, & !ocean current &vdfg, & !Katata-added for fog dep - &Qke,qke_adv, & + &qke,qke_adv, & &sh3d,sm3d, & - &nchem,kdvel,ndvel, & !Smoke/Chem variables &chem3d,vdep,smoke_dbg, & - &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,enh_mix,rrfs_sd, & ! end smoke/chem variables - - &Tsq,Qsq,Cov, & - &RUBLTEN,RVBLTEN,RTHBLTEN, & - &RQVBLTEN,RQCBLTEN,RQIBLTEN, & - &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN, & - &DOZONE, & + &frp,emis_ant_no, & ! JLS/RAR to adjust exchange coeffs + &mix_chem,enh_mix,rrfs_sd, & ! end smoke/chem variables + &tsq,qsq,cov, & + &rublten,rvblten,rthblten, & + &rqvblten,rqcblten,rqiblten, & + &rqncblten,rqniblten, & + &rqnwfablten,rqnifablten, & + &dozone, & &exch_h,exch_m, & - &Pblh,kpbl, & + &pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &dqke,qwt,qshear,qbuoy,qdiss, & &qc_bl,qi_bl,cldfra_bl, & &bl_mynn_tkeadvect, & &bl_mynn_tkebudget, & @@ -428,7 +427,7 @@ SUBROUTINE mynn_bl_driver( & &det_thl3D,det_sqv3D, & &nupdraft,maxMF,ktop_plume, & &spp_pbl,pattern_spp_pbl, & - &RTHRATEN, & + &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & &FLAG_OZONE & @@ -453,7 +452,7 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl - REAL, INTENT(in) :: closure + REAL(kind=kind_phys), INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE @@ -480,71 +479,68 @@ 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, INTENT(in) :: delt - REAL, DIMENSION(:), INTENT(in) :: dx - REAL, DIMENSION(:,:), INTENT(in) :: dz, & + REAL(kind=kind_phys), INTENT(in) :: delt + REAL(kind=kind_phys), DIMENSION(:), INTENT(in) :: dx + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(:,:), INTENT(in):: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(:,:), INTENT(in):: ozone - REAL, DIMENSION(:), INTENT(in) :: xland,ust, & - &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in):: ozone + REAL(kind=kind_phys), DIMENSION(:), INTENT(in):: ust, & + &ch,qsfc,ps,wspd + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqniblten,rqncblten, & + &rqnwfablten,rqnifablten + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten - REAL, DIMENSION(:,:), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - - REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - - REAL, DIMENSION(:,:), INTENT(out) :: & - &exch_h,exch_m + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m + REAL, DIMENSION(:), INTENT(in) :: xland,ts,znt,hfx,qfx, & + &uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + REAL(kind=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) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(:), INTENT(inout) :: Pblh,rmol + REAL(kind=kind_phys), DIMENSION(:), INTENT(inout) :: Pblh + REAL, DIMENSION(:), INTENT(inout) :: rmol REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(:), INTENT(OUT) :: & - &maxmf + REAL(kind=kind_phys), DIMENSION(:), INTENT(out) :: maxmf - REAL, DIMENSION(:,:), INTENT(inout) :: & - &el_pbl + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. ! 1D (local) budget arrays are used for passing between subroutines. REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + REAL(kind=kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& + REAL, 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, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION(:, :, :), INTENT(INOUT) :: chem3d - REAL, DIMENSION(:, :), INTENT(IN) :: vdep - REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + REAL(kind=kind_phys), DIMENSION(:, :, :), INTENT(INOUT) :: chem3d + REAL(kind=kind_phys), DIMENSION(:, :), INTENT(IN) :: vdep + REAL(kind=kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -553,68 +549,82 @@ SUBROUTINE mynn_bl_driver( & !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm, thlsg, sqwsg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & - &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & + INTEGER :: i,j,k,kproblem + REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw, & + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &Vt, Vq, sgm, thlsg, sqwsg, vdfg + REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & + &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & + &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & &dqnwfa1,dqnifa1,dozone1 !mass-flux variables REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & &edmf_thl1,edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & - &edmf_qt_dd1,edmf_thl_dd1, & + REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & + &edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,& + REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & + REAL,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 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw REAL :: 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,sqc9,sqi9 + & th_sfc,ztop_plume,sqc9,sqi9,wsp !top-down diffusion REAL, DIMENSION(ITS:ITE) :: maxKHtopdown REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE + LOGICAL :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) ::rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + REAL(kind=kind_phys), DIMENSION( :, :), INTENT(IN) :: pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub - real :: delt2 - - IF ( debug_code ) THEN - if (idbg .lt. ime) then - print*,'in MYNN driver; at beginning' - print*," th(1:5)=",th(idbg,1:5) - print*," u(1:5)=",u(idbg,1:5) - print*," v(1:5)=",v(idbg,1:5) - print*," w(1:5)=",w(idbg,1:5) - print*," sqv(1:5)=",sqv3D(idbg,1:5) - print*," p(1:5)=",p(idbg,1:5) - print*," rho(1:5)=",rho(idbg,1:5) - print*," xland=",xland(idbg)," u*=",ust(idbg), & - &" ts=",ts(idbg)," qsfc=",qsfc(idbg), & - &" z/L=",0.5*dz(idbg,1)*rmol(idbg)," ps=",ps(idbg),& - &" hfx=",hfx(idbg)," qfx=",qfx(idbg), & - &" wspd=",wspd(idbg)," znt=",znt(idbg) - endif - ENDIF + real(kind=kind_phys) :: delt2 + + + if (debug_code) then !check incoming values + do i=its,ite + problem = .false. + do k=kts,kte + wsp = sqrt(u(i,k)**2 + v(i,k)**2) + if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. & + wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. & + sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then + kproblem = k + problem = .true. + print*,"Incoming problem at: i=",i," k=1" + print*," QFX=",qfx(i)," HFX=",hfx(i) + print*," wsp=",wsp," T=",t3d(i,k) + print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k) + print*," u*=",ust(i)," wspd=",wspd(i) + print*," xland=",xland(i)," ts=",ts(i) + print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i) + print*," znt=",znt(i)," dx=",dx(i) + endif + enddo + if (problem) then + print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte)) + endif + enddo + endif !*** Begin debugging IMD=(IMS+IME)/2 @@ -1178,7 +1188,8 @@ SUBROUTINE mynn_bl_driver( & !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& + &dx(i),dz1,zw,u1,v1,xland(i), & + &thl,sqw,sqv,sqc,sqi, & &p1,ex1,tsq1,qsq1,cov1, & &Sh,el,bl_mynn_cloudpdf, & &qc_bl1D,qi_bl1D,cldfra_bl1D, & @@ -1193,7 +1204,7 @@ SUBROUTINE mynn_bl_driver( & CALL topdown_cloudrad(kts,kte,dz1,zw, & &xland(i),kpbl(i),PBLH(i), & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten, & + &cldfra_bl1D,rthraten(i,:), & &maxKHtopdown(i),KHtopdown,TKEprodTD ) ELSE maxKHtopdown(i) = 0.0 @@ -1311,7 +1322,6 @@ SUBROUTINE mynn_bl_driver( & !> - Call mynn_tendencies() to solve for tendencies of !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. CALL mynn_tendencies(kts,kte,i, & - &closure, & &delt, dz1, rho1, & &u1, v1, th1, tk1, qv1, & &qc1, qi1, qnc1, qni1, & @@ -1326,7 +1336,7 @@ SUBROUTINE mynn_bl_driver( & &Du1, Dv1, Dth1, Dqv1, & &Dqc1, Dqi1, Dqnc1, Dqni1, & &Dqnwfa1, Dqnifa1, Dozone1, & - &vdfg(i), diss_heat, & + &diss_heat, & ! mass flux components &s_aw1,s_awthl1,s_awqt1, & &s_awqv1,s_awqc1,s_awu1,s_awv1, & @@ -1350,7 +1360,7 @@ SUBROUTINE mynn_bl_driver( & IF ( mix_chem ) THEN - IF ( rrfs_sd ) THEN + IF ( rrfs_sd ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1362,19 +1372,19 @@ SUBROUTINE mynn_bl_driver( & &emis_ant_no(i), & &frp(i), rrfs_sd, & &enh_mix, smoke_dbg ) - ELSE - CALL mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &zero, & - &zero, rrfs_sd, & - &enh_mix, smoke_dbg ) - ENDIF + ELSE + CALL mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + ENDIF DO ic = 1,nchem DO k = kts,kte chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) @@ -1386,58 +1396,38 @@ SUBROUTINE mynn_bl_driver( & &dfm, dfh, dz1, K_m1, K_h1) !UPDATE 3D ARRAYS - DO k=KTS,KTE !KTF + do k=kts,kte exch_m(i,k)=K_m1(k) exch_h(i,k)=K_h1(k) - RUBLTEN(i,k)=du1(k) - RVBLTEN(i,k)=dv1(k) - RTHBLTEN(i,k)=dth1(k) - RQVBLTEN(i,k)=dqv1(k) - IF(bl_mynn_cloudmix > 0)THEN - IF (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (FLAG_QI) RQIBLTEN(i,k)=dqi1(k) - ELSE - IF (FLAG_QC) RQCBLTEN(i,k)=0. - IF (FLAG_QI) RQIBLTEN(i,k)=0. - ENDIF - IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) - IF (FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) - IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) - IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) - ELSE - IF (FLAG_QNC) RQNCBLTEN(i,k)=0. - IF (FLAG_QNI) RQNIBLTEN(i,k)=0. - IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=0. - IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=0. - ENDIF - DOZONE(i,k)=DOZONE1(k) - - IF(icloud_bl > 0)THEN - !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS - IF (CLDFRA_BL1D(k) < cldfra_bl1D_old(k)) THEN - !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER - !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE - !TIMESCALE. USE THE MINIMUM OF THE TWO. - ts_decay = MIN( 1800., 2.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) - ! qc_bl2 and qi_bl2 are linked to decay rates - qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) - qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) - qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-5) * delt/ts_decay)) - qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-6) * delt/ts_decay)) - IF (cldfra_bl(i,k) < 0.005 .OR. & - (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN - CLDFRA_BL(i,k)= 0. - QC_BL(i,k) = 0. - QI_BL(i,k) = 0. - ENDIF - ELSE - qc_bl(i,k)=qc_bl1D(k) - qi_bl(i,k)=qi_bl1D(k) - cldfra_bl(i,k)=cldfra_bl1D(k) - ENDIF - ENDIF + rublten(i,k)=du1(k) + rvblten(i,k)=dv1(k) + rthblten(i,k)=dth1(k) + rqvblten(i,k)=dqv1(k) + if (bl_mynn_cloudmix > 0) then + if (FLAG_QC) rqcblten(i,k)=dqc1(k) + if (FLAG_QI) rqiblten(i,k)=dqi1(k) + else + if (FLAG_QC) rqcblten(i,k)=0. + if (FLAG_QI) rqiblten(i,k)=0. + endif + if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then + if (FLAG_QNC) rqncblten(i,k)=dqnc1(k) + if (FLAG_QNI) rqniblten(i,k)=dqni1(k) + if (FLAG_QNWFA) rqnwfablten(i,k)=dqnwfa1(k) + if (FLAG_QNIFA) rqnifablten(i,k)=dqnifa1(k) + else + if (FLAG_QNC) rqncblten(i,k)=0. + if (FLAG_QNI) rqniblten(i,k)=0. + if (FLAG_QNWFA) rqnwfablten(i,k)=0. + if (FLAG_QNIFA) rqnifablten(i,k)=0. + endif + dozone(i,k)=dozone1(k) + + if (icloud_bl > 0) then + qc_bl(i,k)=qc_bl1D(k) + qi_bl(i,k)=qi_bl1D(k) + cldfra_bl(i,k)=cldfra_bl1D(k) + endif el_pbl(i,k)=el(k) qke(i,k)=qke1(k) @@ -1446,22 +1436,22 @@ SUBROUTINE mynn_bl_driver( & cov(i,k)=cov1(k) sh3d(i,k)=sh(k) sm3d(i,k)=sm(k) - ENDDO !end-k + enddo !end-k - IF ( bl_mynn_tkebudget ) THEN + if ( bl_mynn_tkebudget ) then !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) k=kts qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - DO k = kts,kte-1 + do k = kts,kte-1 qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z qWT(i,k)=qWT1(k) qDISS(i,k)=qDISS1(k) dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt - ENDDO + enddo !! Upper boundary conditions k=kte qSHEAR(i,k)=0. @@ -1469,7 +1459,7 @@ SUBROUTINE mynn_bl_driver( & qWT(i,k)=0. qDISS(i,k)=0. dqke(i,k)=0. - ENDIF + endif !update updraft/downdraft properties if (bl_mynn_output > 0) THEN !research mode == 1 @@ -1508,9 +1498,9 @@ SUBROUTINE mynn_bl_driver( & DO k = kts,kte IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 0.9 )print*,& + IF ( ABS(vt(k)) > 2.0 )print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 6000.)print*,& + IF ( ABS(vq(k)) > 7000.)print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) @@ -1639,22 +1629,20 @@ SUBROUTINE mym_initialize ( & INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf LOGICAL, INTENT(IN) :: INITIALIZE_QKE ! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx + REAL, INTENT(IN) :: rmo, Psig_bl + REAL(kind=kind_phys), INTENT(IN) :: dx, ust, zi REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& edmf_w1,edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - REAL, DIMENSION(kts:kte) :: & &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& &gm,gh,sm,sh,qkw,vt,vq INTEGER :: k,l,lmax REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg - + REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl @@ -1984,7 +1972,8 @@ SUBROUTINE mym_length ( & INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl + REAL(kind=kind_phys), INTENT(IN) :: dx,zi REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& edmf_w1,edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el @@ -1994,7 +1983,7 @@ SUBROUTINE mym_length ( & REAL, DIMENSION(kts:kte), INTENT(IN) :: theta REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + REAL :: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: @@ -2036,7 +2025,7 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.21 + alp1 = 0.23 alp2 = 1.0 alp3 = 5.0 alp4 = 100. @@ -2118,9 +2107,9 @@ SUBROUTINE mym_length ( & CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH cns = 3.5 - alp1 = 0.21 + alp1 = 0.22 !0.21 alp2 = 0.3 - alp3 = 1.5 + alp3 = 2.0 !1.5 alp4 = 5.0 alp5 = 0.3 alp6 = 50. @@ -2151,7 +2140,7 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. zi2+h1) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2174,17 +2163,17 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - alp2 = 0.3 + 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) - bv = SQRT( gtr*dtv(k) ) + alp2 = 0.3 !test+ 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) + bv = max( sqrt( gtr*dtv(k) ), 0.001) !elb = alp2*qkw(k) / bv & ! formulation, ! & *( 1.0 + alp3/alp2*& ! except keep ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk - elb = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) elf = 0.65 * qkw(k)/bv - !elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k)*edmf_w1(k)/bv) + elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 elf = elb @@ -2223,9 +2212,9 @@ SUBROUTINE mym_length ( & Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.21 + alp1 = 0.22 !0.21 alp2 = 0.30 - alp3 = 1.5 + alp3 = 2.0 !1.5 alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length @@ -2258,7 +2247,7 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. PBLH_PLUS_ENT) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2284,7 +2273,7 @@ SUBROUTINE mym_length ( & bv = MAX( SQRT( gtr*dtv(k) ), 0.001) !elb_mf = alp2*qkw(k) / bv & elb_mf = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) @@ -2773,10 +2762,11 @@ SUBROUTINE mym_turbulence ( & #endif INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL(kind=kind_phys), INTENT(IN) :: closure + REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu + REAL(kind=kind_phys), INTENT(IN) :: dx,zi REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& &TKEprodTD,thlsg,qwsg @@ -2798,7 +2788,7 @@ SUBROUTINE mym_turbulence ( & REAL :: e6c,dzk,afk,abk,vtt,vqq,& &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: zi, cldavg + REAL :: cldavg REAL, DIMENSION(kts:kte), INTENT(in) :: theta REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod @@ -3343,12 +3333,12 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: closure + REAL(kind=kind_phys), INTENT(IN) :: closure INTEGER, INTENT(IN) :: bl_mynn_edmf_tke - REAL, INTENT(IN) :: delt REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, INTENT(IN) :: flt, flq, pmz, phh + REAL(kind=kind_phys), INTENT(IN) :: ust, delt REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov ! WA 8/3/15 REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw @@ -3731,17 +3721,17 @@ END SUBROUTINE mym_predict !! subgrid cloud fraction and mixing ratio as well as the functions used to !! calculate the buoyancy flux. Different cloud PDFs can be selected by !! use of the namelist parameter \p bl_mynn_cloudpdf . - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, & - & thl, qw, qv, qc, qi, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& - & qc_bl1D, qi_bl1D, & - & cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, zw, u1, v1, xland,& + & thl, qw, qv, qc, qi, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf, & + & qc_bl1D, qi_bl1D, & + & cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) !------------------------------------------------------------------- @@ -3752,11 +3742,12 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, INTENT(IN) :: HFX1,rmo,xland + REAL(kind=kind_phys), INTENT(IN) :: dx,pblh1 REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & - &tsq, qsq, cov, th + &tsq, qsq, cov, th, u1, v1 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm @@ -3768,7 +3759,7 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: 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 + &qmq,qsat_tk,wsp,wspfac INTEGER :: i,j,k REAL :: erf @@ -3779,7 +3770,8 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 - REAL :: lfac + REAL :: cfmax + INTEGER, PARAMETER :: buoy_opt=1 ! 0: traditional SD77, 1: CB02,CB05 !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3981,76 +3973,69 @@ SUBROUTINE mym_condensation (kts,kte, & sgm(k) = SQRT( r3sq ) !Set limits on sigma relative to saturation water vapor sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tk*0.040 ) !Note: 0.02 results in SWDOWN similar + sgm(k) = MAX( sgm(k), qsat_tk*0.035 ) !Note: 0.02 results in SWDOWN similar !to the first-order version of sigma q1(k) = qmq / sgm(k) ! Q1, the normalized saturation - - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - !This form only allows cloud fractions out to q1 = -1.8 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) - !This form only allows cloud fractions out to q1 = -1 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - - END DO - - ! Specify hydrometeors - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - ! "fng" represents the non-Gaussian contribution to the liquid - ! water flux; these formulations are from Cuijpers and Bechtold - ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, - ! hereafter BCMT95 - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) - - !CLOUD WATER AND ICE + q1k = q1(k) ! backup Q1 for later modification + + ! Specify cloud fraction + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02 + !wayne's - over-diffuse, when limits removed from vt & vq & fng + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) + !effort to reduce rh-dependency + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(2.9*(q1(k)+0.4)))) + cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.4)))) + !moderate - best compromise?? + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*(q1(k)+0.2)))) + !closer to original for Q1 < -1, best for holding onto stratus, not good flowers + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.9*(q1(k)+0.4)))) + + + ! Specify hydrometeors + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. IF (q1k < 0.) THEN !unsaturated ql_water = sgm(k)*EXP(1.2*q1k-1) 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 - !ql_ice = MIN(80.*qv(k),0.1)*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) - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) ENDIF - !In saturated grid cells, use average of current estimate and prev time step - IF ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) - IF ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) + !In saturated grid cells, use average of SGS and resolved values + if ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) + if ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) - IF (cldfra_bl1D(k) < 0.01) THEN + if (cldfra_bl1D(k) < 0.01) then ql_ice = 0.0 ql_water = 0.0 cldfra_bl1D(k) = 0.0 - ENDIF + endif !PHASE PARTITIONING: Make some inferences about the relative amounts of !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, !use a simple temperature-dependent partitioning. -! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning -! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid -! liq_frac = 1.0 -! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice -! liq_frac = 0.0 -! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably -! ! large amounts; assume subgrid follows -! ! same partioning -! liq_frac = qc(k) / ( qc(k) + qi(k) ) -! ELSE -! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one -! ! species is very small, so make a temperature- -! ! depedent guess -! ENDIF -! ELSE ! no explicit condensate, so make a temperature-dependent guess - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) -! ENDIF + ! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning + ! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid + ! liq_frac = 1.0 + ! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice + ! liq_frac = 0.0 + ! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably + ! ! large amounts; assume subgrid follows + ! ! same partioning + ! liq_frac = qc(k) / ( qc(k) + qi(k) ) + ! ELSE + ! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one + ! ! species is very small, so make a temperature- + ! ! depedent guess + ! ENDIF + ! ELSE ! no explicit condensate, so make a temperature-dependent guess + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) + ! ENDIF qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice qi_bl1D(k) = (1.0-liq_frac)*ql_ice @@ -4058,15 +4043,17 @@ SUBROUTINE mym_condensation (kts,kte, & !Above tropopause: eliminate subgrid clouds from CB scheme if (k .ge. k_tropo-1) then cldfra_bl1D(K) = 0. - qc_bl1D(k) = 0. - qi_bl1D(k) = 0. + qc_bl1D(k) = 0. + qi_bl1D(k) = 0. endif - ENDDO - - !Buoyancy-flux-related calculations follow... - DO k = kts,kte-1 - t = th(k)*exner(k) + !Buoyancy-flux-related calculations follow... + !limiting Q1 to avoid too much diffusion in cloud layers + if ((xland-1.5).GE.0) then ! water + q1k=max(Q1(k),-2.5) + else ! land + q1k=max(Q1(k),-2.0) + endif ! "Fng" represents the non-Gaussian transport factor ! (non-dimensional) from Bechtold et al. 1995 ! (hereafter BCMT95), section 3(c). Their suggested @@ -4078,8 +4065,7 @@ SUBROUTINE mym_condensation (kts,kte, & !ELSE ! Fng = 1.-1.5*q1k !ENDIF - !limiting to avoid mixing away stratus, was -5 - q1k=MAX(Q1(k),-1.0) + ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) IF (q1k .GE. 1.0) THEN Fng = 1.0 ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN @@ -4089,42 +4075,70 @@ SUBROUTINE mym_condensation (kts,kte, & ELSE Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) ENDIF - Fng = MIN(Fng, 20.) - - xl = xl_blend(t) - 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 - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - MIN(cldfra_bl1D(K),0.5)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cldfra_bl1D(K),0.5)*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). + + if (buoy_opt .eq. 1) then + 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 + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + vt(k) = qww - cfmax*beta*bb*Fng - 1. + vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + else + + !original buoyancy flux functions from SD77 + eq1 = rrp*exp( -0.5*q1k*q1k ) + qll = max( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + q2p = xl/cp/exner(k) + + !qt is a THETA-V CONVERSION FOR TOTAL WATER + cfmax= min(cldfra_bl1D(K), 0.6) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cfmax + rac = alp(k)*( cfmax-qll*eq1 )*( q2p*qt-(1.+p608)*th(k) ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*th(k)-tv0 +rac + endif ! dampen the amplification factor (cld_factor) with height in order ! to limit excessively large cloud fractions aloft !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) - fac_damp = min(zagl * 0.01, 1.0) + !fac_damp = min(zagl * 0.01, 1.0) + wsp =sqrt(u1(k)**2 + v1(k)**2) + wspfac = 1.0 - min(max(0.,wsp-15),10.)/10. ! reduce as winds go from 15 to 25 m/s. + fac_damp = min(zagl * 0.0025, 1.0)*wspfac !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.22 )**2 - cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 - !cld_factor = 1.0 + !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 + !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 !too low of albedo + !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 + !make this enhancement over water only? + !if ((xland-1.5).GE.0) then ! water + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) + !else + ! cld_factor = 1.0 + !endif cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) - ENDDO + enddo END SELECT !end cloudPDF option - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + !For testing purposes only, option for isolating on the mass-flux clouds. IF (bl_mynn_cloudpdf .LT. 0) THEN DO k = kts,kte-1 cldfra_bl1D(k) = 0.0 @@ -4153,7 +4167,6 @@ END SUBROUTINE mym_condensation !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, !! qc, and qi SUBROUTINE mynn_tendencies(kts,kte,i, & - &closure, & &delt,dz,rho, & &u,v,th,tk,qv,qc,qi,qnc,qni, & &psfc,p,exner, & @@ -4166,7 +4179,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &dfm,dfh,dfq, & &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & &Dqnwfa,Dqnifa,Dozone, & - &vdfg1,diss_heat, & + &diss_heat, & &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & &s_awu,s_awv, & &s_awqnc,s_awqni, & @@ -4194,7 +4207,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(in) :: closure INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars @@ -4221,10 +4233,10 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &qnwfa,qnifa,ozone,dfm,dfh REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& &dqni,dqnc,dqnwfa,dqnifa,dozone - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,& - &psfc + REAL, INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce + REAL(kind=kind_phys), INTENT(IN) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2 + REAL ::wsp,wsp2,tk2,th2 LOGICAL :: problem integer :: kproblem @@ -4240,7 +4252,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface & khdz, kmdz REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: vdfg1 !Katata-fogdes REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc REAL :: ustdrag,ustdiff,qvflux REAL :: th_new,portion_qc,portion_qi,condensate,qsat @@ -4358,7 +4369,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=u(kte) ! CALL tridiag(kte,a,b,c,d) - 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 ! du(k)=(d(k-kts+1)-u(k))/delt @@ -4422,7 +4434,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=v(kte) ! CALL tridiag(kte,a,b,c,d) - 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 ! dv(k)=(d(k-kts+1)-v(k))/delt @@ -4489,8 +4502,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=thl(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 !thl(k)=d(k-kts+1) @@ -4552,8 +4565,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqw(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqw2) - CALL tridiag3(kte,a,b,c,d,sqw2) + CALL tridiag2(kte,a,b,c,d,sqw2) +! CALL tridiag3(kte,a,b,c,d,sqw2) ! DO k=kts,kte ! sqw2(k)=d(k-kts+1) @@ -4609,8 +4622,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqc2) - CALL tridiag3(kte,a,b,c,d,sqc2) + CALL tridiag2(kte,a,b,c,d,sqc2) +! CALL tridiag3(kte,a,b,c,d,sqc2) ! DO k=kts,kte ! sqc2(k)=d(k-kts+1) @@ -4687,8 +4700,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqv(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqv2) - CALL tridiag3(kte,a,b,c,d,sqv2) + CALL tridiag2(kte,a,b,c,d,sqv2) +! CALL tridiag3(kte,a,b,c,d,sqv2) ! DO k=kts,kte ! sqv2(k)=d(k-kts+1) @@ -4749,8 +4762,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqi(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqi2) - CALL tridiag3(kte,a,b,c,d,sqi2) + CALL tridiag2(kte,a,b,c,d,sqi2) +! CALL tridiag3(kte,a,b,c,d,sqi2) ! DO k=kts,kte ! sqi2(k)=d(k-kts+1) @@ -4787,8 +4800,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qni(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 !qni2(k)=d(k-kts+1) @@ -4828,8 +4841,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnc(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 !qnc2(k)=d(k-kts+1) @@ -4869,8 +4882,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnwfa(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 !qnwfa2(k)=d(k) @@ -4911,8 +4924,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnifa(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 !qnifa2(k)=d(k-kts+1) @@ -4950,8 +4963,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=ozone(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 !ozone2(k)=d(k-kts+1) @@ -5143,21 +5156,28 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & do k=kts,kte wsp = sqrt(u(k)**2 + v(k)**2) wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - if (wsp2 > 200.) then + th2 = th(k) + Dth(k)*delt + tk2 = th2*exner(k) + if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then problem = .true. - print*,"Huge wind speed: i=",i," k=",k," wsp=",wsp2 - print*," du=",du(k)*delt," dv=",dv(k)*delt + print*,"Outgoing problem at: i=",i," k=",k + print*," incoming wsp=",wsp," outgoing wsp=",wsp2 + print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 + print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) kproblem = k endif enddo if (problem) then - print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) endif endif @@ -5188,7 +5208,7 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt + real(kind=kind_phys), intent(in) :: delt real, dimension(kte), intent(in) :: dp, exner real, dimension(kte), intent(inout) :: qv, qc, qi, th real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth @@ -5265,20 +5285,21 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & dfh, & s_aw, s_awchem, & emis_ant_no, frp, rrfs_sd, & - enh_mix, smoke_dbg ) + enh_mix, smoke_dbg ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: delt,flt + REAL, INTENT(IN) :: flt + REAL(kind=kind_phys), INTENT(IN) :: delt,pblh INTEGER, INTENT(IN) :: nchem, kdvel, ndvel REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL, INTENT(IN) :: emis_ant_no,frp,pblh + REAL(kind=kind_phys), INTENT(IN) :: emis_ant_no,frp LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars @@ -5633,7 +5654,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(OUT) :: zi + REAL(kind=kind_phys), INTENT(OUT) :: zi REAL, INTENT(IN) :: landsea REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D @@ -5825,8 +5846,9 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma - REAL, INTENT(IN) :: DT,UST,FLT,FLTV,FLQ,FLQV,PBLH,& - DX,Psig_shcu,landsea,ts + REAL, INTENT(IN) :: FLT,FLTV,FLQ,FLQV,& + Psig_shcu,landsea,ts + REAL(kind=kind_phys), INTENT(IN) :: dx,dt,ust,pblh LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA ! outputs - updraft properties @@ -5836,7 +5858,8 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE) :: edmf_th ! output INTEGER, INTENT(OUT) :: nup2,ktop - REAL, INTENT(OUT) :: maxmf,ztop + REAL(kind=kind_phys), INTENT(OUT) :: maxmf + REAL, INTENT(OUT) :: ztop ! outputs - variables needed for solver REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi s_awthl, & !sum ai*rho*wi*phii @@ -5854,7 +5877,7 @@ SUBROUTINE DMP_mf( & REAL,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=10, debug_mf=0 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the @@ -5870,7 +5893,7 @@ SUBROUTINE DMP_mf( & REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,qtk,rho_int ! w parameters REAL,PARAMETER :: & @@ -5911,13 +5934,14 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& + REAL :: 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, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl + REAL :: THp, QTp, QCp, QCs, esat, qsl REAL :: csigma,acfac,ac_wsp,ac_cld !plume overshoot @@ -5938,7 +5962,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& - qc_plume + qc_plume,exc_heat,exc_moist,tk_int REAL, PARAMETER :: Cdet = 1./45. REAL, 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 @@ -6207,13 +6231,28 @@ SUBROUTINE DMP_mf( & UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQC(1,I)=0.0 !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +exc_fac*UPW(1,I)*sigmaQT/sigmaW + + 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_fac*UPW(1,I)*sigmaTH/sigmaW + & + 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_fac*UPW(1,I)*sigmaTH/sigmaW + & + 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 + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) @@ -6306,14 +6345,14 @@ SUBROUTINE DMP_mf( & !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp - IF ( mix_chem ) THEN + if ( mix_chem ) then do ic = 1,nchem ! Exponential Entrainment: !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp ! Linear entrainment: chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp enddo - ENDIF + endif ! Define pressure at model interface Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) @@ -6486,7 +6525,7 @@ SUBROUTINE DMP_mf( & 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 !to conform to grid mean properties, move qc to qv in grid mean - !saturated layers, so total water fluxes are preserve but + !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then qc_plume = UPQC(K,i) @@ -6704,22 +6743,22 @@ SUBROUTINE DMP_mf( & ! 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)THEN - - !interpolate plume thl, th, and qt to mass levels + IF(k > KTOP) exit + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)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)) QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) !convert TH to T - t = THp*exner(k) +! t = THp*exner(k) !SATURATED VAPOR PRESSURE - esat = esat_blend(t) + esat = esat_blend(tk(k)) !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) !condensed liquid in the plume on mass levels IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN - QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) + QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) ELSE QCp = MAX(edmf_qc(k),edmf_qc(k-1)) ENDIF @@ -6735,7 +6774,7 @@ SUBROUTINE DMP_mf( & b9 = a*rsl ! CB02 variable "b" q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from ! "b9" in CB02 by a factor ! of T/theta. Strictly, b9 above is formulated in @@ -6755,17 +6794,32 @@ SUBROUTINE DMP_mf( & endif !CB form: - !sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - ! & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components !Per S.DeRoode 2009? - sigq = 10. * edmf_a(k) * (edmf_qt(k)-qt(k)) - - sigq = MAX(sigq, 1.0E-6) + !sigq = 4. * Aup * (QTp - qt(k)) + !constrain sigq wrt saturation: + sigq = max(sigq, qsat_tk*0.02 ) + sigq = min(sigq, qsat_tk*0.25 ) qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; - ! the numerator of Q1 - mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + Q1 = qmq/sigq ! the numerator of Q1 + + if ((landsea-1.5).GE.0) then ! WATER + mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + mf_cf = max(mf_cf, 1.2 * Aup) + else ! LAND + !mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) ! New WA fit + mf_cf = max(mf_cf, 1.75 * Aup) + endif + + ! WA TEST 4/15/22 use fit to Aup rather than CB + !IF (Aup > 0.1) THEN + ! mf_cf = 2.5 * Aup + !ELSE + ! mf_cf = 1.8 * Aup + !ENDIF !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" @@ -6776,61 +6830,64 @@ SUBROUTINE DMP_mf( & !ENDIF ! Update cloud fractions and specific humidities in grid cells - ! where the mass-flux scheme is active. Now, we also use the - ! stratus component of the SGS clouds as well. The stratus cloud - ! fractions (Ac_strat) are reduced slightly to give way to the - ! mass-flux SGS cloud fractions (Ac_mf). - IF (cldfra_bl1d(k) < 0.5) THEN - IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN - !cldfra_bl1d(k) = mf_cf - !qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - Ac_mf = mf_cf - Ac_strat = cldfra_bl1d(k)*(1.0-mf_cf) - cldfra_bl1d(k) = Ac_mf + Ac_strat - !dillute Qc from updraft area to larger cloud area - qc_mf = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - !The mixing ratios from the stratus component are not well - !estimated in shallow-cumulus regimes. Ensure stratus clouds - !have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (qc_mf*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ELSE - !cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) - !qc_bl1d(k) = QCp - Ac_mf = 0.5*(edmf_a(k)+edmf_a(k-1)) - Ac_strat = cldfra_bl1d(k)*(1.0-Ac_mf) - cldfra_bl1d(k)=Ac_mf + Ac_strat - qc_mf = QCp - !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ENDIF - ELSE - Ac_mf = mf_cf - ENDIF + ! where the mass-flux scheme is active. The specific humidities + ! are converted to grid means (not in-cloud quantities). + + if ((landsea-1.5).GE.0) then ! water + !don't overwrite stratus CF & qc_bl - degrades marine stratus + if (cldfra_bl1d(k) < cf_thresh) then + 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 + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif + else ! land + 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 + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. The - !cloud-fraction bounding was added to improve cloud retention, - !following RAP and HRRR testing. - !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: - Q1 = qmq/MAX(sigq,1E-6) - Q1=MAX(Q1,-5.0) - IF (Q1 .GE. 1.0) THEN - Fng = 1.0 - ELSEIF (Q1 .GE. -1.7 .AND. Q1 .LT. 1.0) THEN - Fng = EXP(-0.4*(Q1-1.0)) - ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - ENDIF + !See mym_condensation for details on these formulations. + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with + !limits ,since they really should be recalculated after all the other changes...: + !Only overwrite vt & vq in non-stratus condition + if (cldfra_bl1d(k) < cf_thresh) then + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then + Fng = 1.0 + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then + Fng = EXP(-0.4*(Q1-1.0)) + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + endif - vt(k) = qww - MIN(0.40,Ac_mf)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.40,Ac_mf)*beta*a*Fng - tv0 - ENDIF - ENDDO + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif + endif + enddo !k-loop ENDIF !end nup2 > 0 @@ -7009,11 +7066,12 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & INTEGER, INTENT(IN) :: KTS,KTE,KPBL REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,rthraten,dz + THV,P,rho,exner,dz + REAL(kind=kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH - + REAL, INTENT(IN) :: WTHL,WQT + REAL(kind=kind_phys), INTENT(IN) :: dt,ust,pblh ! outputs - downdraft properties REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd @@ -7366,7 +7424,7 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL,INTENT(IN) :: dx,PBL1 + REAL(kind=kind_phys), INTENT(IN) :: dx,pbl1 REAL, INTENT(OUT) :: Psig_bl,Psig_shcu REAL :: dxdh @@ -7642,9 +7700,11 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & !input integer, intent(in) :: kte,kts real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D + real(kind=kind_phys), dimension(kts:kte), intent(in) :: rthraten real, dimension(kts:kte+1), intent(in) :: zw - real, intent(in) :: pblh,xland + real(kind=kind_phys), intent(in) :: pblh + real, intent(in) :: xland integer,intent(in) :: kpbl !output real, intent(out) :: maxKHtopdown diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 0d81e145ae..c47414c60e 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -67,6 +67,7 @@ MODULE module_sf_mynn ! & p1000mb, ep_2 ! !For non-WRF + use machine, only : kind_phys use physcons, only : cp => con_cp, & & g => con_g, & & r_d => con_rd, & @@ -134,6 +135,7 @@ SUBROUTINE SFCLAY_mynn( & z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in + flag_restart, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -265,26 +267,26 @@ SUBROUTINE SFCLAY_mynn( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: itimestep,iter - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN) :: EP1,EP2,KARMAN - REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX + REAL(kind=kind_phys), INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 + REAL(kind=kind_phys), INTENT(IN) :: EP1,EP2,KARMAN + REAL(kind=kind_phys), INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: - INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt - logical, intent(in) :: compute_flux,compute_diag + integer, intent(in) :: ISFFLX, LSM, LSM_RUC + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + logical, intent(in) :: compute_flux,compute_diag integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) !Input data integer, dimension(ims:ime), intent(in) :: vegtype - real, dimension(ims:ime), intent(in) :: & + real(kind=kind_phys), dimension(ims:ime), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert !=================================== ! 3D VARIABLES !=================================== - REAL, DIMENSION( ims:ime, kms:kme ) , & + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme ) , & INTENT(IN ) :: dz8w, & QV3D, & P3D, & @@ -294,24 +296,24 @@ SUBROUTINE SFCLAY_mynn( & th3d,pi3d !GJF: This array must be assumed-shape since it is conditionally-allocated - REAL, DIMENSION( :,: ), & + REAL(kind=kind_phys), DIMENSION( :,: ), & INTENT(IN) :: pattern_spp_sfc !=================================== ! 2D VARIABLES !=================================== - REAL, DIMENSION( ims:ime ) , & + REAL(kind=kind_phys), DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL, DIMENSION( ims:ime ) , & + REAL(kind=kind_phys), DIMENSION( ims:ime ) , & INTENT(OUT ) :: U10,V10, & TH2,T2,Q2 - REAL, DIMENSION( ims:ime ) , & + REAL(kind=kind_phys), DIMENSION( ims:ime ) , & INTENT(INOUT) :: HFLX,HFX, & QFLX,QFX, & LH, & @@ -333,13 +335,14 @@ SUBROUTINE SFCLAY_mynn( & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter + LOGICAL, INTENT(IN) :: flag_restart - REAL, DIMENSION( ims:ime ), INTENT(IN) :: & + REAL(kind=kind_phys), DIMENSION(ims:ime ), INTENT(IN) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_wat, snowh_lnd, snowh_ice - REAL, DIMENSION( ims:ime), INTENT(INOUT) :: & + REAL(kind=kind_phys), DIMENSION(ims:ime), INTENT(INOUT) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & & UST_wat, UST_lnd, UST_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -412,11 +415,20 @@ SUBROUTINE SFCLAY_mynn( & IF (itimestep==1 .AND. iter==1) THEN DO i=its,ite - !Everything here is used before calculated - UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - MOL(i)=0.0 + + IF (.not. flag_restart) THEN + !Everything here is used before calculated + if (ust_wat(i) .lt. 1e-4 .or. ust_wat(i) .gt. 3.0) then + UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + endif + if (ust_lnd(i) .lt. 1e-4 .or. ust_lnd(i) .gt. 3.0) then + UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + endif + if (ust_ice(i) .lt. 1e-4 .or. ust_ice(i) .gt. 3.0) then + UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + endif + MOL(i)=0.0 + ENDIF ! restart QFLX(i)=0. HFLX(i)=0. if ( LSM == LSM_RUC ) then @@ -443,7 +455,7 @@ SUBROUTINE SFCLAY_mynn( & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -491,7 +503,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -531,12 +543,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & J, itimestep, iter, lsm, lsm_ruc + LOGICAL, INTENT(IN) :: flag_restart REAL, PARAMETER :: XKA=2.4E-5 !molecular diffusivity REAL, PARAMETER :: PRT=1. !prandlt number REAL, PARAMETER :: snowh_thresh = 50. !mm - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 - REAL, INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV !,DX + REAL(kind=kind_phys), INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 + REAL(kind=kind_phys), INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV !,DX !----------------------------- ! NAMELIST OPTIONS @@ -551,13 +564,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !Input data integer, dimension(ims:ime), intent(in) :: vegtype - real, dimension(ims:ime), intent(in) :: & + real(kind=kind_phys), dimension(ims:ime), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert !----------------------------- ! 1D ARRAYS !----------------------------- - REAL, DIMENSION( ims:ime ), INTENT(IN) :: MAVAIL, & + REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(IN) :: & + MAVAIL, & PBLH, & XLAND, & PSFCPA, & @@ -570,9 +584,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & dz8w1d, & dz2w1d - REAL, DIMENSION( ims:ime ), INTENT(OUT) :: QFX,HFX, & - RMOL - REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: HFLX,QFLX, & + REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(OUT) :: & + & QFX,HFX,RMOL,WSTAR + REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(INOUT) :: & + HFLX,QFLX, & LH,MOL, & QGH,QSFC, & ZNT, & @@ -590,12 +605,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter - REAL, DIMENSION( ims:ime ), INTENT(in) :: & + REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_wat, snowh_lnd, snowh_ice - REAL, DIMENSION( ims:ime ), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(inout) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & & UST_wat, UST_lnd, UST_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -613,12 +628,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & REAL, DIMENSION( its:ite ), INTENT(IN) :: rstoch1D ! DIAGNOSTIC OUTPUT - REAL, DIMENSION( ims:ime ), INTENT(OUT) :: U10,V10, & - TH2,T2,Q2 + REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(OUT) :: & + & U10,V10,TH2,T2,Q2 !-------------------------------------------- !JOE-additinal output - REAL, DIMENSION( ims:ime ), INTENT(OUT) :: wstar,qstar + REAL, DIMENSION( ims:ime ), INTENT(OUT) :: qstar !JOE-end ! CCPP error handling @@ -956,13 +971,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_wat(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_wat*WSPD_wat) - IF (ITIMESTEP == 1) THEN - rb_wat(I)=MAX(rb_wat(I),-2.0) - rb_wat(I)=MIN(rb_wat(I), 2.0) - ELSE - rb_wat(I)=MAX(rb_wat(I),-4.0) - rb_wat(I)=MIN(rb_wat(I), 4.0) - ENDIF + rb_wat(I)=MAX(rb_wat(I),-2.0) + rb_wat(I)=MIN(rb_wat(I), 2.0) ENDIF ! end water point IF (dry(i)) THEN @@ -993,19 +1003,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_lnd(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_lnd*WSPD_lnd) + rb_lnd(I)=MAX(rb_lnd(I),-2.0) + rb_lnd(I)=MIN(rb_lnd(I), 2.0) !From Tilden Meyers: !IF (rb_lnd(I) .GE 0.0) THEN ! ust_lnd(i)=WSPD_lnd*0.1/(1.0 + 10.0*rb_lnd(I)) !ELSE ! ust_lnd(i)=WSPD_lnd*0.1*(1.0 - 10.0*rb_lnd(I))**onethird !ENDIF - IF (ITIMESTEP == 1) THEN - rb_lnd(I)=MAX(rb_lnd(I),-2.0) - rb_lnd(I)=MIN(rb_lnd(I), 2.0) - ELSE - rb_lnd(I)=MAX(rb_lnd(I),-4.0) - rb_lnd(I)=MIN(rb_lnd(I), 4.0) - ENDIF ENDIF ! end land point IF (icy(i)) THEN @@ -1036,13 +1041,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_ice(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_ice*WSPD_ice) - IF (ITIMESTEP == 1) THEN - rb_ice(I)=MAX(rb_ice(I),-2.0) - rb_ice(I)=MIN(rb_ice(I), 2.0) - ELSE - rb_ice(I)=MAX(rb_ice(I),-4.0) - rb_ice(I)=MIN(rb_ice(I), 4.0) - ENDIF + rb_ice(I)=MAX(rb_ice(I),-2.0) + rb_ice(I)=MIN(rb_ice(I), 2.0) ENDIF ! end ice point !NOW CONDENSE THE POSSIBLE WSPD VALUES BY TAKING THE MAXIMUM @@ -1325,27 +1325,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(i)) THEN IF (rb_wat(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),20.) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),20.) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),20.) @@ -1391,26 +1393,28 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !========================================================== !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0) - ZOL(I)=MIN(ZOL(I),0.0) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) @@ -1458,27 +1462,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (dry(i)) THEN IF (rb_lnd(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),20.) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),20.) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),20.) @@ -1522,27 +1528,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0) - ZOL(I)=MIN(ZOL(I),0.0) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) @@ -1589,27 +1597,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(i)) THEN IF (rb_ice(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),20.) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),20.) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),20.) @@ -1653,27 +1663,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0) - ZOL(I)=MIN(ZOL(I),0.0) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) @@ -2270,7 +2282,8 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& & landsea,IZ0TLND2,spp_sfc,rstoch) IMPLICIT NONE - REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea + REAL(kind=kind_phys), INTENT(IN) :: ustar,KARMAN + REAL, INTENT(IN) :: Z_0,restar,landsea INTEGER, OPTIONAL, INTENT(IN):: IZ0TLND2 REAL, INTENT(OUT) :: Zt,Zq REAL :: CZIL !=0.100 in Chen et al. (1997) @@ -2339,8 +2352,8 @@ SUBROUTINE davis_etal_2008(Z_0,ustar) !corrects a small-bias in Z_0 (AHW real-time 2012). IMPLICIT NONE - REAL, INTENT(IN) :: ustar - REAL, INTENT(OUT) :: Z_0 + REAL(kind=kind_phys), INTENT(IN) :: ustar + REAL(kind=kind_phys), INTENT(OUT) :: Z_0 REAL :: ZW, ZN1, ZN2 REAL, PARAMETER :: G=9.81, OZO=1.59E-5 @@ -2366,8 +2379,8 @@ END SUBROUTINE davis_etal_2008 SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) IMPLICIT NONE - REAL, INTENT(IN) :: ustar,wsp10 - REAL, INTENT(OUT) :: Z_0 + REAL(kind=kind_phys), INTENT(IN) :: ustar,wsp10 + REAL(kind=kind_phys), INTENT(OUT) :: Z_0 REAL, parameter :: g=9.81, pi=3.14159265 REAL :: hs, Tp, Lp @@ -2394,8 +2407,9 @@ END SUBROUTINE Taylor_Yelland_2001 SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) IMPLICIT NONE - REAL, INTENT(IN) :: ustar, visc, wsp10, zu - REAL, INTENT(OUT) :: Z_0 + REAL(kind=kind_phys), INTENT(IN) :: ustar, wsp10 + REAL, INTENT(IN) :: visc, zu + REAL(kind=kind_phys), INTENT(OUT) :: Z_0 REAL, PARAMETER :: G=9.81, CZO2=0.011 REAL :: CZC !variable charnock "constant" REAL :: wsp10m ! logarithmically calculated 10 m @@ -2419,8 +2433,9 @@ END SUBROUTINE charnock_1955 SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) IMPLICIT NONE - REAL, INTENT(IN) :: ustar, visc, wsp10, zu - REAL, INTENT(OUT) :: Z_0 + REAL(kind=kind_phys), INTENT(IN) :: ustar, wsp10 + REAL, INTENT(IN) :: visc, zu + REAL(kind=kind_phys), INTENT(OUT) :: Z_0 REAL, PARAMETER :: G=9.81 REAL, PARAMETER :: m=0.0017, b=-0.005 REAL :: CZC ! variable charnock "constant" @@ -2485,7 +2500,8 @@ END SUBROUTINE garratt_1992 SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE - REAL, INTENT(IN) :: Ren,ustar,visc,rstoch + REAL, INTENT(IN) :: Ren,visc,rstoch + REAL(kind=kind_phys), INTENT(IN) :: ustar INTEGER, INTENT(IN):: spp_sfc REAL, INTENT(OUT) :: Zt,Zq @@ -2529,7 +2545,8 @@ END SUBROUTINE fairall_etal_2003 SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE - REAL, INTENT(IN) :: Ren,ustar,visc,rstoch + REAL, INTENT(IN) :: Ren,visc,rstoch + REAL(kind=kind_phys), INTENT(IN) :: ustar INTEGER, INTENT(IN):: spp_sfc REAL, INTENT(OUT) :: Zt,Zq @@ -2576,7 +2593,8 @@ END SUBROUTINE fairall_etal_2014 SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc) IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc + REAL, INTENT(IN) :: Z_0, Ren, qst, visc + REAL(kind=kind_phys), INTENT(IN) :: ustar, tstar REAL :: ht, &! roughness height at critical Reynolds number tstar2, &! bounded T*, forced to be non-positive qstar2, &! bounded q*, forced to be non-positive @@ -2610,8 +2628,9 @@ END SUBROUTINE Yang_2008 !>\ingroup mynn_sfc SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) - REAL, INTENT(OUT) :: z0max - REAL, INTENT(IN) :: shdmax,z1,z0pert + REAL(kind=kind_phys), INTENT(OUT) :: z0max + REAL(kind=kind_phys), INTENT(IN) :: shdmax,z0pert + REAL, INTENT(IN) :: z1 INTEGER, INTENT(IN):: vegtype,ivegsrc REAL :: tem1, tem2 @@ -2671,7 +2690,8 @@ END SUBROUTINE GFS_z0_lnd SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) REAL, INTENT(OUT) :: ztmax - REAL, INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd + REAL(kind=kind_phys), INTENT(IN) :: ustar_lnd,sigmaf,ztpert + REAL, INTENT(IN) :: z0max REAL :: czilc, tem1, tem2 REAL, PARAMETER :: ca = 0.4 @@ -2698,9 +2718,10 @@ END SUBROUTINE GFS_zt_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) - REAL, INTENT(OUT) :: z0rl_wat - REAL, INTENT(INOUT):: ustar_wat - REAL, INTENT(IN) :: wspd,z1 + REAL(kind=kind_phys), INTENT(OUT) :: z0rl_wat + REAL(kind=kind_phys), INTENT(INOUT):: ustar_wat + REAL(kind=kind_phys), INTENT(IN) :: wspd + REAL, INTENT(IN) :: z1 LOGICAL, INTENT(IN):: redrag INTEGER, INTENT(IN):: sfc_z0_type REAL :: z0,z0max,wind10m @@ -2752,7 +2773,8 @@ END SUBROUTINE GFS_z0_wat SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type) REAL, INTENT(OUT) :: ztmax - REAL, INTENT(IN) :: wspd,z1,z0rl_wat,restar + REAL, INTENT(IN) :: restar,z1,z0rl_wat + REAL(kind=kind_phys), INTENT(IN) :: wspd INTEGER, INTENT(IN):: sfc_z0_type REAL :: z0,z0max,wind10m,rat,ustar_wat REAL, PARAMETER :: charnock = 0.014, z0s_max=.317e-2 @@ -2808,8 +2830,8 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & @@ -3029,7 +3051,8 @@ END SUBROUTINE znot_t_v7 SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, bvisc, ustar + REAL(kind=kind_phys), INTENT(IN) :: ustar + REAL, INTENT(IN) :: Z_0, bvisc REAL, INTENT(OUT) :: Zt, Zq REAL :: Ren2, zntsno @@ -3078,7 +3101,8 @@ END SUBROUTINE Andreas_2002 SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) IMPLICIT NONE - REAL, INTENT(IN) :: zL, Zt, Z_0, Za + REAL(kind=kind_phys), INTENT(IN) :: Z_0 + REAL, INTENT(IN) :: zL, Zt, Za REAL, INTENT(OUT) :: psi_m, psi_h REAL :: x, x0, y, y0, zmL, zhL @@ -3116,7 +3140,8 @@ END SUBROUTINE PSI_Hogstrom_1996 SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) IMPLICIT NONE - REAL, INTENT(IN) :: zL, Zt, Z_0, Za + REAL(kind=kind_phys), INTENT(IN) :: Z_0 + REAL, INTENT(IN) :: zL, Zt, Za REAL, INTENT(OUT) :: psi_m, psi_h REAL :: x, x0, y, y0, zmL, zhL @@ -3300,8 +3325,9 @@ END SUBROUTINE PSI_CB2005 SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) IMPLICIT NONE - REAL, INTENT(OUT) :: zL - REAL, INTENT(IN) :: Rib, zaz0, z0zt + REAL(kind=kind_phys), INTENT(OUT) :: zL + REAL(kind=kind_phys), INTENT(IN) :: Rib + REAL, INTENT(IN) :: zaz0, z0zt REAL :: alfa, beta, zaz02, z0zt2 REAL, PARAMETER :: au11=0.045, bu11=0.003, bu12=0.0059, & &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & @@ -3354,7 +3380,7 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) END SUBROUTINE Li_etal_2010 !------------------------------------------------------------------- - REAL function zolri(ri,za,z0,zt,zol1,psi_opt) + REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) ! This iterative algorithm was taken from the revised surface layer ! scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and @@ -3363,7 +3389,8 @@ REAL function zolri(ri,za,z0,zt,zol1,psi_opt) ! estimate of z/L. IMPLICIT NONE - REAL, INTENT(IN) :: ri,za,z0,zt,zol1 + REAL, INTENT(IN) :: za,z0,zt + REAL(kind=kind_phys), INTENT(IN) :: ri,zol1 INTEGER, INTENT(IN) :: psi_opt REAL :: x1,x2,fx1,fx2 INTEGER :: n @@ -3422,7 +3449,8 @@ REAL function zolri2(zol2,ri2,za,z0,zt,psi_opt) IMPLICIT NONE INTEGER, INTENT(IN) :: psi_opt - REAL, INTENT(IN) :: ri2,za,z0,zt + REAL, INTENT(IN) :: za,z0,zt + REAL(kind=kind_phys), INTENT(IN) :: ri2 REAL, INTENT(INOUT) :: zol2 REAL :: zol20,zol3,psim1,psih1,psix2,psit2,zolt @@ -3451,14 +3479,15 @@ REAL function zolri2(zol2,ri2,za,z0,zt,psi_opt) end function !==================================================================== - REAL function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + REAL(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) ! This iterative algorithm to compute z/L from bulk-Ri IMPLICIT NONE - REAL, INTENT(IN) :: ri,za,z0,zt,logz0,logzt + REAL(kind=kind_phys), INTENT(IN) :: ri + REAL(kind=kind_phys), INTENT(INOUT) :: zol1 + REAL, INTENT(IN) :: za,z0,zt,logz0,logzt INTEGER, INTENT(IN) :: psi_opt - REAL, INTENT(INOUT) :: zol1 REAL :: zol20,zol3,zolt,zolold INTEGER :: n INTEGER, PARAMETER :: nmax = 20 diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index c879b0b399..176885d625 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -25,6 +25,15 @@ MODULE module_sf_ruclsm real (kind=kind_phys), parameter :: rhowater= 1000. real (kind=kind_phys), parameter :: piconst = 3.1415926535897931 real (kind=kind_phys), parameter :: r_v = 4.6150e+2 + + !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 + integer, parameter :: isncond_opt = 2 + + !-- Snow fraction options + !-- option 1: original formulation using critical snow depth to compute snow fraction + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. + integer, parameter :: isncovr_opt = 1 + !! @} !> VEGETATION PARAMETERS @@ -1035,8 +1044,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - !ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + !ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. smtotold (I,J) = smtotold(I,J) * 1000. ! mm @@ -1417,8 +1426,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER :: K,ILNB - integer :: isncovr_opt - REAL :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET @@ -1444,7 +1451,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- option 1: original formulation using critical snow depth to compute !-- snow fraction !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. - isncovr_opt = 1 + !isncovr_opt = 1 !-- !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 snhei_crit=0.01601*1.e3/rhosn @@ -4018,7 +4025,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & REAL, DIMENSION(1:NZS) :: cotso,rhtso REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr - integer :: nmelt, isncond_opt + integer :: nmelt REAL :: keff @@ -4031,7 +4038,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - isncond_opt = 1 + !isncond_opt = 2 keff = 0.265 !--- SNOW flag -- ISICE @@ -5177,7 +5184,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & hfx REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff - integer :: nmelt, iter, isncond_opt + integer :: nmelt, iter !----------------------------------------------------------------- @@ -5186,7 +5193,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - isncond_opt = 1 + !isncond_opt = 1 keff = 0.265 do k=1,nzs diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index b669611ebc..8ac6378bd6 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -83,12 +83,6 @@ subroutine mynnedmf_wrapper_init ( & return end if - if (lheatstrg) then - errmsg = 'Logic error: lheatstrg not implemented for MYNN PBL' - errflg = 1 - return - end if - end subroutine mynnedmf_wrapper_init subroutine mynnedmf_wrapper_finalize () @@ -169,7 +163,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! should be moved to inside the mynn: use machine, only: kind_phys use bl_mynn_common, only: cp, r_d, grav, g_inv, zero, & - xlv, xlvcp, xlscp + xlv, xlvcp, xlscp, p608 use module_bl_mynn, only: mynn_bl_driver !------------------------------------------------------------------- @@ -211,7 +205,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & imp_physics_thompson, imp_physics_gfdl, & & imp_physics_nssl, & & spp_pbl - real, intent(in) :: & + real(kind=kind_phys), intent(in) :: & & bl_mynn_closure !TENDENCY DIAGNOSTICS @@ -279,7 +273,7 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw ! spp_wts_pbl only allocated if spp_pbl == 1 - real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + real(kind=kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL real(kind=kind_phys), dimension(im,levs) :: & @@ -291,7 +285,7 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - real(kind_phys), dimension(:), intent(inout) :: frp + real(kind=kind_phys), dimension(:), intent(inout) :: frp logical, intent(in) :: mix_chem, enh_mix, rrfs_sd real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind=kind_phys), dimension(:,: ), intent(inout) :: vdep @@ -572,11 +566,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im ! dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv th(i,k)=t3d(i,k)/exner(i,k) - ! keep as specific humidity - ! qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) - ! qc(i,k)=qc(i,k)/(1.0 - qvsh(i,k)) - ! qi(i,k)=qi(i,k)/(1.0 - qvsh(i,k)) - rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) + rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)*(1.+p608*max(sqv(i,k),1e-8))) w(i,k) = -omega(i,k)/(rho(i,k)*grav) enddo enddo @@ -594,6 +584,11 @@ SUBROUTINE mynnedmf_wrapper_run( & ch(i)=0.0 hfx(i)=hflx(i)*rho(i,1)*cp qfx(i)=qflx(i)*rho(i,1) + !filter bad incoming fluxes + if (hfx(i) > 1200.)hfx(i) = 1200. + if (hfx(i) < -500.)hfx(i) = -500. + if (qfx(i) > .0005)qfx(i) = 0.0005 + if (qfx(i) < -.0002)qfx(i) = -0.0002 dtsfc1(i) = hfx(i) dqsfc1(i) = qfx(i)*XLV @@ -1037,9 +1032,9 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th + real(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind=kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, th integer k real :: dqc2, dqi2, dqv2, sum, aa, dum real, parameter :: qvmin1= 1e-8, & !min at k=1 diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90 index c4da027f19..a3b47e6e24 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -304,6 +304,7 @@ SUBROUTINE mynnsfc_wrapper_run( & z0pert=z0pert,ztpert=ztpert, & !intent(in) redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & + flag_restart=flag_restart, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) tsurf_wat=tsurf_wat, tsurf_lnd=tsurf_lnd, tsurf_ice=tsurf_ice, & !intent(in) diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index 6567a331b2..73419a1402 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -124,7 +124,8 @@ subroutine sgscloud_radpre_run( & real :: rhgrid,h2oliq,qsat,tem1,tem2,clwt,es,onemrh,value !Chaboureau and Bechtold (2002 and 2005) - real :: a, f, sigq, qmq, qt, xl, tlk, th, thl, rsl, cpm, cb_cf + real :: a, f, sigq, qmq, qt, xl, th, thl, rsl, cpm, cb_cf + real(kind=kind_phys) :: tlk !Option to convective cloud fraction integer, parameter :: conv_cf_opt = 0 !0: C-B, 1: X-R @@ -200,7 +201,7 @@ subroutine sgscloud_radpre_run( & !endif if (qc(i,k) < 1.e-6 .and. cldfra_bl(i,k)>0.001) then - qc(i,k) = qc_bl(i,k)*cldfra_bl(i,k) + qc(i,k) = qc_bl(i,k) !eff radius cloud water (microns) from Miles et al. (2007) if (nint(slmsk(i)) == 1) then !land @@ -219,7 +220,7 @@ subroutine sgscloud_radpre_run( & snow_frac = min(0.5, max((p3d(i,k)-30000.0),0.0)/140000.0) ice_frac = 1.0 - snow_frac if (qi(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qi(i,k) = ice_frac*qi_bl(i,k)*cldfra_bl(i,k) + 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.) @@ -232,7 +233,7 @@ subroutine sgscloud_radpre_run( & endif if (qs(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qs(i,k) = snow_frac*qi_bl(i,k)*cldfra_bl(i,k) + 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.) @@ -289,10 +290,11 @@ subroutine sgscloud_radpre_run( & !Partition the convective clouds into water & frozen species liqfrac = min(1., max(0., (Tk-244.)/29.)) - qc(i,k) = qc(i,k)+qci_conv(i,k)*liqfrac + !For now, GF mixing ratios are added elsewhere. + !qc(i,k) = qc(i,k)+qci_conv(i,k)*liqfrac !split ice & snow 50-50% - qi(i,k) = qi(i,k)+0.5*qci_conv(i,k)*(1. - liqfrac) - qs(i,k) = qs(i,k)+0.5*qci_conv(i,k)*(1. - liqfrac) + !qi(i,k) = qi(i,k)+0.5*qci_conv(i,k)*(1. - liqfrac) + !qs(i,k) = qs(i,k)+0.5*qci_conv(i,k)*(1. - liqfrac) !eff radius cloud water (microns) if (nint(slmsk(i)) == 1) then !land @@ -333,10 +335,15 @@ subroutine sgscloud_radpre_run( & sigq = SQRT(sigq**2 + 1e-10) ! combined conv + background components qmq = a * (qt - qsat) ! saturation deficit/excess; ! the numerator of Q1 - cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.99) + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.0),0.99) + if (qci_conv(i,k) .lt. 1e-9) cb_cf = 0.0 if (do_mynnedmf .and. qmq .ge. 0.0) then ! leverage C-B stratus clouds from MYNN in saturated conditions - clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + if (cb_cf .gt. 0.0) then + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else + !default to MYNN clouds - already specified + endif else ! unsaturated clouds1(i,k) = cb_cf endif From 76cc805fb63f89a2e65924d4b9064d72c4642bc7 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Thu, 3 Nov 2022 19:58:17 +0000 Subject: [PATCH 49/50] "update smoke emission reading and direct feedback" --- physics/GFS_rrtmg_pre.F90 | 19 +++++++++++++++++-- physics/GFS_rrtmg_pre.meta | 16 +++++++++++++++- physics/smoke/rrfs_smoke_wrapper.F90 | 8 ++++---- 3 files changed, 36 insertions(+), 7 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index e9a301a8f6..75fa427394 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -19,7 +19,7 @@ end subroutine GFS_rrtmg_pre_init subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & - ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, ntsmoke, ntdust, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & @@ -88,6 +88,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntsmoke, ntdust, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & @@ -136,7 +137,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & cnvw_in, cnvc_in, & sppt_wts - real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs, aer_nm + real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: aer_nm real(kind=kind_phys), dimension(:), intent(inout) :: coszen, coszdg @@ -602,6 +604,19 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !check print *,' in grrad : calling setaer ' +!>--- add smoke and dust --- + if (aero_dir_fdb) then + do k=1,lmk + do i=1,im + aer_nm(i,k,1 )=aer_nm(i,k,1 )+qgrs(i,k,ntdust )*0.11 + aer_nm(i,k,2 )=aer_nm(i,k,1 )+qgrs(i,k,ntdust )*0.89 + aer_nm(i,k,12)=aer_nm(i,k,12)+qgrs(i,k,ntsmoke)*0.01 + aer_nm(i,k,14)=aer_nm(i,k,14)+qgrs(i,k,ntsmoke)*0.99 + enddo + enddo + endif +!>---------------------------- + call setaer (plvl, plyr, prslk1, tvly, rhly, slmsk, & ! --- inputs tracer1, aer_nm, xlon, xlat, IM, LMK, LMP,& lsswr,lslwr, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 79e3050d26..1efe2bb35e 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -205,6 +205,20 @@ dimensions = () type = integer intent = in +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -719,7 +733,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_tracers_MG) type = real kind = kind_phys - intent = in + intent = inout [dx] standard_name = characteristic_grid_lengthscale long_name = relative dx for the grid cell diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 index c47477fe57..883d480368 100755 --- a/physics/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -691,12 +691,12 @@ subroutine rrfs_smoke_prep( & emis_anoc(i) = emi_in(i,1) enddo - if (hour_int<=24) then + if (hour_int<24) then do j=jts,jte do i=its,ite - ebb_smoke_hr(i) = smoke_RRFS(i,int(gmt)+1,1) ! smoke - frp_hr (i) = smoke_RRFS(i,int(gmt)+1,2) ! frp - frp_std_hr (i) = smoke_RRFS(i,int(gmt)+1,3) ! std frp + ebb_smoke_hr(i) = smoke_RRFS(i,hour_int+1,1) ! smoke + frp_hr (i) = smoke_RRFS(i,hour_int+1,2) ! frp + frp_std_hr (i) = smoke_RRFS(i,hour_int+1,3) ! std frp ebu_in (i,j) = ebb_smoke_hr(i) plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) From e7a4ddfd2ed4890518d9d2fcb7a900e4d34b1b51 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 9 Nov 2022 15:23:24 +0000 Subject: [PATCH 50/50] "use snow from LSM instead of that from MP for dust" --- physics/smoke/rrfs_smoke_wrapper.F90 | 2 +- physics/smoke/rrfs_smoke_wrapper.meta | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 index 883d480368..7c2c88345a 100755 --- a/physics/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -380,7 +380,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, hwp = 0. do i=its,ite wdgust(i)=max(1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2),3.) - snoweq(i)=max((25.-snow(i)*1000.)/25.,0.) + snoweq(i)=max((25.-snow(i))/25.,0.) hwp(i)=0.237*wdgust(i)**1.11*max(t2m(i)-dpt2m(i),15.)**0.92*((1.-wetness(i))**6.95)*snoweq(i) ! Eric 08/2022 enddo diff --git a/physics/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta index 1a53981784..8280084c72 100755 --- a/physics/smoke/rrfs_smoke_wrapper.meta +++ b/physics/smoke/rrfs_smoke_wrapper.meta @@ -263,9 +263,9 @@ kind = kind_phys intent = in [snow] - standard_name = lwe_thickness_of_snow_amount - long_name = snow fall on physics timestep - units = m + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys